view implementations/midi/methods.lisp @ 206:1f3873585a5d

Change midifile-import to call event constructors, not make-instance
directly.

(cl:in-package #:amuse-midi)

(defgeneric (setf midi-velocity) (value event)
    (:method (v e) (declare (ignore v)) e))
(defmethod (setf midi-velocity) (value (event midi-pitched-event))
     (setf (%midi-pitched-event-velocity event) value)
     event)

(defgeneric (setf midi-patch) (value event)
   (:method (v e) (declare (ignore v)) e))
(defmethod (setf midi-patch) (value (event midi-pitched-event))
    (setf (%midi-pitched-event-patch event) value)
    event)

(Defgeneric midi-channel (midi-message)
  (:documentation "MIDI channel. Also used for midi output"))
(defmethod midi-channel ((midi-message midi-message))
  (%midi-message-channel midi-message))

(defgeneric midi-track (midi-message)
  (:documentation "MIDI track. Also used for midi output"))
(defmethod midi-track ((midi-message midi-message))
  (%midi-message-track midi-message))

(defgeneric midi-velocity (event)
  (:documentation "MIDI velocity. Also used for midi output"))
(defmethod midi-velocity ((event midi-pitched-event))
  (%midi-pitched-event-velocity event))
(defmethod midi-velocity ((event midi-percussive-event))
  (%midi-percussive-event-velocity event))

(defgeneric midi-patch (event)
  (:documentation "MIDI patch (instrumental sound). Also used for
  midi output"))
(defmethod midi-patch ((event midi-pitched-event))
  (%midi-pitched-event-patch event))

(defgeneric midi-drum-sound (event)
  (:documentation "MIDI pitch for unpitched events (usually, drum
  sound for drum kits on channel 10, but also for semi-pitched
  SFX, etc). Also used for midi output"))
(defmethod midi-drum-sound ((event midi-percussive-event))
  (%midi-percussive-event-sound event))

(defmethod time-signatures ((composition midi-composition))
  (%midi-time-signatures composition))
(defmethod (setf time-signatures) (sequence (composition midi-composition))
  (setf (%midi-time-signatures composition) sequence))
(defmethod tempi ((composition midi-composition))
  (%midi-tempi composition))
(defmethod (setf tempi) (sequence (composition midi-composition))
  (setf (%midi-tempi composition) sequence))
(defmethod key-signatures ((composition midi-composition))
  (%midi-key-signatures composition))
(defmethod (setf key-signatures) (sequence (composition midi-composition))
  (setf (%midi-key-signatures composition) sequence))

(defgeneric copy-event (event))
;; FIXME: This ought to call-next-method and operate on the result,
;; rather than calling internals from the other package
(defmethod copy-event ((event midi-pitched-event))
  (with-slots (channel track (number amuse::number)
		       (time amuse::time) (interval amuse::interval)
		       velocity patch) event
    (make-midi-pitched-event number velocity patch channel track time
			     interval)))

(defmethod copy-event ((event midi-percussive-event)) 
  (with-slots (channel track (time amuse::time)
		       (interval amuse::interval) velocity patch
		       sound) event
    (make-midi-percussive-event sound velocity patch channel track
				time interval)))

(defgeneric copy-time-signature (time-signature))
(defmethod copy-time-signature ((time-signature standard-time-signature))
  (make-instance (class-of time-signature)
                 :numerator (time-signature-numerator time-signature)
                 :denominator (time-signature-denominator time-signature)))
(defmethod copy-time-signature ((time-signature-period standard-time-signature-period))
  (let ((sig (call-next-method)))
    (setf (timepoint sig) (timepoint time-signature-period)
          (duration sig) (duration time-signature-period))
    sig))
(defgeneric copy-tempo (tempo))
(defmethod copy-tempo ((tempo standard-tempo))
  (make-instance (class-of tempo)
                 :bpm (bpm tempo)))
(defmethod copy-tempo ((tempo-period standard-tempo-period))
  (let ((tp (call-next-method)))
    (setf (timepoint tp) (timepoint tempo-period)
          (duration tp) (duration tempo-period))
    tp))
(defgeneric copy-key-signature (key-signature))
(defmethod copy-key-signature ((key-signature standard-key-signature))
  (make-instance (class-of key-signature)
                 :sharp-count (key-signature-sharps key-signature)
                 :mode (key-signature-mode key-signature)))
(defmethod copy-key-signature ((key-signature-period standard-key-signature-period))
  (let ((sig (call-next-method)))
    (setf (timepoint sig) (timepoint key-signature-period)
          (duration sig) (duration key-signature-period))
    sig))



;; Allow derived sequences from remove-if, etc. to preserve other slot
;; info (timesigs, etc)
#+nil
(defmethod sequence:make-sequence-like :around ((o midi-composition) length
						&key (initial-element nil iep)
						(initial-contents nil icp))
  (declare (ignore length initial-element initial-contents)) 
  (let ((result (call-next-method)))
    (cond
      ((or iep icp)
       (setf (timepoint result) (timepoint (elt result 0))
	     (duration result) (- (timepoint
				   (loop for e being the elements of result
				      maximize (cut-off e)))
				  (timepoint (elt result 0)))))
      (t (setf (timepoint result) 0
	       (duration result) 0)))
    (with-slots (time-signatures tempi misc-controllers)
	o
      (setf (%midi-time-signatures result) time-signatures
	    (%midi-tempi result) tempi
	    (%midi-misc-controllers result) misc-controllers))
    result))
	    

;; useful little function

(defun microsecond-per-crotchet-to-bpm (mu-per-c)
  (/ 60000000 mu-per-c))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MIDI playback methods

(defmethod get-patch-for-midi ((event midi-pitched-event))
  ;; FIXME
  (midi-patch event))

(defmethod get-channel-for-midi ((event midi-message))
  ;; FIXME 1- ??? I'm only doing this because of the Geerdes
  ;; database. Looks like a recipe for disaster. Think should probably
  ;; enforce 0-15.
  (1- (midi-channel event)))

(defmethod get-velocity-for-midi ((event midi-message))
  ;; FIXME: under-exclusive specialisation. Does this matter?
  (midi-velocity event))

(defmethod get-pitch-for-midi ((event midi-percussive-event))
  (midi-drum-sound event))

(defmethod get-pitch-for-midi ((event midi-pitched-event))
  (midi-pitch-number event))

;; Have avoided percussion vs pitched, as this is more obviously
;; meaningless.
(defmethod significantly-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event))
  (>= (/ (midi-velocity event1)
	 (midi-velocity event2))
      4/3))
(defmethod significantly-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event))
  (>= (/ (midi-velocity event1)
	 (midi-velocity event2))
      4/3))
(defmethod substantially-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event))
  (>= (/ (midi-velocity event1)
	 (midi-velocity event2))
      2))
(defmethod substantially-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event))
  (>= (/ (midi-velocity event1)
	 (midi-velocity event2))
      2))

(defmethod crotchet ((object midi-object))
  (make-standard-period 1))

(defmethod monody ((identifier midifile-identifier))
  (monody (get-composition identifier)))

;; TODO: improve this naive first-cut at MONODY for midi files which
;; simply selects a track which is both monodic (if any monodic tracks
;; exist) and contains the highest pitch of any monodic track.
(defmethod monody ((c midi-composition))
  (flet ((not-overlapping (track) 
           (let ((result t)
                 (track (sort (copy-list track) #'amuse:time<)))
             (dotimes (i (1- (length track)) result)
               (let ((e1 (elt track i))
                     (e2 (elt track (1+ i))))
                 (unless (or (before e1 e2) (meets e1 e2))
                   (setf result nil)))))))
    (let ((tracks (make-hash-table))
          (result nil)
          (max-pitch 0))
      (sequence:dosequence (message c)
        (let* ((tracknum (amuse-midi:midi-track message))
               (track (gethash tracknum tracks)))
          (setf (gethash tracknum tracks) (cons message track))))
      (maphash #'(lambda (k v)
                   (declare (ignore k))
                   (let ((max (apply #'max (mapcar #'midi-pitch-number v))))
                     (when (and (not-overlapping v) (> max max-pitch))
                       (setf result (sort v #'amuse:time<)
                             max-pitch max))))
               tracks)
      (when result 
        (let ((monody (make-instance 'midi-monody 
                                     :time (amuse:timepoint c)
                                     :interval (amuse:duration c)
                                     :time-signatures (time-signatures c)
                                     :key-signatures (key-signatures c)
                                     :tempi (tempi c)
                                     :controllers (%midi-misc-controllers c))))
          (sequence:adjust-sequence monody (length result)
                                    :initial-contents result)
          monody)))))

(defmethod trim-enclosing-silence ((composition midi-composition))
  (let ((start (timepoint (bar-before (onset (elt composition 0))
                                      composition)))
        (end)
        (new-sequence) (new-composition))
    ;; First attend to the events themselves - copy and slide
    (sequence:dosequence (event composition)
      (push (copy-event event) new-sequence)
      (setf (timepoint (car new-sequence)) (- (timepoint event)
                                             start))
      (when (or (not end)
                (> (timepoint (cut-off event)) end))
        (setf end (timepoint (cut-off event)))))
    ;; Make the new composition with slid events
    ;; Should work, but doesn't
    #+nil
    (setf new-composition (sequence:make-sequence-like composition 0))
    (setf new-composition (make-instance 'midi-composition
                                         :time 0
                                         :interval (- end start)))
    (setf (amuse::%list-slot-sequence-data new-composition)
          (reverse new-sequence))
    ;; Time-sigs
    (let ((sigs))
      (dolist (sig (time-signatures composition))
        ;; only include if signature affects window
        (when (and (> (timepoint (cut-off sig))
                      start)
                   (< (timepoint sig)
                      end))
          ;; copy the signature
          (push (copy-time-signature sig)
                sigs)
          ;; adjust the timing
          (setf (timepoint (car sigs))
                (max 0 (- (timepoint (car sigs)) start))
                (duration (car sigs))
                (- (min (timepoint (cut-off (car sigs)))
                        (- end start))
                   (timepoint (car sigs))))))
      (setf (time-signatures new-composition) (reverse sigs)))
    (let ((sigs))
      (dolist (sig (key-signatures composition))
        ;; only include if signature affects window
        (when (and (> (timepoint (cut-off sig))
                      start)
                   (< (timepoint sig)
                      end))
          ;; copy the signature
          (push (copy-key-signature sig)
                sigs)
          ;; adjust the timing
          (setf (timepoint (car sigs))
                (max 0 (- (timepoint (car sigs)) start))
                (duration (car sigs))
                (- (min (timepoint (cut-off (car sigs)))
                        (- end start))
                   (timepoint (car sigs))))))
      (setf (key-signatures new-composition) (reverse sigs)))
    (let ((tempi))
      (dolist (tempo (tempi composition))
        ;; only include if signature affects window
        (when (and (> (timepoint (cut-off tempo))
                      start)
                   (< (timepoint tempo)
                      end))
          ;; copy the signature
          (push (copy-tempo tempo)
                tempi)
          ;; adjust the timing
          (setf (timepoint (car tempi))
                (max 0 (- (timepoint (car tempi)) start))
                (duration (car tempi))
                (- (min (timepoint (cut-off (car tempi)))
                        (- end start))
                   (timepoint (car tempi))))))
      (setf (tempi new-composition) (reverse tempi)))
    new-composition))


(defgeneric bar-before (moment composition))

(defmethod bar-before (moment (composition midi-composition))
  "Returns the moment at which the containing bar begins"
  (do ((time-sigs (time-signatures composition) (cdr time-sigs)))
      ((null time-sigs) nil)
    (let ((bar-period (make-standard-period
		       (crotchets-in-a-bar (car time-sigs)))))
      (when (time> (cut-off (car time-sigs))
                   moment)
        (do ((bar (time+ (onset (car time-sigs)) bar-period)
                  (time+ bar bar-period))
             (prev-bar (onset (car time-sigs))))
            ((time> bar moment) (return-from bar-before prev-bar))
          (setf prev-bar bar))))))

(defmethod get-applicable-time-signatures ((anchored-period anchored-period)
                                           (composition midi-composition))
  (%find-overlapping anchored-period (time-signatures composition)))
(defmethod get-applicable-tempi ((anchored-period anchored-period)
                                 (composition midi-composition))
  (%find-overlapping anchored-period (tempi composition)))
(defmethod get-applicable-key-signatures ((anchored-period anchored-period)
                                          (composition midi-composition))
  (%find-overlapping anchored-period (key-signatures composition)))

(defun %find-overlapping (period1 period-list)
  (let ((result-list))
    (dolist (period2 period-list result-list)
      (cond
        ((time>= period2 (cut-off period1))
         (return-from %find-overlapping (reverse result-list)))
        ((time> (cut-off period2) period1)
         (push period2 result-list))))))