comparison utils/meltools.lisp @ 158:49b418a68acb

Finally added mcsv-exporting file...

darcs-hash:20071211145641-f76cc-58fb06b2d2d58120c56d7c9f4629936eb327eace.gz

+;;; Tools for simile, melconv and melfeature
+
+(cl:in-package #:amuse-utils)
+
+;; Basic tools and variables for mcsv output
+
+(defgeneric get-timebase (constituent)
+  (:method (c)
+    (apply #'lcm
+	   (nconc (map 'list #'(lambda (x)
+				 (denominator
+				  (timepoint x)))
+		       c)
+		  (map 'list #'(lambda (x)
+				 (denominator
+				  (timepoint (cut-off x))))
+		       c)))))
+					
+(defparameter *default-field-list*
+  '(:onset :onsetics :takt :beat :ticks :pitch :durs :durtic :dur16))
+
+(defparameter *mcsv-field-functions*
+  '((:onset mcsv-real-time-onset)
+    (:onsetics mcsv-tick-onset)
+    (:takt mcsv-bar-number)
+    (:beat mcsv-beat-in-bar)
+    (:ticks mcsv-ticks-in-beat)
+    (:pitch mcsv-pitch)
+    (:durs mcsv-seconds-duration)
+    (:durtic mcsv-ticks-duration)
+    (:dur16 mcsv-quarter-beat-duration)))
+
+;; method or function?
+(defgeneric write-mcsv (filename constituent fieldlist ticks)
+  (:method (fn c fl ticks)
+    (with-open-file (file fn :direction :output :if-exists :supersede)
+      (let ((time-sig (car (get-applicable-time-signatures c c)))
+	    (timebase (or ticks (get-timebase c)))
+	    (fieldlist (or fl *default-field-list*)))
+	(format file "Signature: ~D/~D, Ticks per Beat: ~D~%"
+		(if time-sig
+		    (time-signature-numerator time-sig)
+		    4)
+		(if time-sig
+		    (time-signature-denominator time-sig)
+		    4)
+		timebase)
+	(dolist (field fieldlist (format file "~%"))
+	  (format file "~D;" field))
+	(write-mcsv-to-stream file c fieldlist timebase)))))
+
+(defun write-mcsv-to-stream (stream composition fieldlist ticks)
+  (sequence:dosequence (event composition)
+    (dolist (field fieldlist (format stream "~%"))
+      (format stream "~D;" (get-mcsv-data field event composition ticks)))))
+
+(defun get-mcsv-data (field event composition ticks)
+  (funcall (second (assoc field *mcsv-field-functions*))
+	   event composition ticks))
+   
+;; mcsv data functions
+
+(defun mcsv-real-time-onset (event composition ticks)
+  (declare (ignore ticks))
+  (fraction-to-comma-string
+   (beats-to-seconds (onset event) composition)))
+
+(defun mcsv-tick-onset (event composition ticks)
+  (declare (ignore composition))
+  (round (* ticks (timepoint event))))
+
+(defun mcsv-bar-number (event composition ticks)
+  (declare (ignore ticks))
+  (bar-number event composition))
+
+(defun mcsv-beat-in-bar (event composition ticks)
+  ;; FIXME: broken if beat!= crotchet
+  (declare (ignore ticks))
+  (1+ (floor (- (timepoint event)
+		(timepoint (bar-onset (bar-number event composition)
+				      composition))))))
+
+(defun mcsv-ticks-in-beat (event composition ticks)
+  ;; FIXME: broken if beat!= crotchet
+  (declare (ignore composition))
+  (round (* ticks
+	    (rem (timepoint event) 1))))
+
+(defun mcsv-pitch (event composition ticks)
+  (declare (ignore composition ticks))
+  (midi-pitch-number event))
+
+(defun mcsv-seconds-duration (event composition ticks)
+  (declare (ignore ticks)) 
+  (fraction-to-comma-string (beats-to-seconds event composition)))
+
+(defun mcsv-ticks-duration (event composition ticks)
+  (declare (ignore composition)) 
+  (round (* ticks (duration event))))
+
+(defun mcsv-quarter-beat-duration (event composition ticks)
+  (declare (ignore ticks composition)) 
+  (round (* 4 (duration event))))
+
+(defun fraction-to-comma-string (number)
+  (multiple-value-bind (int rem)
+      (floor number)
+    (concatenate 'string
+		 (princ-to-string int)
+		 ","
+		 (princ-to-string (floor (* 10000 rem))))))