view implementations/geerdes/methods.lisp @ 88:8ea75cc8bc2c

Basic geerdes functionality moved to implementations/geerdes from separate package

darcs-hash:20070720161242-f76cc-fd256cbbb81d8c418a6c7c45844264184c5ed932.gz

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

;;; Compositions

;; identifiers
(defun g-id (cat-id)
  (make-instance 'geerdes-identifier-cat-id :cat-id cat-id))
(defun g-id-file-id (file-id)
  (make-instance 'geerdes-identifier-file-id :file-id file-id))

(defgeneric cat-id (object))
(defgeneric file-id (object))
(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
    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")))