d@34: (cl:in-package #:amuse-midi) d@34: j@302: (defgeneric midi-channel (midi-message) d@134: (:documentation "MIDI channel. Also used for midi output")) d@34: (defmethod midi-channel ((midi-message midi-message)) d@34: (%midi-message-channel midi-message)) d@34: j@317: (defgeneric (setf midi-channel) (value event)) j@317: (defmethod (setf midi-channel) (value (event midi-message)) j@317: (setf (%midi-message-channel event) value) event) j@317: d@134: (defgeneric midi-track (midi-message) d@134: (:documentation "MIDI track. Also used for midi output")) d@34: (defmethod midi-track ((midi-message midi-message)) d@34: (%midi-message-track midi-message)) d@34: j@317: (defgeneric (setf midi-track) (value event)) j@317: (defmethod (setf midi-track) (value (event midi-message)) j@317: (setf (%midi-message-track event) value) event) j@317: d@134: (defgeneric midi-velocity (event) d@134: (:documentation "MIDI velocity. Also used for midi output")) d@34: (defmethod midi-velocity ((event midi-pitched-event)) d@34: (%midi-pitched-event-velocity event)) d@34: (defmethod midi-velocity ((event midi-percussive-event)) d@34: (%midi-percussive-event-velocity event)) d@34: j@317: (defgeneric (setf midi-velocity) (value event)) j@317: (defmethod (setf midi-velocity) (value (event midi-pitched-event)) j@317: (setf (%midi-pitched-event-velocity event) value) event) j@317: (defmethod (setf midi-velocity) (value (event midi-percussive-event)) j@317: (setf (%midi-percussive-event-velocity event) value) event) j@317: d@134: (defgeneric midi-patch (event) d@134: (:documentation "MIDI patch (instrumental sound). Also used for d@134: midi output")) d@34: (defmethod midi-patch ((event midi-pitched-event)) d@34: (%midi-pitched-event-patch event)) j@317: (defmethod midi-patch ((event midi-percussive-event)) j@317: (%midi-percussive-event-patch event)) d@34: j@317: (defgeneric (setf midi-patch) (value event)) j@317: (defmethod (setf midi-patch) (value (event midi-pitched-event)) j@317: (setf (%midi-pitched-event-patch event) value) event) j@317: (defmethod (setf midi-patch) (value (event midi-percussive-event)) j@317: (setf (%midi-percussive-event-patch event) value) event) j@302: d@134: (defgeneric midi-drum-sound (event) d@134: (:documentation "MIDI pitch for unpitched events (usually, drum d@134: sound for drum kits on channel 10, but also for semi-pitched d@134: SFX, etc). Also used for midi output")) d@34: (defmethod midi-drum-sound ((event midi-percussive-event)) d@34: (%midi-percussive-event-sound event)) d@34: j@317: (defgeneric (setf midi-drum-sound) (value event)) j@317: (defmethod (setf midi-drum-sound) (value (event midi-percussive-event)) j@317: (setf (%midi-percussive-event-sound event) value) event) j@317: j@317: (defgeneric midi-note-number (event) j@317: (:documentation "Same as get-pitch-for-midi")) j@317: (defmethod midi-note-number ((event midi-pitched-event)) j@317: (midi-pitch-number event)) j@317: (defmethod midi-note-number ((event midi-percussive-event)) j@317: (midi-drum-sound event)) j@317: j@302: (defgeneric midi-drum-sound= (event1 event2)) j@302: (defmethod midi-drum-sound= ((event1 midi-percussive-event) j@302: (event2 midi-percussive-event)) j@302: (= (midi-drum-sound event1) (midi-drum-sound event2))) j@302: (defmethod midi-drum-sound= ((event1 event) j@302: (event2 event)) j@302: "Return nil for any comparisons involving non-percussive events." j@302: nil) j@302: d@34: (defmethod time-signatures ((composition midi-composition)) d@34: (%midi-time-signatures composition)) d@34: (defmethod (setf time-signatures) (sequence (composition midi-composition)) d@34: (setf (%midi-time-signatures composition) sequence)) d@34: (defmethod tempi ((composition midi-composition)) d@34: (%midi-tempi composition)) d@34: (defmethod (setf tempi) (sequence (composition midi-composition)) d@34: (setf (%midi-tempi composition) sequence)) d@115: (defmethod key-signatures ((composition midi-composition)) d@115: (%midi-key-signatures composition)) d@115: (defmethod (setf key-signatures) (sequence (composition midi-composition)) d@115: (setf (%midi-key-signatures composition) sequence)) d@34: j@281: (defgeneric midi-timebase (composition)) j@281: (defmethod midi-timebase ((composition midi-composition)) j@281: (%midi-timebase composition)) j@281: d@34: ;; FIXME: This ought to call-next-method and operate on the result, d@34: ;; rather than calling internals from the other package d@34: (defmethod copy-event ((event midi-pitched-event)) d@34: (with-slots (channel track (number amuse::number) (time amuse::time) (interval amuse::interval) velocity patch) d@34: event d@34: (make-instance 'midi-pitched-event d@34: :channel channel d@34: :track track d@34: :number number d@34: :time time d@34: :interval interval d@34: :velocity velocity d@34: :patch patch))) d@34: (defmethod copy-event ((event midi-percussive-event)) d@34: (with-slots (channel track (time amuse::time) (interval amuse::interval) velocity patch sound) d@34: event d@34: (make-instance 'midi-percussive-event d@34: :channel channel d@34: :track track d@34: :time time d@34: :interval interval d@34: :velocity velocity d@34: :patch patch d@34: :sound sound))) d@154: (defgeneric copy-time-signature (time-signature)) d@154: (defmethod copy-time-signature ((time-signature standard-time-signature)) d@154: (make-instance (class-of time-signature) d@154: :numerator (time-signature-numerator time-signature) d@154: :denominator (time-signature-denominator time-signature))) d@154: (defmethod copy-time-signature ((time-signature-period standard-time-signature-period)) d@154: (let ((sig (call-next-method))) d@154: (setf (timepoint sig) (timepoint time-signature-period) d@154: (duration sig) (duration time-signature-period)) d@154: sig)) d@154: (defgeneric copy-tempo (tempo)) d@154: (defmethod copy-tempo ((tempo standard-tempo)) d@154: (make-instance (class-of tempo) d@154: :bpm (bpm tempo))) d@154: (defmethod copy-tempo ((tempo-period standard-tempo-period)) d@154: (let ((tp (call-next-method))) d@154: (setf (timepoint tp) (timepoint tempo-period) d@154: (duration tp) (duration tempo-period)) d@154: tp)) d@154: (defgeneric copy-key-signature (key-signature)) d@154: (defmethod copy-key-signature ((key-signature standard-key-signature)) d@154: (make-instance (class-of key-signature) d@154: :sharp-count (key-signature-sharps key-signature) d@154: :mode (key-signature-mode key-signature))) d@154: (defmethod copy-key-signature ((key-signature-period standard-key-signature-period)) d@154: (let ((sig (call-next-method))) d@154: (setf (timepoint sig) (timepoint key-signature-period) d@154: (duration sig) (duration key-signature-period)) d@154: sig)) d@154: d@34: d@34: d@34: ;; Allow derived sequences from remove-if, etc. to preserve other slot d@34: ;; info (timesigs, etc) d@154: #+nil d@34: (defmethod sequence:make-sequence-like :around ((o midi-composition) length d@34: &key (initial-element nil iep) d@34: (initial-contents nil icp)) d@34: (declare (ignore length initial-element initial-contents)) d@34: (let ((result (call-next-method))) d@34: (cond d@34: ((or iep icp) d@34: (setf (timepoint result) (timepoint (elt result 0)) d@34: (duration result) (- (timepoint d@34: (loop for e being the elements of result d@34: maximize (cut-off e))) d@34: (timepoint (elt result 0))))) d@34: (t (setf (timepoint result) 0 d@34: (duration result) 0))) d@34: (with-slots (time-signatures tempi misc-controllers) d@34: o d@34: (setf (%midi-time-signatures result) time-signatures d@34: (%midi-tempi result) tempi d@34: (%midi-misc-controllers result) misc-controllers)) d@34: result)) d@153: d@34: d@34: ;; useful little function d@34: d@34: (defun microsecond-per-crotchet-to-bpm (mu-per-c) d@34: (/ 60000000 mu-per-c)) d@34: d@34: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; d@34: ;; d@34: ;; MIDI playback methods d@34: d@34: (defmethod get-patch-for-midi ((event midi-pitched-event)) d@34: ;; FIXME d@34: (midi-patch event)) d@34: d@34: (defmethod get-channel-for-midi ((event midi-message)) d@34: ;; FIXME 1- ??? I'm only doing this because of the Geerdes d@34: ;; database. Looks like a recipe for disaster. Think should probably d@34: ;; enforce 0-15. d@34: (1- (midi-channel event))) d@34: d@34: (defmethod get-velocity-for-midi ((event midi-message)) d@34: ;; FIXME: under-exclusive specialisation. Does this matter? d@34: (midi-velocity event)) d@34: d@34: (defmethod get-pitch-for-midi ((event midi-percussive-event)) d@34: (midi-drum-sound event)) d@34: d@34: (defmethod get-pitch-for-midi ((event midi-pitched-event)) d@41: (midi-pitch-number event)) d@41: d@41: ;; Have avoided percussion vs pitched, as this is more obviously d@41: ;; meaningless. d@41: (defmethod significantly-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event)) d@41: (>= (/ (midi-velocity event1) d@41: (midi-velocity event2)) d@41: 4/3)) d@41: (defmethod significantly-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event)) d@41: (>= (/ (midi-velocity event1) d@41: (midi-velocity event2)) d@41: 4/3)) d@41: (defmethod substantially-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event)) d@41: (>= (/ (midi-velocity event1) d@41: (midi-velocity event2)) d@41: 2)) d@41: (defmethod substantially-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event)) d@41: (>= (/ (midi-velocity event1) d@41: (midi-velocity event2)) d@41: 2)) d@114: d@130: (defmethod crotchet ((object midi-object)) d@139: (make-standard-period 1)) d@157: d@157: (defmethod monody ((identifier midifile-identifier)) d@157: (monody (get-composition identifier))) d@157: d@157: ;; TODO: improve this naive first-cut at MONODY for midi files which d@157: ;; simply selects a track which is both monodic (if any monodic tracks d@157: ;; exist) and contains the highest pitch of any monodic track. d@157: (defmethod monody ((c midi-composition)) d@157: (flet ((not-overlapping (track) d@157: (let ((result t) d@157: (track (sort (copy-list track) #'amuse:time<))) d@157: (dotimes (i (1- (length track)) result) d@157: (let ((e1 (elt track i)) d@157: (e2 (elt track (1+ i)))) d@157: (unless (or (before e1 e2) (meets e1 e2)) d@157: (setf result nil))))))) d@157: (let ((tracks (make-hash-table)) d@157: (result nil) d@157: (max-pitch 0)) d@157: (sequence:dosequence (message c) d@157: (let* ((tracknum (amuse-midi:midi-track message)) d@157: (track (gethash tracknum tracks))) d@157: (setf (gethash tracknum tracks) (cons message track)))) d@157: (maphash #'(lambda (k v) d@157: (declare (ignore k)) d@157: (let ((max (apply #'max (mapcar #'midi-pitch-number v)))) d@157: (when (and (not-overlapping v) (> max max-pitch)) d@157: (setf result (sort v #'amuse:time<) d@157: max-pitch max)))) d@157: tracks) d@157: (when result d@157: (let ((monody (make-instance 'midi-monody d@157: :time (amuse:timepoint c) d@157: :interval (amuse:duration c) d@157: :time-signatures (time-signatures c) d@157: :key-signatures (key-signatures c) d@157: :tempi (tempi c) d@157: :controllers (%midi-misc-controllers c)))) d@157: (sequence:adjust-sequence monody (length result) d@157: :initial-contents result) d@157: monody))))) d@157: d@157: (defmethod trim-enclosing-silence ((composition midi-composition)) d@157: (let ((start (timepoint (bar-before (onset (elt composition 0)) d@157: composition))) d@157: (end) d@157: (new-sequence) (new-composition)) d@157: ;; First attend to the events themselves - copy and slide d@157: (sequence:dosequence (event composition) d@157: (push (copy-event event) new-sequence) d@157: (setf (timepoint (car new-sequence)) (- (timepoint event) d@157: start)) d@157: (when (or (not end) d@157: (> (timepoint (cut-off event)) end)) d@157: (setf end (timepoint (cut-off event))))) d@157: ;; Make the new composition with slid events d@157: ;; Should work, but doesn't d@157: #+nil d@157: (setf new-composition (sequence:make-sequence-like composition 0)) d@157: (setf new-composition (make-instance 'midi-composition d@157: :time 0 d@157: :interval (- end start))) d@157: (setf (amuse::%list-slot-sequence-data new-composition) d@157: (reverse new-sequence)) d@157: ;; Time-sigs d@157: (let ((sigs)) d@157: (dolist (sig (time-signatures composition)) d@157: ;; only include if signature affects window d@157: (when (and (> (timepoint (cut-off sig)) d@157: start) d@157: (< (timepoint sig) d@157: end)) d@157: ;; copy the signature d@157: (push (copy-time-signature sig) d@157: sigs) d@157: ;; adjust the timing d@157: (setf (timepoint (car sigs)) d@157: (max 0 (- (timepoint (car sigs)) start)) d@157: (duration (car sigs)) d@157: (- (min (timepoint (cut-off (car sigs))) d@157: (- end start)) d@157: (timepoint (car sigs)))))) d@157: (setf (time-signatures new-composition) (reverse sigs))) d@157: (let ((sigs)) d@157: (dolist (sig (key-signatures composition)) d@157: ;; only include if signature affects window d@157: (when (and (> (timepoint (cut-off sig)) d@157: start) d@157: (< (timepoint sig) d@157: end)) d@157: ;; copy the signature d@157: (push (copy-key-signature sig) d@157: sigs) d@157: ;; adjust the timing d@157: (setf (timepoint (car sigs)) d@157: (max 0 (- (timepoint (car sigs)) start)) d@157: (duration (car sigs)) d@157: (- (min (timepoint (cut-off (car sigs))) d@157: (- end start)) d@157: (timepoint (car sigs)))))) d@157: (setf (key-signatures new-composition) (reverse sigs))) d@157: (let ((tempi)) d@157: (dolist (tempo (tempi composition)) d@157: ;; only include if signature affects window d@157: (when (and (> (timepoint (cut-off tempo)) d@157: start) d@157: (< (timepoint tempo) d@157: end)) d@157: ;; copy the signature d@157: (push (copy-tempo tempo) d@157: tempi) d@157: ;; adjust the timing d@157: (setf (timepoint (car tempi)) d@157: (max 0 (- (timepoint (car tempi)) start)) d@157: (duration (car tempi)) d@157: (- (min (timepoint (cut-off (car tempi))) d@157: (- end start)) d@157: (timepoint (car tempi)))))) d@157: (setf (tempi new-composition) (reverse tempi))) d@157: new-composition)) d@157: d@157: d@157: (defgeneric bar-before (moment composition)) d@157: d@157: (defmethod bar-before (moment (composition midi-composition)) d@157: "Returns the moment at which the containing bar begins" d@157: (do ((time-sigs (time-signatures composition) (cdr time-sigs))) d@157: ((null time-sigs) nil) d@157: (let ((bar-period (make-standard-period d@157: (crotchets-in-a-bar (car time-sigs))))) d@157: (when (time> (cut-off (car time-sigs)) d@157: moment) d@157: (do ((bar (time+ (onset (car time-sigs)) bar-period) d@157: (time+ bar bar-period)) d@157: (prev-bar (onset (car time-sigs)))) d@157: ((time> bar moment) (return-from bar-before prev-bar)) d@165: (setf prev-bar bar)))))) d@165: d@165: (defmethod get-applicable-time-signatures ((anchored-period anchored-period) d@165: (composition midi-composition)) d@165: (%find-overlapping anchored-period (time-signatures composition))) d@165: (defmethod get-applicable-tempi ((anchored-period anchored-period) d@165: (composition midi-composition)) d@165: (%find-overlapping anchored-period (tempi composition))) d@165: (defmethod get-applicable-key-signatures ((anchored-period anchored-period) d@165: (composition midi-composition)) d@165: (%find-overlapping anchored-period (key-signatures composition))) d@165: d@165: (defun %find-overlapping (period1 period-list) d@165: (let ((result-list)) d@165: (dolist (period2 period-list result-list) d@165: (cond d@165: ((time>= period2 (cut-off period1)) d@165: (return-from %find-overlapping (reverse result-list))) d@165: ((time> (cut-off period2) period1) j@278: (push period2 result-list))))))