annotate implementations/midi/methods.lisp @ 155:fc6848dda767

Added setf methods for midi-channel and velocity

darcs-hash:20071204143920-1f211-9505a88618b3b0532b314ef809f8ee7819c956d5.gz

(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-instance 'midi-pitched-event
		   :channel channel
		   :track track
		   :number number
		   :time time
		   :interval interval
		   :velocity velocity
		   :patch patch)))
(defmethod copy-event ((event midi-percussive-event)) 
  (with-slots (channel track (time amuse::time) (interval amuse::interval) velocity patch sound)
      event
    (make-instance 'midi-percussive-event
		   :channel channel 
		   :track track
		   :time time
		   :interval interval
		   :velocity velocity
		   :patch patch
		   :sound sound)))
(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)))))