Mercurial > hg > amuse

annotate implementations/mtp/methods.lisp @ 330:2fbff655ba47 tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Removed cpitch-adj and cents SQL columns
author Jeremy Gow <jeremy.gow@gmail.com>
date Mon, 21 Jan 2013 11:08:11 +0000
parents f54848e1f74c
children
rev   line source
m@46 1 (cl:in-package #:amuse-mtp)
m@46 2
jeremy@329 3 ;;; Are we using cents to represent chromatc pitch, or MIDI values?
jeremy@329 4 ;;; A hack to allow backwards compatibility with old MIDI value databases.
jeremy@329 5 (defvar *cpitch-cents* t)
jeremy@329 6
m@46 7 ;;; Compositions
m@46 8
m@46 9 #.(clsql:locally-enable-sql-reader-syntax)
m@46 10
m@87 11 (defvar *event-attributes*
m@87 12 (list [dataset-id] [composition-id] [event-id]
jeremy@330 13 [onset] [dur] [deltast] [cpitch]
jeremy@328 14 [mpitch] [accidental] [keysig] [mode]
marcus@326 15 [barlength] [pulses] [phrase] [tempo] [dyn] [voice] [bioi]
marcus@326 16 [ornament] [comma] [articulation]))
m@87 17
m@53 18 (defgeneric get-dataset (identifer))
m@53 19
m@53 20 (defmethod get-dataset ((identifier mtp-dataset-identifier))
m@53 21 (let* ((dataset-id (dataset-id identifier))
m@53 22 (where-clause [= [dataset-id] dataset-id])
m@149 23 (db-dataset (car (clsql:select [*] :from [mtp-dataset] :where where-clause)))
marcus@326 24 (db-compositions (clsql:select [composition-id][description][timebase]
m@87 25 :from [mtp-composition]
m@87 26 :order-by '(([composition-id] :asc))
m@87 27 :where where-clause))
m@87 28 (db-events (apply #'clsql:select
m@87 29 (append *event-attributes*
m@87 30 (list :from [mtp-event]
m@87 31 :order-by '(([composition-id] :asc)
m@87 32 ([event-id] :asc))
m@87 33 :where where-clause))))
m@87 34 (dataset (make-mtp-dataset :dataset-id (first db-dataset)
m@87 35 :description (second db-dataset)
m@87 36 :timebase (third db-dataset)
m@87 37 :midc (fourth db-dataset)))
m@53 38 (compositions nil)
m@87 39 (events nil))
m@87 40 ;; for each db-composition
m@87 41 (dolist (dbc db-compositions)
marcus@326 42 (let ((composition-id (first dbc))
marcus@326 43 (description (second dbc))
marcus@326 44 (timebase (third dbc)))
m@87 45 ;; for each db-event
m@87 46 (do* ((dbes db-events (cdr dbes))
m@87 47 (dbe (car dbes) (car dbes))
m@87 48 (cid (second dbe) (second dbe)))
m@87 49 ((or (null dbes) (not (= cid composition-id)))
m@87 50 (setf db-events dbes))
m@87 51 (when dbe
marcus@326 52 (push (db-event->mtp-event dbe timebase) events)))
m@149 53 (when events
m@149 54 (let* ((interval (+ (timepoint (car events)) (duration (car events))))
m@149 55 (composition
m@149 56 (make-mtp-composition :dataset-id dataset-id
m@149 57 :composition-id composition-id
m@149 58 :description description
marcus@326 59 :timebase timebase
m@149 60 :time 0
m@149 61 :interval interval)))
m@149 62 (sequence:adjust-sequence composition (length events)
m@149 63 :initial-contents (nreverse events))
m@149 64 (setf events nil)
m@149 65 (push composition compositions)))))
m@53 66 (sequence:adjust-sequence dataset (length compositions)
m@53 67 :initial-contents (nreverse compositions))
m@53 68 dataset))
m@53 69
m@46 70 (defmethod get-composition ((identifier mtp-composition-identifier))
m@46 71 (let* ((dataset-id (dataset-id identifier))
m@46 72 (composition-id (composition-id identifier))
m@46 73 (where-clause [and [= [dataset-id] dataset-id]
m@46 74 [= [composition-id] composition-id]])
m@46 75 (description
m@51 76 (car (clsql:select [description] :from [mtp-composition]
m@46 77 :where where-clause :flatp t :field-names nil)))
marcus@326 78 (timebase
marcus@326 79 (car (clsql:select [timebase] :from [mtp-composition]
marcus@326 80 :where where-clause :flatp t :field-names nil)))
m@87 81 (db-events (apply #'clsql:select
m@87 82 (append *event-attributes*
m@87 83 (list :from [mtp-event]
m@87 84 :order-by '(([event-id] :asc))
m@87 85 :where where-clause))))
m@46 86 (events nil))
m@87 87 (dolist (e db-events)
marcus@326 88 (push (db-event->mtp-event e timebase) events))
m@46 89 (let* ((interval (+ (timepoint (car events)) (duration (car events))))
m@46 90 (composition
m@46 91 (make-mtp-composition :dataset-id dataset-id
m@46 92 :composition-id composition-id
m@46 93 :description description
marcus@326 94 :timebase timebase
m@46 95 :time 0
m@46 96 :interval interval)))
m@46 97 (sequence:adjust-sequence composition (length events)
m@46 98 :initial-contents (nreverse events))
m@46 99 composition)))
m@46 100
m@90 101 #.(clsql:restore-sql-reader-syntax-state)
m@90 102
marcus@326 103 (defun db-event->mtp-event (db-event timebase)
m@87 104 (let* ((slots ; the order must match *event-attributes*
jeremy@330 105 '(amuse::time amuse::interval deltast cpitch mpitch accidental
marcus@326 106 keysig mode barlength pulses phrase tempo dyn voice bioi
marcus@326 107 ornament comma articulation))
marcus@326 108 (time-slots '(amuse::time amuse::interval deltast barlength bioi))
m@46 109 (mtp-event
m@87 110 (make-mtp-event :dataset-id (first db-event)
m@87 111 :composition-id (second db-event)
m@87 112 :event-id (third db-event))))
m@87 113 (do* ((slts slots (cdr slts))
m@87 114 (db-atts (nthcdr 3 db-event) (cdr db-atts)))
m@87 115 ((null slts) mtp-event)
marcus@326 116 (if (member (car slts) time-slots :test #'eql)
marcus@326 117 (setf (slot-value mtp-event (car slts)) (convert-time-slot (car db-atts) timebase))
marcus@326 118 (setf (slot-value mtp-event (car slts)) (car db-atts))))))
marcus@326 119
marcus@326 120 (defun convert-time-slot (value timebase)
marcus@326 121 "Convert native representation of time into a representation where
marcus@326 122 a crotchet has a value of 96."
marcus@326 123 (if (or (null value) (null timebase))
marcus@326 124 nil
marcus@326 125 (let ((multiplier (/ 96 timebase)))
marcus@326 126 (* value multiplier))))
m@90 127
m@90 128 ;;; Monodies
m@90 129
m@90 130 (defmethod monody ((identifier mtp-composition-identifier))
m@90 131 (monody (get-composition identifier)))
m@90 132
m@90 133 (defmethod monody ((c mtp-composition))
m@292 134 ;; using the voice of the first event in the piece
m@90 135 (let ((monody (make-instance 'mtp-monody
m@90 136 :dataset-id (dataset-id c)
m@90 137 :composition-id (composition-id c)
m@90 138 :description (description c)
marcus@326 139 :timebase (composition-timebase c)
m@90 140 :time 0
m@90 141 :interval (duration c)))
m@90 142 (events nil)
m@292 143 (monody-voice nil))
m@90 144 (sequence:dosequence (event c)
m@292 145 (when (null monody-voice)
m@292 146 (setf monody-voice (%mtp-voice event)))
m@90 147 (when (= (%mtp-voice event) monody-voice)
m@90 148 (push event events)))
m@90 149 (sequence:adjust-sequence
m@90 150 monody (length events)
m@90 151 :initial-contents (sort events #'< :key #'amuse:timepoint))
m@90 152 monody))
m@46 153
marcus@326 154
m@46 155 ;;; Constituents from compositions: time-signatures
m@46 156
m@96 157 (defmethod crotchet ((dataset mtp-dataset))
d@136 158 (amuse:make-standard-period
m@96 159 (/ (dataset-timebase dataset) 4)))
m@87 160
marcus@326 161 (defmethod crotchet ((composition mtp-composition))
marcus@326 162 (amuse:make-standard-period
marcus@326 163 (/ (composition-timebase composition) 4)))
marcus@326 164
m@46 165 #.(clsql:locally-enable-sql-reader-syntax)
m@96 166 (defmethod crotchet ((event mtp-event))
m@96 167 (let ((timebase
marcus@326 168 (car (clsql:select [timebase] :from [mtp-composition]
marcus@326 169 :where [and [= [dataset-id] (dataset-id event)] [= [composition-id] (composition-id event)]]
m@96 170 :flatp t
m@96 171 :field-names nil))))
d@136 172 (amuse:make-standard-period (/ timebase 4))))
m@46 173 #.(clsql:restore-sql-reader-syntax-state)
m@46 174
m@69 175 (defmethod get-applicable-time-signatures ((e mtp-event) c)
m@69 176 (declare (ignore c))
m@291 177 ;(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 178 (let* ((pulses (%mtp-pulses e))
m@291 179 (barlength (%mtp-barlength e))
m@291 180 (timebase (* 4 (duration (crotchet e))))
m@291 181 (numerator (if (null pulses) 0 pulses))
m@291 182 (denominator (if (null barlength)
m@291 183 1
m@291 184 (/ timebase (/ barlength pulses)))))
m@291 185 (list
m@291 186 (amuse:make-standard-time-signature-period numerator
m@291 187 denominator
d@136 188 (timepoint e)
d@136 189 (duration e)))))
m@69 190
m@46 191 (defmethod time-signatures ((c mtp-composition))
m@46 192 (let ((results nil)
m@46 193 (interval 0)
m@46 194 (current nil))
m@46 195 (sequence:dosequence (event c)
m@70 196 (let ((ts (car (get-applicable-time-signatures event c))))
m@46 197 (when (and (%mtp-barlength event)
m@46 198 (%mtp-pulses event)
m@46 199 (or (null current)
m@46 200 (not (time-signature-equal ts current))))
m@46 201 (unless (null current)
m@46 202 (setf (duration current) interval)
m@46 203 (push current results))
m@46 204 (setf interval 0
m@46 205 current ts)))
m@46 206 (incf interval (%mtp-deltast event))
m@46 207 (incf interval (duration event)))
m@46 208 (when current
m@46 209 (setf (duration current) interval)
m@46 210 (push current results))
m@46 211 (nreverse results)))
m@46 212
m@46 213 ;;; Constituents from compositions: key-signatures
m@46 214
m@69 215 (defmethod get-applicable-key-signatures ((e mtp-event) c)
m@69 216 (declare (ignore c))
m@69 217 (let* ((sharps (%mtp-keysig e))
m@68 218 (mode (%mtp-mode e))
m@69 219 (midi-mode (and mode (if (= mode 0) 0 1))))
d@136 220 (list (amuse:make-midi-key-signature-period sharps midi-mode
d@136 221 (timepoint e)
d@136 222 (duration e)))))
m@46 223
m@68 224 (defmethod key-signatures ((c mtp-composition))
m@46 225 (let ((results nil)
m@46 226 (interval 0)
m@46 227 (current nil))
m@46 228 (sequence:dosequence (event c)
m@69 229 (let ((ks (car (get-applicable-key-signatures event c))))
m@46 230 (when (and (%mtp-keysig event)
m@46 231 (%mtp-mode event)
m@46 232 (or (null current)
m@46 233 (not (key-signature-equal ks current))))
m@46 234 (unless (null current)
m@46 235 (setf (duration current) interval)
m@46 236 (push current results))
m@46 237 (setf interval 0
m@46 238 current ks)))
m@46 239 (incf interval (%mtp-deltast event))
m@46 240 (incf interval (duration event)))
m@46 241 (when current
m@46 242 (setf (duration current) interval)
m@46 243 (push current results))
m@46 244 (nreverse results)))
m@46 245
m@46 246 ;;; Constituents from compositions: tempi
m@46 247
m@69 248 (defmethod get-applicable-tempi ((e mtp-event) c)
m@69 249 (declare (ignore c))
d@136 250 (list (amuse:make-standard-tempo-period (%mtp-tempo e)
d@136 251 (timepoint e)
d@136 252 (duration e))))
m@69 253
m@46 254 (defmethod tempi ((c mtp-composition))
m@46 255 (let ((results nil)
m@46 256 (interval 0)
m@46 257 (current nil))
m@46 258 (sequence:dosequence (event c)
m@46 259 (when (and (%mtp-tempo event)
m@46 260 (or (null current)
m@46 261 (not (= (bpm current) (%mtp-tempo event)))))
m@46 262 (unless (null current)
m@46 263 (setf (duration current) interval)
m@46 264 (push current results))
m@69 265 (let ((new (car (get-applicable-tempi event c))))
m@46 266 (setf interval 0
m@46 267 current new)))
m@46 268 (incf interval (%mtp-deltast event))
m@46 269 (incf interval (duration event)))
m@46 270 (when current
m@46 271 (setf (duration current) interval)
m@46 272 (push current results))
m@46 273 (nreverse results)))
m@46 274
m@46 275 ;;; Events: Pitch
m@46 276
m@46 277 (defmethod chromatic-pitch ((e mtp-event))
m@46 278 (make-chromatic-pitch (%mtp-cpitch e)))
m@46 279
m@46 280 (defmethod midi-pitch-number ((e mtp-event))
m@46 281 (%mtp-cpitch e))
m@46 282
m@110 283 (defmethod diatonic-pitch-cp ((e mtp-event))
m@110 284 ;; MIPS morphetic pitch is relative to An0 while cpitch is relative to Cn2
jeremy@329 285 ;; Make sure MIDI value is used
jeremy@329 286 (- (if *cpitch-cents* (/ (%mtp-cpitch e) 100) (%mtp-cpitch e))
jeremy@329 287 21))
m@110 288
m@110 289 (defmethod diatonic-pitch-mp ((e mtp-event))
m@82 290 ;; MIPS morphetic pitch is relative to An0 while mpitch is relative to Cn2
m@82 291 (- (%mtp-mpitch e) 12))
m@82 292
m@46 293 (defmethod diatonic-pitch ((e mtp-event))
m@110 294 (make-mips-pitch (diatonic-pitch-cp e)
m@110 295 (diatonic-pitch-mp e)))
m@82 296
m@84 297 (defmethod asa-pitch-string ((e mtp-event))
m@110 298 (asa-pitch-string (diatonic-pitch e)))
m@84 299
m@82 300 #.(clsql:locally-enable-sql-reader-syntax)
m@82 301 (defmethod middle-c ((e mtp-event))
m@82 302 (let ((cpitch (car (clsql:select [midc] :from [dataset]
m@82 303 :where [= [dataset-id] (dataset-id e)]
m@82 304 :flatp t :field-names nil))))
m@82 305 (make-mtp-event :cpitch cpitch :mpitch (* (/ cpitch 12) 7))))
m@82 306 #.(clsql:restore-sql-reader-syntax-state)
m@79 307
m@79 308 ;;; Phrase boundaries
m@79 309
m@98 310 (defmethod ground-truth-segmenter-before ((c mtp-composition))
m@98 311 (declare (ignore c))
m@98 312 (make-instance 'mtp-before-segmenter))
m@98 313
m@98 314 (defmethod ground-truth-segmenter-after ((c mtp-composition))
m@98 315 (declare (ignore c))
m@99 316 (make-instance 'mtp-after-segmenter))
m@98 317
m@98 318 (defmethod ground-truth-segmenter-before ((e mtp-event))
m@98 319 (declare (ignore e))
m@98 320 (make-instance 'mtp-before-segmenter))
m@98 321
m@98 322 (defmethod ground-truth-segmenter-after ((e mtp-event))
m@98 323 (declare (ignore e))
m@99 324 (make-instance 'mtp-after-segmenter))
m@98 325
m@79 326 (defmethod boundary-strength ((s mtp-before-segmenter) (e mtp-event) c)
m@79 327 (declare (ignore s c))
m@79 328 (let ((phrase (%mtp-phrase e)))
m@79 329 (case phrase
m@79 330 (-1 1)
m@79 331 (t 0))))
m@79 332
m@79 333 (defmethod boundary-strength ((s mtp-after-segmenter) (e mtp-event) c)
m@79 334 (declare (ignore s c))
m@79 335 (let ((phrase (%mtp-phrase e)))
m@79 336 (case phrase
m@79 337 (1 1)
m@79 338 (t 0))))