annotate implementations/geerdes/methods.lisp @ 192:54d79a2c82d2

fix make-chromatic-pitched-event constructor

Ignore-this: 93298c4a64a4a65dc948f8473c92a9c8

darcs-hash:20090524152250-16a00-295d43f8c2d16089196ab223b43264ae55f5620b.gz

(cl:in-package #:amuse-geerdes)

;;; Compositions

;; identifiers
(defun g-id (cat-id)
  "Make a geerdes-identifier based on a catalogue id"
  (make-instance 'geerdes-identifier-cat-id :cat-id cat-id))
(defun g-id-file-id (file-id)
  "Make a geerdes-identifier based on a catalogue id"
  (make-instance 'geerdes-identifier-file-id :file-id file-id))

(defgeneric cat-id (object)
  (:documentation "Return a database catalogue id for object (for
  Geerdes data, this is the company's own ID"))
(defgeneric file-id (object)
  (:documentation "Return a database file id for object (for
  Geerdes data, this is a unique integer identifier)"))
(defgeneric (setf cat-id) (value object))
(defgeneric (setf file-id) (value object))

(defmethod cat-id ((object geerdes-composition))
  (%db-cat-id object))
(defmethod cat-id ((object geerdes-identifier-cat-id))
  (slot-value object 'cat-id))
(defmethod file-id ((object geerdes-composition))
  (%db-file-id object))
(defmethod file-id ((object geerdes-identifier-file-id))
  (slot-value object 'file-id))
(defmethod (setf cat-id) (value (object geerdes-composition))
  (setf (%db-cat-id object) value))
(defmethod (setf cat-id) (value (object geerdes-identifier-cat-id))
  (setf (slot-value object 'cat-id) value))
(defmethod (setf file-id) (value (object geerdes-composition))
  (setf (%db-file-id object) value))
(defmethod (setf file-id) (value (object geerdes-identifier-file-id))
  (setf (slot-value object 'file-id) value))

;; Composition 

(defmethod get-composition ((identifier geerdes-identifier))
  (let* ((composition (get-geerdes-composition identifier)))
    (%initialise-notes composition)
    (%initialise-constituents composition)))

(defgeneric get-geerdes-composition (identifier))
(defmethod get-geerdes-composition ((identifier geerdes-identifier-cat-id))
  #.(clsql:locally-enable-sql-reader-syntax)
  (let* ((cat-id (cat-id identifier))
	 (file-info (car (clsql:select [id] [timebase]
				       :from [midi_file]
				       :where [= [cat_id] cat-id]
				       :flatp t
				       :result-types :auto)))
	 (timebase (second file-info))
	 (file-id (first file-info))
	 (composition (make-instance 'geerdes-composition
				     :id identifier
				     :file-id file-id
				     :cat-id cat-id
				     :midi-timebase timebase)))
    (setf (%midi-events composition) (get-db-events file-id)
	  (%midi-constituents composition) (get-db-constituents file-id))
  #.(clsql:restore-sql-reader-syntax-state)
  composition))
(defmethod get-geerdes-composition ((identifier geerdes-identifier-file-id))
  #.(clsql:locally-enable-sql-reader-syntax)
  (let* ((file-id (file-id identifier))
	 (file-info (car (clsql:select [cat_id] [timebase]
				       :from [midi_file]
				       :where [= [id] file-id]
				       :flatp t
				       :result-types :auto)))
	 (timebase (second file-info))
	 (cat-id (first file-info))
	 (composition (make-instance 'geerdes-composition
				     :id identifier
				     :cat-id cat-id
				     :file-id file-id
				     :midi-timebase timebase)))
    (setf (%midi-events composition) (get-db-events file-id)	  
	  (%midi-constituents composition) (get-db-constituents file-id))
    #.(clsql:restore-sql-reader-syntax-state)
    composition))

(defun get-db-events (file-id)
  (clsql:query
   (concatenate 'string "
    SELECT track, channel, start, duration, patch, pitch, velocity, id, event_id, mel_duration
    FROM midi_event LEFT JOIN derived_midi_monody ON (id=event_id)
    WHERE file_id=" (princ-to-string file-id)
    " ORDER BY start")))
(defun get-db-constituents (file-id)
  (clsql:query (concatenate 'string "
    SELECT track, channel, start, duration,
      param.num, param.value, pb.value, tp.value, ts.num, ts.denom
    FROM midi_constituent c
      LEFT JOIN midi_pb pb ON (id=pb.constituent_id)
      LEFT JOIN midi_tempo tp ON (id=tp.constituent_id)
      LEFT JOIN midi_timesig ts ON (id=ts.constituent_id)
      LEFT JOIN midi_param param ON (id=param.constituent_id)
    WHERE c.file_id=" (princ-to-string file-id)
    " ORDER BY start")))

(defmethod monody ((composition geerdes-composition))
  (unless (amuse-geerdes::%monody composition)
    (setf (amuse-geerdes::%monody composition)
	  (get-monody composition)))
  (amuse-geerdes::%monody composition))

(defgeneric get-monody (composition))
(defmethod get-monody ((composition geerdes-composition))
  ;;; FIXME: FIXED-[THIS IS DANGEROUS - IT EDITS NOTE LENGTH]
  ;; FIXME: As a result of this fix, notes no longer eq their monody
  ;; versions
  ;;; FIXME: This is a serious issue. Needs to be addressed by
  ;; a proper implementation of constituent with annotations
  ;;; From DTM: - Select notes
  ;; on channel 4
  (let ((vocal-line (loop for event being the elements of (lead-vocal-part composition)
		       collect (copy-event event))))
    (when vocal-line
      (let* ((comp (make-instance 'geerdes-composition
				  :file-id (file-id composition)
				  :time (timepoint composition)
				  :tempi (tempi composition)
				  :time-signatures (time-signatures composition)
				  :interval (duration composition)))
	     (vocal-composition (sequence:adjust-sequence comp
							  (length vocal-line)
							  :initial-contents vocal-line))
	     (monody (make-instance 'geerdes-monody
				    :time (timepoint composition)
				    :file-id (file-id composition)
				    :tempi (tempi composition)
				    :time-signatures (time-signatures composition)
				    :interval (duration composition))) ;; Overly inclusive?
	     (monody-events (monodificate vocal-composition)))
	(sequence:adjust-sequence monody (length monody-events)
				  :initial-contents monody-events)))))

(defgeneric lead-vocal-part (time-ordered-constituent)
  (:method (toc) (remove-if-not #'lead-vocalp toc)))

(defgeneric lead-vocalp (event)
  (:method (e) (declare (ignore e)) nil))
(defmethod lead-vocalp ((event geerdes-pitched-event))
  (= (midi-channel event) 4))

(defmethod crotchet ((object geerdes-object))
  (make-standard-period 1))