changeset 146:a74494a94be9

implementations/midi: implement MONODY for midi files

darcs-hash:20070924160443-c0ce4-302ec7f06335a374b673f70ef2e79d4b2a8b3616.gz

--- a/implementations/midi/classes.lisp	Mon Sep 24 16:44:39 2007 +0100
+++ b/implementations/midi/classes.lisp	Mon Sep 24 17:04:43 2007 +0100
@@ -20,6 +20,9 @@
   signatures, tempi, key signatures and other controllers as
   lists in slots"))
 
+(defclass midi-monody (amuse:standard-monody midi-composition)
+  ())
+
 (defclass midi-message (midi-object) ;?
   ((channel :accessor %midi-message-channel :initarg :channel)
    (track :accessor %midi-message-track :initarg :track)))

--- a/implementations/midi/methods.lisp	Mon Sep 24 16:44:39 2007 +0100
+++ b/implementations/midi/methods.lisp	Mon Sep 24 17:04:43 2007 +0100
@@ -144,3 +144,45 @@
 
 (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)))))
+