# HG changeset patch
# User Marcus Pearce <m.pearce@gold.ac.uk>
# Date 1185199676 -3600
# Node ID 23c3be4c445f00422375aad55744ef32036d0b7d
# Parent  0b4c624910f1ab8a31aeed5fa25e72b0232b86fb
implementations/mtp/: monodies

darcs-hash:20070723140756-c0ce4-d37c71088330756c4add1a2b41cfc185e9ac7924.gz

diff -r 0b4c624910f1 -r 23c3be4c445f implementations/mtp/classes.lisp
--- a/implementations/mtp/classes.lisp	Mon Jul 23 15:06:51 2007 +0100
+++ b/implementations/mtp/classes.lisp	Mon Jul 23 15:07:56 2007 +0100
@@ -23,7 +23,10 @@
   ((dataset-id :initarg :dataset-id :accessor dataset-id)
    (composition-id :initarg :composition-id :accessor composition-id)
    (description :initarg :description :accessor description)))
-   
+
+(defclass mtp-monody (amuse:monody mtp-composition) 
+  ())
+
 (defclass mtp-event (amuse:pitched-event)
   ((dataset-id :initarg :dataset-id :accessor dataset-id)
    (composition-id :initarg :composition-id :accessor composition-id)
diff -r 0b4c624910f1 -r 23c3be4c445f implementations/mtp/methods.lisp
--- a/implementations/mtp/methods.lisp	Mon Jul 23 15:06:51 2007 +0100
+++ b/implementations/mtp/methods.lisp	Mon Jul 23 15:07:56 2007 +0100
@@ -85,6 +85,8 @@
                                 :initial-contents (nreverse events))
       composition)))
 
+#.(clsql:restore-sql-reader-syntax-state) 
+
 (defun db-event->mtp-event (db-event)
   (let* ((slots ; the order must match *event-attributes*
           '(amuse::time amuse::interval deltast cpitch mpitch accidental 
@@ -97,7 +99,28 @@
           (db-atts (nthcdr 3 db-event) (cdr db-atts)))
          ((null slts) mtp-event)
       (setf (slot-value mtp-event (car slts)) (car db-atts)))))
-#.(clsql:restore-sql-reader-syntax-state) 
+
+;;; Monodies 
+
+(defmethod monody ((identifier mtp-composition-identifier))
+  (monody (get-composition identifier)))
+
+(defmethod monody ((c mtp-composition))
+  (let ((monody (make-instance 'mtp-monody 
+                               :dataset-id (dataset-id c)
+                               :composition-id (composition-id c)
+                               :description (description c)
+                               :time 0 
+                               :interval (duration c)))
+        (events nil)
+        (monody-voice 1))
+    (sequence:dosequence (event c)
+      (when (= (%mtp-voice event) monody-voice)
+        (push event events)))
+    (sequence:adjust-sequence 
+     monody (length events)
+     :initial-contents (sort events #'< :key #'amuse:timepoint))
+    monody))
 
 ;;; Constituents from compositions: time-signatures 
 
@@ -215,7 +238,6 @@
       (setf (duration current) interval)
       (push current results))
     (nreverse results)))
-      
 
 ;;; Events: Pitch