d@88: (cl:in-package #:amuse-geerdes) d@88: j@288: ;; Identifiers d@88: d@100: (defgeneric cat-id (object) d@134: (:documentation "Return a database catalogue id for object (for d@134: Geerdes data, this is the company's own ID")) d@100: (defgeneric file-id (object) d@134: (:documentation "Return a database file id for object (for d@134: Geerdes data, this is a unique integer identifier)")) j@288: (defgeneric (setf cat-id) (value object)) ;; FIXME: why? d@88: (defgeneric (setf file-id) (value object)) d@88: d@88: (defmethod cat-id ((object geerdes-composition)) d@88: (%db-cat-id object)) d@88: (defmethod cat-id ((object geerdes-identifier-cat-id)) d@88: (slot-value object 'cat-id)) d@88: (defmethod file-id ((object geerdes-composition)) d@88: (%db-file-id object)) d@88: (defmethod file-id ((object geerdes-identifier-file-id)) d@88: (slot-value object 'file-id)) d@88: (defmethod (setf cat-id) (value (object geerdes-composition)) d@88: (setf (%db-cat-id object) value)) d@88: (defmethod (setf cat-id) (value (object geerdes-identifier-cat-id)) d@88: (setf (slot-value object 'cat-id) value)) d@88: (defmethod (setf file-id) (value (object geerdes-composition)) d@88: (setf (%db-file-id object) value)) d@88: (defmethod (setf file-id) (value (object geerdes-identifier-file-id)) d@88: (setf (slot-value object 'file-id) value)) d@88: j@288: ;; Identifier accessors for CHARM constituents j@288: j@288: (defmethod composition-id ((o geerdes-composition-identifier)) j@288: "Composition-id is file-id in geerdes." j@288: (file-id o)) j@288: j@288: (defmethod composition-id ((o geerdes-composition)) j@288: (file-id o)) j@288: j@288: (defmethod event-id ((o geerdes-event)) j@288: (event-id (identifier o))) j@288: j@280: ;; Specialised constructors j@280: j@280: (defmethod make-composition-identifier ((package (eql *package*)) j@280: composition-id) j@280: (g-id-file-id composition-id)) j@280: d@88: ;; Composition d@88: j@288: (defmethod get-composition ((identifier j@288: geerdes-composition-identifier)) d@88: (let* ((composition (get-geerdes-composition identifier))) d@88: (%initialise-notes composition) d@88: (%initialise-constituents composition))) d@88: d@88: (defgeneric get-geerdes-composition (identifier)) d@88: (defmethod get-geerdes-composition ((identifier geerdes-identifier-cat-id)) d@88: #.(clsql:locally-enable-sql-reader-syntax) d@88: (let* ((cat-id (cat-id identifier)) d@88: (file-info (car (clsql:select [id] [timebase] d@88: :from [midi_file] d@88: :where [= [cat_id] cat-id] d@88: :flatp t j@280: :result-types :auto j@280: :database *amuse-database*))) d@88: (timebase (second file-info)) d@88: (file-id (first file-info)) d@88: (composition (make-instance 'geerdes-composition j@281: :identifier identifier d@88: :file-id file-id d@88: :cat-id cat-id d@88: :midi-timebase timebase))) d@88: (setf (%midi-events composition) (get-db-events file-id) d@88: (%midi-constituents composition) (get-db-constituents file-id)) d@88: #.(clsql:restore-sql-reader-syntax-state) d@88: composition)) j@280: d@88: (defmethod get-geerdes-composition ((identifier geerdes-identifier-file-id)) d@88: #.(clsql:locally-enable-sql-reader-syntax) d@88: (let* ((file-id (file-id identifier)) d@88: (file-info (car (clsql:select [cat_id] [timebase] d@88: :from [midi_file] d@88: :where [= [id] file-id] d@88: :flatp t j@280: :result-types :auto j@280: :database *amuse-database*))) d@88: (timebase (second file-info)) d@88: (cat-id (first file-info)) d@88: (composition (make-instance 'geerdes-composition j@281: :identifier identifier d@88: :cat-id cat-id d@88: :file-id file-id d@88: :midi-timebase timebase))) d@88: (setf (%midi-events composition) (get-db-events file-id) d@88: (%midi-constituents composition) (get-db-constituents file-id)) d@88: #.(clsql:restore-sql-reader-syntax-state) d@88: composition)) d@88: d@88: (defun get-db-events (file-id) d@88: (clsql:query d@88: (concatenate 'string " d@133: SELECT track, channel, start, duration, patch, pitch, velocity, id, event_id, mel_duration d@88: FROM midi_event LEFT JOIN derived_midi_monody ON (id=event_id) d@88: WHERE file_id=" (princ-to-string file-id) j@280: " ORDER BY start") j@280: :database *amuse-database*)) j@280: d@88: (defun get-db-constituents (file-id) d@88: (clsql:query (concatenate 'string " d@88: SELECT track, channel, start, duration, d@88: param.num, param.value, pb.value, tp.value, ts.num, ts.denom d@88: FROM midi_constituent c d@88: LEFT JOIN midi_pb pb ON (id=pb.constituent_id) d@88: LEFT JOIN midi_tempo tp ON (id=tp.constituent_id) d@88: LEFT JOIN midi_timesig ts ON (id=ts.constituent_id) d@88: LEFT JOIN midi_param param ON (id=param.constituent_id) d@88: WHERE c.file_id=" (princ-to-string file-id) j@280: " ORDER BY start") j@280: :database *amuse-database*)) d@101: d@101: (defmethod monody ((composition geerdes-composition)) d@101: (unless (amuse-geerdes::%monody composition) d@101: (setf (amuse-geerdes::%monody composition) d@101: (get-monody composition))) d@101: (amuse-geerdes::%monody composition)) d@101: d@101: (defgeneric get-monody (composition)) d@101: (defmethod get-monody ((composition geerdes-composition)) d@101: ;;; FIXME: FIXED-[THIS IS DANGEROUS - IT EDITS NOTE LENGTH] d@101: ;; FIXME: As a result of this fix, notes no longer eq their monody d@101: ;; versions d@101: ;;; FIXME: This is a serious issue. Needs to be addressed by d@101: ;; a proper implementation of constituent with annotations d@101: ;;; From DTM: - Select notes d@101: ;; on channel 4 d@101: (let ((vocal-line (loop for event being the elements of (lead-vocal-part composition) d@101: collect (copy-event event)))) d@101: (when vocal-line d@101: (let* ((comp (make-instance 'geerdes-composition d@101: :file-id (file-id composition) d@101: :time (timepoint composition) d@101: :tempi (tempi composition) d@101: :time-signatures (time-signatures composition) d@101: :interval (duration composition))) d@101: (vocal-composition (sequence:adjust-sequence comp d@101: (length vocal-line) d@101: :initial-contents vocal-line)) d@101: (monody (make-instance 'geerdes-monody d@101: :time (timepoint composition) d@101: :file-id (file-id composition) d@101: :tempi (tempi composition) d@101: :time-signatures (time-signatures composition) d@101: :interval (duration composition))) ;; Overly inclusive? d@101: (monody-events (monodificate vocal-composition))) d@101: (sequence:adjust-sequence monody (length monody-events) d@101: :initial-contents monody-events))))) d@101: d@101: (defgeneric lead-vocal-part (time-ordered-constituent) d@101: (:method (toc) (remove-if-not #'lead-vocalp toc))) d@101: d@101: (defgeneric lead-vocalp (event) d@101: (:method (e) (declare (ignore e)) nil)) m@103: (defmethod lead-vocalp ((event geerdes-pitched-event)) d@101: (= (midi-channel event) 4)) d@114: d@130: (defmethod crotchet ((object geerdes-object)) d@139: (make-standard-period 1))