annotate implementations/mtp/methods.lisp @ 291:2d2bc910c364

Handle missing time signature in MTP implementation of GET-APPLICABLE-TIME-SIGNATURES.

darcs-hash:20090722123745-c0ce4-b153c9962f3d9f4cc6ce2a44cf1c3a65951c3ce7.gz

(cl:in-package #:amuse-mtp)

;;; Compositions 

#.(clsql:locally-enable-sql-reader-syntax)

(defvar *event-attributes* 
  (list [dataset-id] [composition-id] [event-id]
        [onset] [dur] [deltast] [cpitch] [mpitch] [accidental] [keysig] [mode]
        [barlength] [pulses] [phrase] [tempo] [dyn] [voice]))

(defgeneric get-dataset (identifer))

(defmethod get-dataset ((identifier mtp-dataset-identifier))
  (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] 
                                        :from [mtp-composition] 
                                        :order-by '(([composition-id] :asc))
                                        :where where-clause))
         (db-events (apply #'clsql:select 
                           (append *event-attributes* 
                                   (list :from [mtp-event] 
                                         :order-by '(([composition-id] :asc)
                                                     ([event-id] :asc))
                                         :where where-clause))))
         (dataset (make-mtp-dataset :dataset-id (first db-dataset) 
                                    :description (second db-dataset) 
                                    :timebase (third db-dataset) 
                                    :midc (fourth db-dataset)))
         (compositions nil)
         (events nil))
    ;; for each db-composition 
    (dolist (dbc db-compositions)
      (let ((composition-id (car dbc))
            (description (car dbc)))
        ;; for each db-event 
        (do* ((dbes db-events (cdr dbes))
              (dbe (car dbes) (car dbes))
              (cid (second dbe) (second dbe)))
             ((or (null dbes) (not (= cid composition-id)))
              (setf db-events dbes))
          (when dbe
            (push (db-event->mtp-event dbe) 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
                                        :time 0
                                        :interval interval)))
            (sequence:adjust-sequence composition (length events)
                                      :initial-contents (nreverse events))
            (setf events nil)
            (push composition compositions)))))
    (sequence:adjust-sequence dataset (length compositions)
                              :initial-contents (nreverse compositions))
    dataset))

(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 [mtp-composition] 
                             :where where-clause :flatp t :field-names nil)))
         (db-events (apply #'clsql:select 
                           (append *event-attributes* 
                                   (list :from [mtp-event] 
                                         :order-by '(([event-id] :asc))
                                         :where where-clause))))
         (events nil))
    (dolist (e db-events)
      (push (db-event->mtp-event e) 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)))

#.(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 
            keysig mode barlength pulses phrase tempo dyn voice bioi))
         (mtp-event
          (make-mtp-event :dataset-id (first db-event)
                          :composition-id (second db-event)
                          :event-id (third db-event))))
    (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)))))

;;; 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 

(defmethod crotchet ((dataset mtp-dataset))
  (amuse:make-standard-period 
   (/ (dataset-timebase dataset) 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)]
                            :flatp t 
                            :field-names nil))))
    (amuse:make-standard-period (/ timebase 4))))
#.(clsql:restore-sql-reader-syntax-state) 

(defmethod get-applicable-time-signatures ((e mtp-event) c)
  (declare (ignore c))
  ;(format t "~&GATS ~A ~A ~A: pulses = ~A; barlength = ~A.~%" (dataset-id e) (composition-id e) (event-id e) (%mtp-pulses e) (%mtp-barlength e))
  (let* ((pulses (%mtp-pulses e))
         (barlength (%mtp-barlength e))
         (timebase (* 4 (duration (crotchet e))))
         (numerator (if (null pulses) 0 pulses))
         (denominator (if (null barlength)
                          1
                          (/ timebase (/ barlength pulses)))))
    (list
     (amuse:make-standard-time-signature-period numerator
                                                denominator
						(timepoint e) 
						(duration e)))))

(defmethod time-signatures ((c mtp-composition))
  (let ((results nil)
        (interval 0) 
        (current nil))
    (sequence:dosequence (event c)
      (let ((ts (car (get-applicable-time-signatures event c))))
        (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 

(defmethod get-applicable-key-signatures ((e mtp-event) c)
  (declare (ignore c))
  (let* ((sharps (%mtp-keysig e))
         (mode (%mtp-mode e))
         (midi-mode (and mode (if (= mode 0) 0 1))))
    (list (amuse:make-midi-key-signature-period sharps midi-mode 
						(timepoint e) 
						(duration e)))))

(defmethod key-signatures ((c mtp-composition))
  (let ((results nil)
        (interval 0) 
        (current nil))
    (sequence:dosequence (event c)
      (let ((ks (car (get-applicable-key-signatures event c))))
        (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 get-applicable-tempi ((e mtp-event) c)
  (declare (ignore c))
  (list (amuse:make-standard-tempo-period (%mtp-tempo e) 
					  (timepoint e) 
					  (duration e))))

(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 (car (get-applicable-tempi event c))))
          (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-cp ((e mtp-event))
  ;; MIPS morphetic pitch is relative to An0 while cpitch is relative to Cn2
  (- (%mtp-cpitch e) 21))

(defmethod diatonic-pitch-mp ((e mtp-event))
  ;; MIPS morphetic pitch is relative to An0 while mpitch is relative to Cn2
  (- (%mtp-mpitch e) 12))

(defmethod diatonic-pitch ((e mtp-event))
  (make-mips-pitch (diatonic-pitch-cp e)
                   (diatonic-pitch-mp e)))

(defmethod asa-pitch-string ((e mtp-event))
  (asa-pitch-string (diatonic-pitch e)))

#.(clsql:locally-enable-sql-reader-syntax)
(defmethod middle-c ((e mtp-event))
  (let ((cpitch (car (clsql:select [midc] :from [dataset] 
                                   :where [= [dataset-id] (dataset-id e)]
                                   :flatp t :field-names nil))))
    (make-mtp-event :cpitch cpitch :mpitch (* (/ cpitch 12) 7))))
#.(clsql:restore-sql-reader-syntax-state)

;;; Phrase boundaries 

(defmethod ground-truth-segmenter-before ((c mtp-composition))
  (declare (ignore c))
  (make-instance 'mtp-before-segmenter))

(defmethod ground-truth-segmenter-after ((c mtp-composition))
  (declare (ignore c))
  (make-instance 'mtp-after-segmenter))

(defmethod ground-truth-segmenter-before ((e mtp-event))
  (declare (ignore e))
  (make-instance 'mtp-before-segmenter))

(defmethod ground-truth-segmenter-after ((e mtp-event))
  (declare (ignore e))
  (make-instance 'mtp-after-segmenter))

(defmethod boundary-strength ((s mtp-before-segmenter) (e mtp-event) c)
  (declare (ignore s c))
  (let ((phrase (%mtp-phrase e)))
    (case phrase
      (-1 1)
      (t 0))))

(defmethod boundary-strength ((s mtp-after-segmenter) (e mtp-event) c)
  (declare (ignore s c))
  (let ((phrase (%mtp-phrase e)))
    (case phrase
      (1 1)
      (t 0))))