changeset 157:f5f4bf8d74d7

Fixed previous patch

darcs-hash:20071204151652-1f211-efd2cee99c632933f62a188cf9333dfb5bfe9918.gz

--- a/implementations/midi/methods.lisp	Tue Dec 04 15:00:55 2007 +0000
+++ b/implementations/midi/methods.lisp	Tue Dec 04 15:16:52 2007 +0000
@@ -187,3 +187,140 @@
 
 (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))))))
\ No newline at end of file