Mercurial > hg > amuse
changeset 46:34fb42cba5b9
basic mtp amuse implementation
darcs-hash:20070615111202-aa3d6-498f4d035964f6f8e8803de9cbf6f50974affe88.gz
| author | m.pearce <m.pearce@gold.ac.uk> |
|---|---|
| date | Fri, 15 Jun 2007 12:12:02 +0100 |
| parents | 0f31919a855d |
| children | e3d86a0f25b3 |
| files | implementations/mtp/classes.lisp implementations/mtp/constructors.lisp implementations/mtp/methods.lisp implementations/mtp/package.lisp |
| diffstat | 4 files changed, 241 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/implementations/mtp/classes.lisp Fri Jun 15 12:12:02 2007 +0100 @@ -0,0 +1,29 @@ +(cl:in-package #:amuse-mtp) + +(defclass mtp-composition-identifier (identifier) + ((dataset-id :initarg :dataset-id :accessor dataset-id) + (composition-id :initarg :composition-id :accessor composition-id))) + +(defclass mtp-composition (amuse:composition) + ((dataset-id :initarg :dataset-id :accessor dataset-id) + (composition-id :initarg :composition-id :accessor composition-id) + (description :initarg :description :accessor description))) + +(defclass mtp-event (amuse:pitched-event) + ((dataset-id :initarg :dataset-id :accessor dataset-id) + (composition-id :initarg :composition-id :accessor composition-id) + (event-id :initarg :event-id :accessor event-id) + ;;(onset :initarg :onset :accessor %mtp-onset) - (timepoint ...) + ;;(dur :initarg :dur :accessor %mtp-accidental) - (duration ...) + (deltast :initarg :deltast :accessor %mtp-deltast) + (cpitch :initarg :cpitch :accessor %mtp-cpitch) + (mpitch :initarg :mpitch :accessor %mtp-mpitch) + (accidental :initarg :accidental :accessor %mtp-accidental) + (keysig :initarg :keysig :accessor %mtp-keysig) + (mode :initarg :mode :accessor %mtp-mode) + (barlength :initarg :barlength :accessor %mtp-barlength) + (pulses :initarg :pulses :accessor %mtp-pulses) + (phrase :initarg :phrase :accessor %mtp-phrase) + (tempo :initarg :tempo :accessor %mtp-tempo) + (dyn :initarg :dyn :accessor %mtp-dyn) + (voice :initarg :voice :accessor %mtp-voice)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/implementations/mtp/constructors.lisp Fri Jun 15 12:12:02 2007 +0100 @@ -0,0 +1,12 @@ +(cl:in-package #:amuse-mtp) + +(defun make-mtp-composition-identifier (dataset-id composition-id) + (make-instance 'mtp-composition-identifier + :dataset-id dataset-id :composition-id composition-id)) + +(defun make-mtp-composition (&rest args) + (apply #'make-instance 'mtp-composition args)) + +(defun make-mtp-event (&rest args) + (apply #'make-instance 'mtp-event args)) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/implementations/mtp/methods.lisp Fri Jun 15 12:12:02 2007 +0100 @@ -0,0 +1,197 @@ +(cl:in-package #:amuse-mtp) + +;;; Compositions + +#.(clsql:locally-enable-sql-reader-syntax) + +(defmethod get-composition ((identifier mtp-composition-identifier)) + (let* ((dataset-id (dataset-id identifier)) + (composition-id (composition-id identifier)) + (where-clause [and [= [dataset-id] dataset-id] + [= [composition-id] composition-id]]) + (description + (car (clsql:select [description] :from [composition] + :where where-clause :flatp t :field-names nil))) + (event-count + (1+ + (car + (clsql:select [max [event-id]] :from [event] + :where where-clause :flatp t :field-names nil)))) + (events nil)) + (dotimes (event-id event-count) + (push (get-event dataset-id composition-id event-id) events)) + (let* ((interval (+ (timepoint (car events)) (duration (car events)))) + (composition + (make-mtp-composition :dataset-id dataset-id + :composition-id composition-id + :description description + :time 0 + :interval interval))) + (sequence:adjust-sequence composition (length events) + :initial-contents (nreverse events)) + composition))) + +(defun get-event (dataset-id composition-id event-id) + (let* ((attributes + (list (list 'amuse::time [onset]) + (list 'amuse::interval [dur]) + (list 'deltast [deltast]) + (list 'cpitch [cpitch]) + (list 'mpitch [mpitch]) + (list 'accidental [accidental]) + (list 'keysig [keysig]) + (list 'mode [mode]) + (list 'barlength [barlength]) + (list 'pulses [pulses]) + (list 'phrase [phrase]) + (list 'tempo [tempo]) + (list 'dyn [dyn]) + (list 'voice [voice]))) + (mtp-event + (make-mtp-event :dataset-id dataset-id + :composition-id composition-id + :event-id event-id))) + (dolist (a attributes mtp-event) + (let ((value + (clsql:select (cadr a) :from [event] + :where [and [= [dataset-id] dataset-id] + [= [composition-id] composition-id] + [= [event-id] event-id]] + :flatp t + :field-names nil))) + (setf (slot-value mtp-event (car a)) (car value)))))) + +#.(clsql:restore-sql-reader-syntax-state) + + +;;; Constituents from compositions: time-signatures + +(defgeneric time-signature-equal (ts1 ts2)) +(defmethod time-signature-equal ((ts1 basic-time-signature) + (ts2 basic-time-signature)) + (let ((n1 (time-signature-numerator ts1)) + (n2 (time-signature-numerator ts2)) + (d1 (time-signature-denominator ts1)) + (d2 (time-signature-denominator ts2))) + (and n1 n2 (= n1 n2) + d1 d2 (= d1 d2)))) + +(defgeneric time-signature (event)) +(defmethod time-signature ((e mtp-event)) + (let ((pulses (%mtp-pulses e)) + (barlength (%mtp-barlength e)) + (timebase (timebase-for-event e))) + (make-basic-time-signature pulses (/ timebase (/ barlength pulses)) + (timepoint e) nil))) + +#.(clsql:locally-enable-sql-reader-syntax) +(defun timebase-for-event (event) + (car (clsql:select [timebase] :from [dataset] + :where [= [dataset-id] + (dataset-id event)] + :flatp t + :field-names nil))) +#.(clsql:restore-sql-reader-syntax-state) + +(defmethod time-signatures ((c mtp-composition)) + (let ((results nil) + (interval 0) + (current nil)) + (sequence:dosequence (event c) + (let ((ts (time-signature event))) + (when (and (%mtp-barlength event) + (%mtp-pulses event) + (or (null current) + (not (time-signature-equal ts current)))) + (unless (null current) + (setf (duration current) interval) + (push current results)) + (setf interval 0 + current ts))) + (incf interval (%mtp-deltast event)) + (incf interval (duration event))) + (when current + (setf (duration current) interval) + (push current results)) + (nreverse results))) + +;;; Constituents from compositions: key-signatures + +(defgeneric key-signature-equal (ks1 ks2)) +(defmethod key-signature-equal ((ks1 midi-key-signature) + (ks2 midi-key-signature)) + (let ((s1 (key-signature-sharps ks1)) + (s2 (key-signature-sharps ks2)) + (m1 (key-signature-mode ks1)) + (m2 (key-signature-mode ks2))) + (and s1 s2 (= s1 s2) + m1 m2 (= m1 m2)))) + +(defgeneric key-signature (event)) +(defmethod key-signature ((e mtp-event)) + (let ((keysig (%mtp-keysig e)) + (mode (%mtp-mode e)) + (onset (timepoint e))) + (amuse:make-midi-key-signature keysig mode onset nil))) + +(defmethod key-signatures ((c mtp-composition)) + (let ((results nil) + (interval 0) + (current nil)) + (sequence:dosequence (event c) + (let ((ks (key-signature event))) + (when (and (%mtp-keysig event) + (%mtp-mode event) + (or (null current) + (not (key-signature-equal ks current)))) + (unless (null current) + (setf (duration current) interval) + (push current results)) + (setf interval 0 + current ks))) + (incf interval (%mtp-deltast event)) + (incf interval (duration event))) + (when current + (setf (duration current) interval) + (push current results)) + (nreverse results))) + +;;; Constituents from compositions: tempi + +(defmethod tempi ((c mtp-composition)) + (let ((results nil) + (interval 0) + (current nil)) + (sequence:dosequence (event c) + (when (and (%mtp-tempo event) + (or (null current) + (not (= (bpm current) (%mtp-tempo event))))) + (unless (null current) + (setf (duration current) interval) + (push current results)) + (let ((new (amuse:make-tempo (%mtp-tempo event) + (timepoint event) + nil))) + (setf interval 0 + current new))) + (incf interval (%mtp-deltast event)) + (incf interval (duration event))) + (when current + (setf (duration current) interval) + (push current results)) + (nreverse results))) + + +;;; Events: Pitch + +(defmethod chromatic-pitch ((e mtp-event)) + (make-chromatic-pitch (%mtp-cpitch e))) + +(defmethod midi-pitch-number ((e mtp-event)) + (%mtp-cpitch e)) + +(defmethod diatonic-pitch ((e mtp-event)) +;; (make-diatonic-pitch (event-mpitch e) +;; (event-accidental e) +;; octave) + )