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

Basic geerdes functionality moved to implementations/geerdes from separate package

darcs-hash:20070720161242-f76cc-fd256cbbb81d8c418a6c7c45844264184c5ed932.gz

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/geerdes/methods.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,97 @@
+(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")))
\ No newline at end of file