Mercurial > hg > amuse
changeset 87:19a263fb92d1
implementations/mtp/: faster implementations of GET-COMPOSITION and GET-DATASET
darcs-hash:20070718151258-c0ce4-6431a2c8e4939fefeb0c7d6c9e2aa91d9474c232.gz
| author | Marcus Pearce <m.pearce@gold.ac.uk> |
|---|---|
| date | Wed, 18 Jul 2007 16:12:58 +0100 |
| parents | 7a0ee88f1edb |
| children | 8ea75cc8bc2c |
| files | implementations/mtp/methods.lisp tools/segmentation/classes.lisp |
| diffstat | 2 files changed, 76 insertions(+), 56 deletions(-) [+] |
line wrap: on
line diff
--- a/implementations/mtp/methods.lisp Tue Jul 17 17:51:05 2007 +0100 +++ b/implementations/mtp/methods.lisp Wed Jul 18 16:12:58 2007 +0100 @@ -4,32 +4,60 @@ #.(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]) - (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))) + (db-dataset (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) - (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)) + (events nil)) + ;; for each db-composition + (dolist (dbc db-compositions) + (let ((composition-id (first dbc)) + (description (second 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))) + (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)) @@ -38,14 +66,14 @@ (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)))) + (db-events (apply #'clsql:select + (append *event-attributes* + (list :from [mtp-event] + :order-by '(([event-id] :asc)) + :where where-clause)))) (events nil)) - (dotimes (event-id event-count) - (push (get-event dataset-id composition-id event-id) events)) + (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 @@ -57,43 +85,35 @@ :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]))) +(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)) (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)))))) - + (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))))) #.(clsql:restore-sql-reader-syntax-state) - ;;; Constituents from compositions: time-signatures +(defgeneric timebase (object)) + +(defmethod timebase ((dataset mtp-dataset)) + (dataset-timebase dataset)) + #.(clsql:locally-enable-sql-reader-syntax) -(defun timebase-for-event (event) +(defmethod timebase ((composition mtp-composition)) + (car (clsql:select [timebase] :from [mtp-dataset] + :where [= [dataset-id] + (dataset-id composition)] + :flatp t + :field-names nil))) +(defmethod timebase ((event mtp-event)) (car (clsql:select [timebase] :from [mtp-dataset] :where [= [dataset-id] (dataset-id event)] @@ -105,7 +125,7 @@ (declare (ignore c)) (let ((pulses (%mtp-pulses e)) (barlength (%mtp-barlength e)) - (timebase (timebase-for-event e))) + (timebase (timebase e))) (list (amuse:make-basic-time-signature pulses (/ timebase (/ barlength pulses))
--- a/tools/segmentation/classes.lisp Tue Jul 17 17:51:05 2007 +0100 +++ b/tools/segmentation/classes.lisp Wed Jul 18 16:12:58 2007 +0100 @@ -11,5 +11,5 @@ (defclass ground-truth-segmenter (segmenter) ()) (defclass segmentation () () - (:documenation "Base class for delivering the results of + (:documentation "Base class for delivering the results of segmentation"))