annotate implementations/mtp/methods.lisp @ 82:92e6625473e2

implementations/mtp: implement diatonic pitch

darcs-hash:20070717120244-c0ce4-4667ed1bf08ca41f6619e895c4cdc2e24224df04.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 

#.(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 get-applicable-time-signatures ((e mtp-event) c)
  (declare (ignore c))
  (let ((pulses (%mtp-pulses e))
        (barlength (%mtp-barlength e))
        (timebase (timebase-for-event e)))
    (list 
     (amuse:make-basic-time-signature pulses 
                                      (/ timebase (/ barlength pulses))
                                      (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 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-tempo (%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 meredith-morphetic-pitch-number ((e mtp-event))
  ;; MIPS morphetic pitch is relative to An0 while mpitch is relative to Cn2
  (- (%mtp-mpitch e) 12))

(defmethod mips-pitch ((e mtp-event))
  (make-mips-pitch (meredith-chromatic-pitch-number e)
                   (meredith-morphetic-pitch-number e)))

(defmethod diatonic-pitch ((e mtp-event))
  (diatonic-pitch (mips-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 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))))