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