diff implementations/geerdes/constructors.lisp @ 88:8ea75cc8bc2c

Basic geerdes functionality moved to implementations/geerdes from separate package

darcs-hash:20070720161242-f76cc-fd256cbbb81d8c418a6c7c45844264184c5ed932.gz

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/geerdes/constructors.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,178 @@
+(cl:in-package #:amuse-geerdes)
+
+(defgeneric %initialise-notes (composition))
+(defmethod %initialise-notes ((composition geerdes-composition))
+  (let ((notes) (l 0) (last-time 0) (monody-notes)
+	(monody (make-instance 'geerdes-monody :file-id (file-id composition)))
+	(timebase (%midi-timebase composition)))
+    (dolist (row (%midi-events composition))
+      (let* ((note (if (pitched-row-p row)
+		      (make-geerdes-pitched-event (%fast-pitch row)
+						  (%fast-velocity row)
+						  (%fast-patch row)
+						  (%fast-channel row)
+						  (%fast-track row)
+						  (%fast-onset row timebase)
+						  (%fast-duration row timebase)
+						  (%fast-id row))
+		      (make-geerdes-percussive-event (%fast-pitch row)
+						     (%fast-velocity row)
+						     (%fast-patch row)
+						     (%fast-channel row)
+						     (%fast-track row)
+						     (%fast-onset row timebase)
+						     (%fast-duration row timebase)
+						     (%fast-id row)))))
+	(when (%fast-monodyp row)
+	  (push note monody-notes))
+	(when (> (timepoint (cut-off note)) last-time)
+	  (setf last-time (timepoint (cut-off note))))
+	(push note notes)
+	(incf l)))
+    (sequence:adjust-sequence composition l :initial-contents (reverse notes))
+    (setf (duration composition) last-time
+	  (timepoint composition) 0)
+    (when monody-notes
+      (setf (%monody composition) (sequence:adjust-sequence monody (length monody-notes)
+							    :initial-contents (reverse monody-notes))
+	    (timepoint (%monody composition)) (timepoint (elt monody 0))
+	    (duration (%monody composition)) (- (timepoint (cut-off (car monody-notes)))
+						(timepoint (elt monody 0)))))
+    composition))
+
+(defgeneric %initialise-constituents (composition))
+(defmethod %initialise-constituents ((composition geerdes-composition))
+  ;; FIXME: Should the duration of composition be affected by this? On
+  ;; the one hand, it makes no difference to the musical content, but
+  ;; on the other, it seems illogical to reach outside the period.
+  (let ((timebase (%midi-timebase composition))
+	(time-sigs)
+	(tempi)
+	(mystery 0))
+    (dolist (row (%midi-constituents composition))
+      (cond
+	((%fast-tempo row)
+	 (push (make-tempo
+		(microsecond-per-crotchet-to-bpm
+		 (%fast-tempo row))
+		(%fast-onset row timebase)
+		(%fast-duration row timebase))
+	       tempi))
+	((%fast-numerator row)
+	 (push (make-basic-time-signature
+		(%fast-numerator row)
+		(%fast-denominator row)
+		(%fast-onset row timebase)
+		(%fast-duration row timebase))
+	       time-sigs))
+	(t (incf mystery))))
+    (setf (time-signatures composition) (reverse time-sigs)
+	  (tempi composition) (reverse tempi))
+    (when (%monody composition)
+      (setf (time-signatures (%monody composition)) (time-signatures composition)
+	    (tempi (%monody composition)) (tempi composition)))
+    (format t "There are ~D constituents not processed~%" mystery)
+    composition))
+
+(defun %fast-track (row)
+  (first row))
+(defun %fast-channel (row)
+  (second row))
+(defun %fast-onset (row timebase)
+  (/ (third row) timebase))
+(defun %fast-duration (row timebase)
+  (/ (fourth row) timebase))
+(defun %fast-patch (event-row)
+  (fifth event-row))
+(defun %fast-pitch (event-row)
+  (sixth event-row))
+(defun %fast-velocity (event-row)
+  (seventh event-row))
+(defun %fast-id (event-row)
+  (eighth event-row))
+(defun %fast-monodyp (event-row)
+  (ninth event-row))
+
+(defun %fast-tempo (tp-row)
+  (eighth tp-row))
+(defun %fast-numerator (ts-row)
+  (ninth ts-row))
+(defun %fast-denominator (ts-row)
+  (tenth ts-row))
+
+(defun pitched-row-p (event-row)
+  (and (not (= (%fast-channel event-row) 10))
+       (< (%fast-patch event-row) 112)))
+
+(defun make-geerdes-pitched-event (pitch-number velocity patch
+				channel track onset duration id)
+  (make-instance 'geerdes-pitched-event
+		 :number pitch-number
+		 :velocity velocity
+		 :patch patch
+		 :channel channel
+		 :track track
+		 :time onset
+		 :interval duration
+		 :id id))
+
+(defun make-geerdes-percussive-event (pitch-number velocity patch
+				   channel track onset duration id)
+  (make-instance 'geerdes-percussive-event
+		 :sound pitch-number
+		 :velocity velocity
+		 :patch patch
+		 :channel channel
+		 :track track
+		 :time onset
+		 :interval duration
+		 :id id))
+
+(defgeneric copy-event (event))
+(defmethod copy-event ((event geerdes-pitched-event))
+  (with-slots ((channel amuse-midi::channel)
+	       (track amuse-midi::track)
+	       (number amuse::number)
+	       (time amuse::time)
+	       (interval amuse::interval)
+	       (velocity amuse-midi::velocity)
+	       (patch amuse-midi::patch) id)
+      event
+    (make-instance 'geerdes-pitched-event
+		   :channel channel
+		   :track track
+		   :number number
+		   :time time
+		   :interval interval
+		   :velocity velocity
+		   :patch patch
+		   :id id)))
+(defmethod copy-event ((event geerdes-percussive-event)) 
+  (with-slots ((channel amuse-midi::channel)
+	       (track amuse-midi::track)
+	       (time amuse::time)
+	       (interval amuse::interval)
+	       (velocity amuse-midi::velocity)
+	       (patch amuse-midi::patch)
+	       (sound amuse-midi::sound) id)
+      event
+    (make-instance 'geerdes-percussive-event
+		   :channel channel 
+		   :track track
+		   :time time
+		   :interval interval
+		   :velocity velocity
+		   :patch patch
+		   :sound sound
+		   :id id)))
+
+;; We want any function that generates a sequence from a geerdes
+;; composition to preserve all slot values:
+(defmethod sequence:make-sequence-like :around ((o geerdes-composition)
+						length
+						&key (initial-element nil iep)
+						(initial-contents nil icp))
+  (declare (ignore iep icp length initial-element initial-contents))
+  (let ((result (call-next-method)))
+    (setf (%db-entry result) (%db-entry o))
+    result))