annotate implementations/midi/methods.lisp @ 330:2fbff655ba47 tip

Removed cpitch-adj and cents SQL columns
author Jeremy Gow <jeremy.gow@gmail.com>
date Mon, 21 Jan 2013 11:08:11 +0000
parents 46dd71ef9ab3
children
rev   line source
d@34 1 (cl:in-package #:amuse-midi)
d@34 2
j@302 3 (defgeneric midi-channel (midi-message)
d@134 4 (:documentation "MIDI channel. Also used for midi output"))
d@34 5 (defmethod midi-channel ((midi-message midi-message))
d@34 6 (%midi-message-channel midi-message))
d@34 7
j@317 8 (defgeneric (setf midi-channel) (value event))
j@317 9 (defmethod (setf midi-channel) (value (event midi-message))
j@317 10 (setf (%midi-message-channel event) value) event)
j@317 11
d@134 12 (defgeneric midi-track (midi-message)
d@134 13 (:documentation "MIDI track. Also used for midi output"))
d@34 14 (defmethod midi-track ((midi-message midi-message))
d@34 15 (%midi-message-track midi-message))
d@34 16
j@317 17 (defgeneric (setf midi-track) (value event))
j@317 18 (defmethod (setf midi-track) (value (event midi-message))
j@317 19 (setf (%midi-message-track event) value) event)
j@317 20
d@134 21 (defgeneric midi-velocity (event)
d@134 22 (:documentation "MIDI velocity. Also used for midi output"))
d@34 23 (defmethod midi-velocity ((event midi-pitched-event))
d@34 24 (%midi-pitched-event-velocity event))
d@34 25 (defmethod midi-velocity ((event midi-percussive-event))
d@34 26 (%midi-percussive-event-velocity event))
d@34 27
j@317 28 (defgeneric (setf midi-velocity) (value event))
j@317 29 (defmethod (setf midi-velocity) (value (event midi-pitched-event))
j@317 30 (setf (%midi-pitched-event-velocity event) value) event)
j@317 31 (defmethod (setf midi-velocity) (value (event midi-percussive-event))
j@317 32 (setf (%midi-percussive-event-velocity event) value) event)
j@317 33
d@134 34 (defgeneric midi-patch (event)
d@134 35 (:documentation "MIDI patch (instrumental sound). Also used for
d@134 36 midi output"))
d@34 37 (defmethod midi-patch ((event midi-pitched-event))
d@34 38 (%midi-pitched-event-patch event))
j@317 39 (defmethod midi-patch ((event midi-percussive-event))
j@317 40 (%midi-percussive-event-patch event))
d@34 41
j@317 42 (defgeneric (setf midi-patch) (value event))
j@317 43 (defmethod (setf midi-patch) (value (event midi-pitched-event))
j@317 44 (setf (%midi-pitched-event-patch event) value) event)
j@317 45 (defmethod (setf midi-patch) (value (event midi-percussive-event))
j@317 46 (setf (%midi-percussive-event-patch event) value) event)
j@302 47
d@134 48 (defgeneric midi-drum-sound (event)
d@134 49 (:documentation "MIDI pitch for unpitched events (usually, drum
d@134 50 sound for drum kits on channel 10, but also for semi-pitched
d@134 51 SFX, etc). Also used for midi output"))
d@34 52 (defmethod midi-drum-sound ((event midi-percussive-event))
d@34 53 (%midi-percussive-event-sound event))
d@34 54
j@317 55 (defgeneric (setf midi-drum-sound) (value event))
j@317 56 (defmethod (setf midi-drum-sound) (value (event midi-percussive-event))
j@317 57 (setf (%midi-percussive-event-sound event) value) event)
j@317 58
j@317 59 (defgeneric midi-note-number (event)
j@317 60 (:documentation "Same as get-pitch-for-midi"))
j@317 61 (defmethod midi-note-number ((event midi-pitched-event))
j@317 62 (midi-pitch-number event))
j@317 63 (defmethod midi-note-number ((event midi-percussive-event))
j@317 64 (midi-drum-sound event))
j@317 65
j@302 66 (defgeneric midi-drum-sound= (event1 event2))
j@302 67 (defmethod midi-drum-sound= ((event1 midi-percussive-event)
j@302 68 (event2 midi-percussive-event))
j@302 69 (= (midi-drum-sound event1) (midi-drum-sound event2)))
j@302 70 (defmethod midi-drum-sound= ((event1 event)
j@302 71 (event2 event))
j@302 72 "Return nil for any comparisons involving non-percussive events."
j@302 73 nil)
j@302 74
d@34 75 (defmethod time-signatures ((composition midi-composition))
d@34 76 (%midi-time-signatures composition))
d@34 77 (defmethod (setf time-signatures) (sequence (composition midi-composition))
d@34 78 (setf (%midi-time-signatures composition) sequence))
d@34 79 (defmethod tempi ((composition midi-composition))
d@34 80 (%midi-tempi composition))
d@34 81 (defmethod (setf tempi) (sequence (composition midi-composition))
d@34 82 (setf (%midi-tempi composition) sequence))
d@115 83 (defmethod key-signatures ((composition midi-composition))
d@115 84 (%midi-key-signatures composition))
d@115 85 (defmethod (setf key-signatures) (sequence (composition midi-composition))
d@115 86 (setf (%midi-key-signatures composition) sequence))
d@34 87
j@281 88 (defgeneric midi-timebase (composition))
j@281 89 (defmethod midi-timebase ((composition midi-composition))
j@281 90 (%midi-timebase composition))
j@281 91
d@34 92 ;; FIXME: This ought to call-next-method and operate on the result,
d@34 93 ;; rather than calling internals from the other package
d@34 94 (defmethod copy-event ((event midi-pitched-event))
d@34 95 (with-slots (channel track (number amuse::number) (time amuse::time) (interval amuse::interval) velocity patch)
d@34 96 event
d@34 97 (make-instance 'midi-pitched-event
d@34 98 :channel channel
d@34 99 :track track
d@34 100 :number number
d@34 101 :time time
d@34 102 :interval interval
d@34 103 :velocity velocity
d@34 104 :patch patch)))
d@34 105 (defmethod copy-event ((event midi-percussive-event))
d@34 106 (with-slots (channel track (time amuse::time) (interval amuse::interval) velocity patch sound)
d@34 107 event
d@34 108 (make-instance 'midi-percussive-event
d@34 109 :channel channel
d@34 110 :track track
d@34 111 :time time
d@34 112 :interval interval
d@34 113 :velocity velocity
d@34 114 :patch patch
d@34 115 :sound sound)))
d@154 116 (defgeneric copy-time-signature (time-signature))
d@154 117 (defmethod copy-time-signature ((time-signature standard-time-signature))
d@154 118 (make-instance (class-of time-signature)
d@154 119 :numerator (time-signature-numerator time-signature)
d@154 120 :denominator (time-signature-denominator time-signature)))
d@154 121 (defmethod copy-time-signature ((time-signature-period standard-time-signature-period))
d@154 122 (let ((sig (call-next-method)))
d@154 123 (setf (timepoint sig) (timepoint time-signature-period)
d@154 124 (duration sig) (duration time-signature-period))
d@154 125 sig))
d@154 126 (defgeneric copy-tempo (tempo))
d@154 127 (defmethod copy-tempo ((tempo standard-tempo))
d@154 128 (make-instance (class-of tempo)
d@154 129 :bpm (bpm tempo)))
d@154 130 (defmethod copy-tempo ((tempo-period standard-tempo-period))
d@154 131 (let ((tp (call-next-method)))
d@154 132 (setf (timepoint tp) (timepoint tempo-period)
d@154 133 (duration tp) (duration tempo-period))
d@154 134 tp))
d@154 135 (defgeneric copy-key-signature (key-signature))
d@154 136 (defmethod copy-key-signature ((key-signature standard-key-signature))
d@154 137 (make-instance (class-of key-signature)
d@154 138 :sharp-count (key-signature-sharps key-signature)
d@154 139 :mode (key-signature-mode key-signature)))
d@154 140 (defmethod copy-key-signature ((key-signature-period standard-key-signature-period))
d@154 141 (let ((sig (call-next-method)))
d@154 142 (setf (timepoint sig) (timepoint key-signature-period)
d@154 143 (duration sig) (duration key-signature-period))
d@154 144 sig))
d@154 145
d@34 146
d@34 147
d@34 148 ;; Allow derived sequences from remove-if, etc. to preserve other slot
d@34 149 ;; info (timesigs, etc)
d@154 150 #+nil
d@34 151 (defmethod sequence:make-sequence-like :around ((o midi-composition) length
d@34 152 &key (initial-element nil iep)
d@34 153 (initial-contents nil icp))
d@34 154 (declare (ignore length initial-element initial-contents))
d@34 155 (let ((result (call-next-method)))
d@34 156 (cond
d@34 157 ((or iep icp)
d@34 158 (setf (timepoint result) (timepoint (elt result 0))
d@34 159 (duration result) (- (timepoint
d@34 160 (loop for e being the elements of result
d@34 161 maximize (cut-off e)))
d@34 162 (timepoint (elt result 0)))))
d@34 163 (t (setf (timepoint result) 0
d@34 164 (duration result) 0)))
d@34 165 (with-slots (time-signatures tempi misc-controllers)
d@34 166 o
d@34 167 (setf (%midi-time-signatures result) time-signatures
d@34 168 (%midi-tempi result) tempi
d@34 169 (%midi-misc-controllers result) misc-controllers))
d@34 170 result))
d@153 171
d@34 172
d@34 173 ;; useful little function
d@34 174
d@34 175 (defun microsecond-per-crotchet-to-bpm (mu-per-c)
d@34 176 (/ 60000000 mu-per-c))
d@34 177
d@34 178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
d@34 179 ;;
d@34 180 ;; MIDI playback methods
d@34 181
d@34 182 (defmethod get-patch-for-midi ((event midi-pitched-event))
d@34 183 ;; FIXME
d@34 184 (midi-patch event))
d@34 185
d@34 186 (defmethod get-channel-for-midi ((event midi-message))
d@34 187 ;; FIXME 1- ??? I'm only doing this because of the Geerdes
d@34 188 ;; database. Looks like a recipe for disaster. Think should probably
d@34 189 ;; enforce 0-15.
d@34 190 (1- (midi-channel event)))
d@34 191
d@34 192 (defmethod get-velocity-for-midi ((event midi-message))
d@34 193 ;; FIXME: under-exclusive specialisation. Does this matter?
d@34 194 (midi-velocity event))
d@34 195
d@34 196 (defmethod get-pitch-for-midi ((event midi-percussive-event))
d@34 197 (midi-drum-sound event))
d@34 198
d@34 199 (defmethod get-pitch-for-midi ((event midi-pitched-event))
d@41 200 (midi-pitch-number event))
d@41 201
d@41 202 ;; Have avoided percussion vs pitched, as this is more obviously
d@41 203 ;; meaningless.
d@41 204 (defmethod significantly-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event))
d@41 205 (>= (/ (midi-velocity event1)
d@41 206 (midi-velocity event2))
d@41 207 4/3))
d@41 208 (defmethod significantly-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event))
d@41 209 (>= (/ (midi-velocity event1)
d@41 210 (midi-velocity event2))
d@41 211 4/3))
d@41 212 (defmethod substantially-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event))
d@41 213 (>= (/ (midi-velocity event1)
d@41 214 (midi-velocity event2))
d@41 215 2))
d@41 216 (defmethod substantially-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event))
d@41 217 (>= (/ (midi-velocity event1)
d@41 218 (midi-velocity event2))
d@41 219 2))
d@114 220
d@130 221 (defmethod crotchet ((object midi-object))
d@139 222 (make-standard-period 1))
d@157 223
d@157 224 (defmethod monody ((identifier midifile-identifier))
d@157 225 (monody (get-composition identifier)))
d@157 226
d@157 227 ;; TODO: improve this naive first-cut at MONODY for midi files which
d@157 228 ;; simply selects a track which is both monodic (if any monodic tracks
d@157 229 ;; exist) and contains the highest pitch of any monodic track.
d@157 230 (defmethod monody ((c midi-composition))
d@157 231 (flet ((not-overlapping (track)
d@157 232 (let ((result t)
d@157 233 (track (sort (copy-list track) #'amuse:time<)))
d@157 234 (dotimes (i (1- (length track)) result)
d@157 235 (let ((e1 (elt track i))
d@157 236 (e2 (elt track (1+ i))))
d@157 237 (unless (or (before e1 e2) (meets e1 e2))
d@157 238 (setf result nil)))))))
d@157 239 (let ((tracks (make-hash-table))
d@157 240 (result nil)
d@157 241 (max-pitch 0))
d@157 242 (sequence:dosequence (message c)
d@157 243 (let* ((tracknum (amuse-midi:midi-track message))
d@157 244 (track (gethash tracknum tracks)))
d@157 245 (setf (gethash tracknum tracks) (cons message track))))
d@157 246 (maphash #'(lambda (k v)
d@157 247 (declare (ignore k))
d@157 248 (let ((max (apply #'max (mapcar #'midi-pitch-number v))))
d@157 249 (when (and (not-overlapping v) (> max max-pitch))
d@157 250 (setf result (sort v #'amuse:time<)
d@157 251 max-pitch max))))
d@157 252 tracks)
d@157 253 (when result
d@157 254 (let ((monody (make-instance 'midi-monody
d@157 255 :time (amuse:timepoint c)
d@157 256 :interval (amuse:duration c)
d@157 257 :time-signatures (time-signatures c)
d@157 258 :key-signatures (key-signatures c)
d@157 259 :tempi (tempi c)
d@157 260 :controllers (%midi-misc-controllers c))))
d@157 261 (sequence:adjust-sequence monody (length result)
d@157 262 :initial-contents result)
d@157 263 monody)))))
d@157 264
d@157 265 (defmethod trim-enclosing-silence ((composition midi-composition))
d@157 266 (let ((start (timepoint (bar-before (onset (elt composition 0))
d@157 267 composition)))
d@157 268 (end)
d@157 269 (new-sequence) (new-composition))
d@157 270 ;; First attend to the events themselves - copy and slide
d@157 271 (sequence:dosequence (event composition)
d@157 272 (push (copy-event event) new-sequence)
d@157 273 (setf (timepoint (car new-sequence)) (- (timepoint event)
d@157 274 start))
d@157 275 (when (or (not end)
d@157 276 (> (timepoint (cut-off event)) end))
d@157 277 (setf end (timepoint (cut-off event)))))
d@157 278 ;; Make the new composition with slid events
d@157 279 ;; Should work, but doesn't
d@157 280 #+nil
d@157 281 (setf new-composition (sequence:make-sequence-like composition 0))
d@157 282 (setf new-composition (make-instance 'midi-composition
d@157 283 :time 0
d@157 284 :interval (- end start)))
d@157 285 (setf (amuse::%list-slot-sequence-data new-composition)
d@157 286 (reverse new-sequence))
d@157 287 ;; Time-sigs
d@157 288 (let ((sigs))
d@157 289 (dolist (sig (time-signatures composition))
d@157 290 ;; only include if signature affects window
d@157 291 (when (and (> (timepoint (cut-off sig))
d@157 292 start)
d@157 293 (< (timepoint sig)
d@157 294 end))
d@157 295 ;; copy the signature
d@157 296 (push (copy-time-signature sig)
d@157 297 sigs)
d@157 298 ;; adjust the timing
d@157 299 (setf (timepoint (car sigs))
d@157 300 (max 0 (- (timepoint (car sigs)) start))
d@157 301 (duration (car sigs))
d@157 302 (- (min (timepoint (cut-off (car sigs)))
d@157 303 (- end start))
d@157 304 (timepoint (car sigs))))))
d@157 305 (setf (time-signatures new-composition) (reverse sigs)))
d@157 306 (let ((sigs))
d@157 307 (dolist (sig (key-signatures composition))
d@157 308 ;; only include if signature affects window
d@157 309 (when (and (> (timepoint (cut-off sig))
d@157 310 start)
d@157 311 (< (timepoint sig)
d@157 312 end))
d@157 313 ;; copy the signature
d@157 314 (push (copy-key-signature sig)
d@157 315 sigs)
d@157 316 ;; adjust the timing
d@157 317 (setf (timepoint (car sigs))
d@157 318 (max 0 (- (timepoint (car sigs)) start))
d@157 319 (duration (car sigs))
d@157 320 (- (min (timepoint (cut-off (car sigs)))
d@157 321 (- end start))
d@157 322 (timepoint (car sigs))))))
d@157 323 (setf (key-signatures new-composition) (reverse sigs)))
d@157 324 (let ((tempi))
d@157 325 (dolist (tempo (tempi composition))
d@157 326 ;; only include if signature affects window
d@157 327 (when (and (> (timepoint (cut-off tempo))
d@157 328 start)
d@157 329 (< (timepoint tempo)
d@157 330 end))
d@157 331 ;; copy the signature
d@157 332 (push (copy-tempo tempo)
d@157 333 tempi)
d@157 334 ;; adjust the timing
d@157 335 (setf (timepoint (car tempi))
d@157 336 (max 0 (- (timepoint (car tempi)) start))
d@157 337 (duration (car tempi))
d@157 338 (- (min (timepoint (cut-off (car tempi)))
d@157 339 (- end start))
d@157 340 (timepoint (car tempi))))))
d@157 341 (setf (tempi new-composition) (reverse tempi)))
d@157 342 new-composition))
d@157 343
d@157 344
d@157 345 (defgeneric bar-before (moment composition))
d@157 346
d@157 347 (defmethod bar-before (moment (composition midi-composition))
d@157 348 "Returns the moment at which the containing bar begins"
d@157 349 (do ((time-sigs (time-signatures composition) (cdr time-sigs)))
d@157 350 ((null time-sigs) nil)
d@157 351 (let ((bar-period (make-standard-period
d@157 352 (crotchets-in-a-bar (car time-sigs)))))
d@157 353 (when (time> (cut-off (car time-sigs))
d@157 354 moment)
d@157 355 (do ((bar (time+ (onset (car time-sigs)) bar-period)
d@157 356 (time+ bar bar-period))
d@157 357 (prev-bar (onset (car time-sigs))))
d@157 358 ((time> bar moment) (return-from bar-before prev-bar))
d@165 359 (setf prev-bar bar))))))
d@165 360
d@165 361 (defmethod get-applicable-time-signatures ((anchored-period anchored-period)
d@165 362 (composition midi-composition))
d@165 363 (%find-overlapping anchored-period (time-signatures composition)))
d@165 364 (defmethod get-applicable-tempi ((anchored-period anchored-period)
d@165 365 (composition midi-composition))
d@165 366 (%find-overlapping anchored-period (tempi composition)))
d@165 367 (defmethod get-applicable-key-signatures ((anchored-period anchored-period)
d@165 368 (composition midi-composition))
d@165 369 (%find-overlapping anchored-period (key-signatures composition)))
d@165 370
d@165 371 (defun %find-overlapping (period1 period-list)
d@165 372 (let ((result-list))
d@165 373 (dolist (period2 period-list result-list)
d@165 374 (cond
d@165 375 ((time>= period2 (cut-off period1))
d@165 376 (return-from %find-overlapping (reverse result-list)))
d@165 377 ((time> (cut-off period2) period1)
j@278 378 (push period2 result-list))))))