view utils/meltools.lisp @ 193:c18f795f4463

rollback the amuse.asd generics/classes dependency fix

Ignore-this: be4e0351d31f24f5348cc8dc434477dc

Fix properly this time by moving the specialized get-constituents method from generics to methods.

rolling back:

Wed Jan 23 15:55:34 GMT 2008  Jamie Forth <[e-mail]>
  * Fixed amuse.asd dependency - generics depends on classes.

    M ./amuse.asd -2 +2

darcs-hash:20090524164116-16a00-2b561eab1a5829a251eb5e9b40357945af13e6a6.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))))))