Mercurial > hg > amuse

changeset 326:5271a0aa06d6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add extra event slots for articulation, commas and ornaments to amuse-mtp.
author Marcus Pearce <marcus.pearce@eecs.qmul.ac.uk>
date Fri, 27 Apr 2012 10:27:57 +0100
parents 87fb1218ab18
children a47e1f34dae5
files implementations/mtp/classes.lisp implementations/mtp/methods.lisp
diffstat 2 files changed, 40 insertions(+), 20 deletions(-) [+]
line wrap: on
line diff
--- a/implementations/mtp/classes.lisp	Tue Feb 07 10:45:14 2012 +0000
+++ b/implementations/mtp/classes.lisp	Fri Apr 27 10:27:57 2012 +0100
@@ -35,6 +35,7 @@
 (defclass mtp-composition (amuse:standard-composition mtp-music-object)
   ((dataset-id :initarg :dataset-id :accessor dataset-id)
    (composition-id :initarg :composition-id :accessor composition-id)
+   (timebase :initarg :timebase :accessor composition-timebase)
    (description :initarg :description :accessor description)))
 
 (defclass mtp-monody (amuse:standard-monody mtp-composition) 
@@ -58,4 +59,7 @@
    (phrase :initarg :phrase :accessor %mtp-phrase)
    (tempo :initarg :tempo :accessor %mtp-tempo)
    (dyn :initarg :dyn :accessor %mtp-dyn)
+   (ornament :initarg :ornament :accessor %mtp-ornament)
+   (comma :initarg :comma :accessor %mtp-comma)
+   (articulation :initarg :articulation :accessor %mtp-articulation)
    (voice :initarg :voice :accessor %mtp-voice)))
--- a/implementations/mtp/methods.lisp	Tue Feb 07 10:45:14 2012 +0000
+++ b/implementations/mtp/methods.lisp	Fri Apr 27 10:27:57 2012 +0100
@@ -7,7 +7,8 @@
 (defvar *event-attributes* 
   (list [dataset-id] [composition-id] [event-id]
         [onset] [dur] [deltast] [cpitch] [mpitch] [accidental] [keysig] [mode]
-        [barlength] [pulses] [phrase] [tempo] [dyn] [voice]))
+        [barlength] [pulses] [phrase] [tempo] [dyn] [voice] [bioi] 
+        [ornament] [comma] [articulation]))
 
 (defgeneric get-dataset (identifer))
 
@@ -15,7 +16,7 @@
   (let* ((dataset-id (dataset-id identifier))
          (where-clause [= [dataset-id] dataset-id])
          (db-dataset (car (clsql:select [*] :from [mtp-dataset] :where where-clause)))
-         (db-compositions (clsql:select [composition-id][description] 
+         (db-compositions (clsql:select [composition-id][description][timebase]
                                         :from [mtp-composition] 
                                         :order-by '(([composition-id] :asc))
                                         :where where-clause))
@@ -33,8 +34,9 @@
          (events nil))
     ;; for each db-composition 
     (dolist (dbc db-compositions)
-      (let ((composition-id (car dbc))
-            (description (car dbc)))
+      (let ((composition-id (first dbc))
+            (description (second dbc))
+            (timebase (third dbc)))
         ;; for each db-event 
         (do* ((dbes db-events (cdr dbes))
               (dbe (car dbes) (car dbes))
@@ -42,13 +44,14 @@
              ((or (null dbes) (not (= cid composition-id)))
               (setf db-events dbes))
           (when dbe
-            (push (db-event->mtp-event dbe) events)))
+            (push (db-event->mtp-event dbe timebase) events)))
         (when events
           (let* ((interval (+ (timepoint (car events)) (duration (car events))))
                  (composition 
                   (make-mtp-composition :dataset-id dataset-id 
                                         :composition-id composition-id
                                         :description description
+                                        :timebase timebase
                                         :time 0
                                         :interval interval)))
             (sequence:adjust-sequence composition (length events)
@@ -67,6 +70,9 @@
          (description 
           (car (clsql:select [description] :from [mtp-composition] 
                              :where where-clause :flatp t :field-names nil)))
+         (timebase 
+          (car (clsql:select [timebase] :from [mtp-composition] 
+                             :where where-clause :flatp t :field-names nil)))
          (db-events (apply #'clsql:select 
                            (append *event-attributes* 
                                    (list :from [mtp-event] 
@@ -74,12 +80,13 @@
                                          :where where-clause))))
          (events nil))
     (dolist (e db-events)
-      (push (db-event->mtp-event e) events))
+      (push (db-event->mtp-event e timebase) events))
     (let* ((interval (+ (timepoint (car events)) (duration (car events))))
            (composition 
             (make-mtp-composition :dataset-id dataset-id 
                                   :composition-id composition-id
                                   :description description
+                                  :timebase timebase
                                   :time 0
                                   :interval interval)))
       (sequence:adjust-sequence composition (length events)
@@ -88,10 +95,12 @@
 
 #.(clsql:restore-sql-reader-syntax-state) 
 
-(defun db-event->mtp-event (db-event)
+(defun db-event->mtp-event (db-event timebase)
   (let* ((slots ; the order must match *event-attributes*
           '(amuse::time amuse::interval deltast cpitch mpitch accidental 
-            keysig mode barlength pulses phrase tempo dyn voice bioi))
+            keysig mode barlength pulses phrase tempo dyn voice bioi 
+            ornament comma articulation))
+         (time-slots '(amuse::time amuse::interval deltast barlength bioi))
          (mtp-event
           (make-mtp-event :dataset-id (first db-event)
                           :composition-id (second db-event)
@@ -99,7 +108,17 @@
     (do* ((slts slots (cdr slts))
           (db-atts (nthcdr 3 db-event) (cdr db-atts)))
          ((null slts) mtp-event)
-      (setf (slot-value mtp-event (car slts)) (car db-atts)))))
+      (if (member (car slts) time-slots :test #'eql)
+          (setf (slot-value mtp-event (car slts)) (convert-time-slot (car db-atts) timebase))
+          (setf (slot-value mtp-event (car slts)) (car db-atts))))))
+
+(defun convert-time-slot (value timebase)
+  "Convert native representation of time into a representation where
+    a crotchet has a value of 96."
+  (if (or (null value) (null timebase))
+      nil
+      (let ((multiplier (/ 96 timebase)))
+        (* value multiplier))))
 
 ;;; Monodies 
 
@@ -112,6 +131,7 @@
                                :dataset-id (dataset-id c)
                                :composition-id (composition-id c)
                                :description (description c)
+                               :timebase (composition-timebase c)
                                :time 0 
                                :interval (duration c)))
         (events nil)
@@ -126,26 +146,22 @@
      :initial-contents (sort events #'< :key #'amuse:timepoint))
     monody))
 
+
 ;;; Constituents from compositions: time-signatures 
 
 (defmethod crotchet ((dataset mtp-dataset))
   (amuse:make-standard-period 
    (/ (dataset-timebase dataset) 4)))
 
+(defmethod crotchet ((composition mtp-composition))
+  (amuse:make-standard-period 
+   (/ (composition-timebase composition) 4)))
+
 #.(clsql:locally-enable-sql-reader-syntax)
-(defmethod crotchet ((composition mtp-composition))
-  (let ((timebase 
-         (car (clsql:select [timebase] :from [mtp-dataset]
-                            :where [= [dataset-id] 
-                                      (dataset-id composition)]
-                            :flatp t 
-                            :field-names nil))))
-    (amuse:make-standard-period (/ timebase 4))))
 (defmethod crotchet ((event mtp-event))
   (let ((timebase 
-         (car (clsql:select [timebase] :from [mtp-dataset]
-                            :where [= [dataset-id] 
-                                      (dataset-id event)]
+         (car (clsql:select [timebase] :from [mtp-composition]
+                            :where [and [= [dataset-id] (dataset-id event)] [= [composition-id] (composition-id event)]]
                             :flatp t 
                             :field-names nil))))
     (amuse:make-standard-period (/ timebase 4))))