annotate implementations/mtp/methods.lisp @ 53:ce4a90427366

implementations/mtp/: add interface to datasets

darcs-hash:20070621120721-c0ce4-54d29dd03ab4d7d61c70ed808d0fd3277687929e.gz

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

;;; Compositions 

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

(defgeneric get-dataset (identifer))

(defmethod get-dataset ((identifier mtp-dataset-identifier))
  (let* ((dataset-id (dataset-id identifier))
         (where-clause [= [dataset-id] dataset-id])
         (data (clsql:select [*] :from [mtp-dataset] :where where-clause))
         (dataset (make-mtp-dataset :dataset-id (first data) 
                                    :description (second data) 
                                    :timebase (third data) 
                                    :midc (fourth data)))
         (compositions nil)
         (composition-count 
          (1+ 
           (car 
            (clsql:select [max [composition-id]] :from [mtp-composition] 
                          :where where-clause :flatp t :field-names nil)))))
    (dotimes (composition-id composition-count) 
      (push (get-composition 
             (make-mtp-composition-identifier dataset-id composition-id))
            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)))
         (event-count 
          (1+ 
           (car 
            (clsql:select [max [event-id]] :from [mtp-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 [mtp-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 [mtp-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)
  )