m@46: (cl:in-package #:amuse-mtp)
m@46: 
jeremy@329: ;;; Are we using cents to represent chromatc pitch, or MIDI values?
jeremy@329: ;;; A hack to allow backwards compatibility with old MIDI value databases.
jeremy@329: (defvar *cpitch-cents* t)
jeremy@329: 
m@46: ;;; Compositions 
m@46: 
m@46: #.(clsql:locally-enable-sql-reader-syntax)
m@46: 
m@87: (defvar *event-attributes* 
m@87:   (list [dataset-id] [composition-id] [event-id]
jeremy@330:         [onset] [dur] [deltast] [cpitch] 
jeremy@328: 	[mpitch] [accidental] [keysig] [mode]
marcus@326:         [barlength] [pulses] [phrase] [tempo] [dyn] [voice] [bioi] 
marcus@326:         [ornament] [comma] [articulation]))
m@87: 
m@53: (defgeneric get-dataset (identifer))
m@53: 
m@53: (defmethod get-dataset ((identifier mtp-dataset-identifier))
m@53:   (let* ((dataset-id (dataset-id identifier))
m@53:          (where-clause [= [dataset-id] dataset-id])
m@149:          (db-dataset (car (clsql:select [*] :from [mtp-dataset] :where where-clause)))
marcus@326:          (db-compositions (clsql:select [composition-id][description][timebase]
m@87:                                         :from [mtp-composition] 
m@87:                                         :order-by '(([composition-id] :asc))
m@87:                                         :where where-clause))
m@87:          (db-events (apply #'clsql:select 
m@87:                            (append *event-attributes* 
m@87:                                    (list :from [mtp-event] 
m@87:                                          :order-by '(([composition-id] :asc)
m@87:                                                      ([event-id] :asc))
m@87:                                          :where where-clause))))
m@87:          (dataset (make-mtp-dataset :dataset-id (first db-dataset) 
m@87:                                     :description (second db-dataset) 
m@87:                                     :timebase (third db-dataset) 
m@87:                                     :midc (fourth db-dataset)))
m@53:          (compositions nil)
m@87:          (events nil))
m@87:     ;; for each db-composition 
m@87:     (dolist (dbc db-compositions)
marcus@326:       (let ((composition-id (first dbc))
marcus@326:             (description (second dbc))
marcus@326:             (timebase (third dbc)))
m@87:         ;; for each db-event 
m@87:         (do* ((dbes db-events (cdr dbes))
m@87:               (dbe (car dbes) (car dbes))
m@87:               (cid (second dbe) (second dbe)))
m@87:              ((or (null dbes) (not (= cid composition-id)))
m@87:               (setf db-events dbes))
m@87:           (when dbe
marcus@326:             (push (db-event->mtp-event dbe timebase) events)))
m@149:         (when events
m@149:           (let* ((interval (+ (timepoint (car events)) (duration (car events))))
m@149:                  (composition 
m@149:                   (make-mtp-composition :dataset-id dataset-id 
m@149:                                         :composition-id composition-id
m@149:                                         :description description
marcus@326:                                         :timebase timebase
m@149:                                         :time 0
m@149:                                         :interval interval)))
m@149:             (sequence:adjust-sequence composition (length events)
m@149:                                       :initial-contents (nreverse events))
m@149:             (setf events nil)
m@149:             (push composition compositions)))))
m@53:     (sequence:adjust-sequence dataset (length compositions)
m@53:                               :initial-contents (nreverse compositions))
m@53:     dataset))
m@53: 
m@46: (defmethod get-composition ((identifier mtp-composition-identifier))
m@46:   (let* ((dataset-id (dataset-id identifier))
m@46:          (composition-id (composition-id identifier))
m@46:          (where-clause [and [= [dataset-id] dataset-id]
m@46:                             [= [composition-id] composition-id]])
m@46:          (description 
m@51:           (car (clsql:select [description] :from [mtp-composition] 
m@46:                              :where where-clause :flatp t :field-names nil)))
marcus@326:          (timebase 
marcus@326:           (car (clsql:select [timebase] :from [mtp-composition] 
marcus@326:                              :where where-clause :flatp t :field-names nil)))
m@87:          (db-events (apply #'clsql:select 
m@87:                            (append *event-attributes* 
m@87:                                    (list :from [mtp-event] 
m@87:                                          :order-by '(([event-id] :asc))
m@87:                                          :where where-clause))))
m@46:          (events nil))
m@87:     (dolist (e db-events)
marcus@326:       (push (db-event->mtp-event e timebase) events))
m@46:     (let* ((interval (+ (timepoint (car events)) (duration (car events))))
m@46:            (composition 
m@46:             (make-mtp-composition :dataset-id dataset-id 
m@46:                                   :composition-id composition-id
m@46:                                   :description description
marcus@326:                                   :timebase timebase
m@46:                                   :time 0
m@46:                                   :interval interval)))
m@46:       (sequence:adjust-sequence composition (length events)
m@46:                                 :initial-contents (nreverse events))
m@46:       composition)))
m@46: 
m@90: #.(clsql:restore-sql-reader-syntax-state) 
m@90: 
marcus@326: (defun db-event->mtp-event (db-event timebase)
m@87:   (let* ((slots ; the order must match *event-attributes*
jeremy@330:           '(amuse::time amuse::interval deltast cpitch mpitch accidental 
marcus@326:             keysig mode barlength pulses phrase tempo dyn voice bioi 
marcus@326:             ornament comma articulation))
marcus@326:          (time-slots '(amuse::time amuse::interval deltast barlength bioi))
m@46:          (mtp-event
m@87:           (make-mtp-event :dataset-id (first db-event)
m@87:                           :composition-id (second db-event)
m@87:                           :event-id (third db-event))))
m@87:     (do* ((slts slots (cdr slts))
m@87:           (db-atts (nthcdr 3 db-event) (cdr db-atts)))
m@87:          ((null slts) mtp-event)
marcus@326:       (if (member (car slts) time-slots :test #'eql)
marcus@326:           (setf (slot-value mtp-event (car slts)) (convert-time-slot (car db-atts) timebase))
marcus@326:           (setf (slot-value mtp-event (car slts)) (car db-atts))))))
marcus@326: 
marcus@326: (defun convert-time-slot (value timebase)
marcus@326:   "Convert native representation of time into a representation where
marcus@326:     a crotchet has a value of 96."
marcus@326:   (if (or (null value) (null timebase))
marcus@326:       nil
marcus@326:       (let ((multiplier (/ 96 timebase)))
marcus@326:         (* value multiplier))))
m@90: 
m@90: ;;; Monodies 
m@90: 
m@90: (defmethod monody ((identifier mtp-composition-identifier))
m@90:   (monody (get-composition identifier)))
m@90: 
m@90: (defmethod monody ((c mtp-composition))
m@292:   ;; using the voice of the first event in the piece
m@90:   (let ((monody (make-instance 'mtp-monody 
m@90:                                :dataset-id (dataset-id c)
m@90:                                :composition-id (composition-id c)
m@90:                                :description (description c)
marcus@326:                                :timebase (composition-timebase c)
m@90:                                :time 0 
m@90:                                :interval (duration c)))
m@90:         (events nil)
m@292:         (monody-voice nil))
m@90:     (sequence:dosequence (event c)
m@292:       (when (null monody-voice)
m@292:         (setf monody-voice (%mtp-voice event)))
m@90:       (when (= (%mtp-voice event) monody-voice)
m@90:         (push event events)))
m@90:     (sequence:adjust-sequence 
m@90:      monody (length events)
m@90:      :initial-contents (sort events #'< :key #'amuse:timepoint))
m@90:     monody))
m@46: 
marcus@326: 
m@46: ;;; Constituents from compositions: time-signatures 
m@46: 
m@96: (defmethod crotchet ((dataset mtp-dataset))
d@136:   (amuse:make-standard-period 
m@96:    (/ (dataset-timebase dataset) 4)))
m@87: 
marcus@326: (defmethod crotchet ((composition mtp-composition))
marcus@326:   (amuse:make-standard-period 
marcus@326:    (/ (composition-timebase composition) 4)))
marcus@326: 
m@46: #.(clsql:locally-enable-sql-reader-syntax)
m@96: (defmethod crotchet ((event mtp-event))
m@96:   (let ((timebase 
marcus@326:          (car (clsql:select [timebase] :from [mtp-composition]
marcus@326:                             :where [and [= [dataset-id] (dataset-id event)] [= [composition-id] (composition-id event)]]
m@96:                             :flatp t 
m@96:                             :field-names nil))))
d@136:     (amuse:make-standard-period (/ timebase 4))))
m@46: #.(clsql:restore-sql-reader-syntax-state) 
m@46: 
m@69: (defmethod get-applicable-time-signatures ((e mtp-event) c)
m@69:   (declare (ignore c))
m@291:   ;(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))
m@291:   (let* ((pulses (%mtp-pulses e))
m@291:          (barlength (%mtp-barlength e))
m@291:          (timebase (* 4 (duration (crotchet e))))
m@291:          (numerator (if (null pulses) 0 pulses))
m@291:          (denominator (if (null barlength)
m@291:                           1
m@291:                           (/ timebase (/ barlength pulses)))))
m@291:     (list
m@291:      (amuse:make-standard-time-signature-period numerator
m@291:                                                 denominator
d@136: 						(timepoint e) 
d@136: 						(duration e)))))
m@69: 
m@46: (defmethod time-signatures ((c mtp-composition))
m@46:   (let ((results nil)
m@46:         (interval 0) 
m@46:         (current nil))
m@46:     (sequence:dosequence (event c)
m@70:       (let ((ts (car (get-applicable-time-signatures event c))))
m@46:         (when (and (%mtp-barlength event)
m@46:                    (%mtp-pulses event)
m@46:                    (or (null current)
m@46:                        (not (time-signature-equal ts current))))
m@46:           (unless (null current)
m@46:             (setf (duration current) interval)
m@46:             (push current results))
m@46:           (setf interval 0
m@46:                 current ts)))
m@46:       (incf interval (%mtp-deltast event))
m@46:       (incf interval (duration event)))
m@46:     (when current 
m@46:       (setf (duration current) interval)
m@46:       (push current results))
m@46:     (nreverse results)))
m@46: 
m@46: ;;; Constituents from compositions: key-signatures 
m@46: 
m@69: (defmethod get-applicable-key-signatures ((e mtp-event) c)
m@69:   (declare (ignore c))
m@69:   (let* ((sharps (%mtp-keysig e))
m@68:          (mode (%mtp-mode e))
m@69:          (midi-mode (and mode (if (= mode 0) 0 1))))
d@136:     (list (amuse:make-midi-key-signature-period sharps midi-mode 
d@136: 						(timepoint e) 
d@136: 						(duration e)))))
m@46: 
m@68: (defmethod key-signatures ((c mtp-composition))
m@46:   (let ((results nil)
m@46:         (interval 0) 
m@46:         (current nil))
m@46:     (sequence:dosequence (event c)
m@69:       (let ((ks (car (get-applicable-key-signatures event c))))
m@46:         (when (and (%mtp-keysig event)
m@46:                    (%mtp-mode event)
m@46:                    (or (null current)
m@46:                        (not (key-signature-equal ks current))))
m@46:           (unless (null current)
m@46:             (setf (duration current) interval)
m@46:             (push current results))
m@46:           (setf interval 0
m@46:                 current ks)))
m@46:       (incf interval (%mtp-deltast event))
m@46:       (incf interval (duration event)))
m@46:     (when current 
m@46:       (setf (duration current) interval)
m@46:       (push current results))
m@46:     (nreverse results)))
m@46: 
m@46: ;;; Constituents from compositions: tempi  
m@46: 
m@69: (defmethod get-applicable-tempi ((e mtp-event) c)
m@69:   (declare (ignore c))
d@136:   (list (amuse:make-standard-tempo-period (%mtp-tempo e) 
d@136: 					  (timepoint e) 
d@136: 					  (duration e))))
m@69: 
m@46: (defmethod tempi ((c mtp-composition)) 
m@46:   (let ((results nil)
m@46:         (interval 0) 
m@46:         (current nil))
m@46:     (sequence:dosequence (event c)
m@46:       (when (and (%mtp-tempo event)
m@46:                  (or (null current)
m@46:                      (not (= (bpm current) (%mtp-tempo event)))))
m@46:         (unless (null current) 
m@46:           (setf (duration current) interval)
m@46:           (push current results))
m@69:         (let ((new (car (get-applicable-tempi event c))))
m@46:           (setf interval 0
m@46:                 current new)))
m@46:       (incf interval (%mtp-deltast event))
m@46:       (incf interval (duration event)))
m@46:     (when current 
m@46:       (setf (duration current) interval)
m@46:       (push current results))
m@46:     (nreverse results)))
m@46: 
m@46: ;;; Events: Pitch 
m@46: 
m@46: (defmethod chromatic-pitch ((e mtp-event))
m@46:   (make-chromatic-pitch (%mtp-cpitch e)))
m@46: 
m@46: (defmethod midi-pitch-number ((e mtp-event))
m@46:   (%mtp-cpitch e))
m@46: 
m@110: (defmethod diatonic-pitch-cp ((e mtp-event))
m@110:   ;; MIPS morphetic pitch is relative to An0 while cpitch is relative to Cn2
jeremy@329:   ;; Make sure MIDI value is used
jeremy@329:   (- (if  *cpitch-cents* (/ (%mtp-cpitch e) 100) (%mtp-cpitch e))
jeremy@329:      21))
m@110: 
m@110: (defmethod diatonic-pitch-mp ((e mtp-event))
m@82:   ;; MIPS morphetic pitch is relative to An0 while mpitch is relative to Cn2
m@82:   (- (%mtp-mpitch e) 12))
m@82: 
m@46: (defmethod diatonic-pitch ((e mtp-event))
m@110:   (make-mips-pitch (diatonic-pitch-cp e)
m@110:                    (diatonic-pitch-mp e)))
m@82: 
m@84: (defmethod asa-pitch-string ((e mtp-event))
m@110:   (asa-pitch-string (diatonic-pitch e)))
m@84: 
m@82: #.(clsql:locally-enable-sql-reader-syntax)
m@82: (defmethod middle-c ((e mtp-event))
m@82:   (let ((cpitch (car (clsql:select [midc] :from [dataset] 
m@82:                                    :where [= [dataset-id] (dataset-id e)]
m@82:                                    :flatp t :field-names nil))))
m@82:     (make-mtp-event :cpitch cpitch :mpitch (* (/ cpitch 12) 7))))
m@82: #.(clsql:restore-sql-reader-syntax-state)
m@79: 
m@79: ;;; Phrase boundaries 
m@79: 
m@98: (defmethod ground-truth-segmenter-before ((c mtp-composition))
m@98:   (declare (ignore c))
m@98:   (make-instance 'mtp-before-segmenter))
m@98: 
m@98: (defmethod ground-truth-segmenter-after ((c mtp-composition))
m@98:   (declare (ignore c))
m@99:   (make-instance 'mtp-after-segmenter))
m@98: 
m@98: (defmethod ground-truth-segmenter-before ((e mtp-event))
m@98:   (declare (ignore e))
m@98:   (make-instance 'mtp-before-segmenter))
m@98: 
m@98: (defmethod ground-truth-segmenter-after ((e mtp-event))
m@98:   (declare (ignore e))
m@99:   (make-instance 'mtp-after-segmenter))
m@98: 
m@79: (defmethod boundary-strength ((s mtp-before-segmenter) (e mtp-event) c)
m@79:   (declare (ignore s c))
m@79:   (let ((phrase (%mtp-phrase e)))
m@79:     (case phrase
m@79:       (-1 1)
m@79:       (t 0))))
m@79: 
m@79: (defmethod boundary-strength ((s mtp-after-segmenter) (e mtp-event) c)
m@79:   (declare (ignore s c))
m@79:   (let ((phrase (%mtp-phrase e)))
m@79:     (case phrase
m@79:       (1 1)
m@79:       (t 0))))