changeset 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/amuse-geerdes.asd	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,13 @@
+(asdf:defsystem amuse-geerdes
+  :name "amuse-geerdes"
+  :depends-on ("amuse" "clsql")
+  :components
+  ((:module implementations
+            :components 
+            ((:module geerdes
+                      :components 
+		      ((:file "package")
+                       (:file "connect" :depends-on ("package"))
+	               (:file "classes" :depends-on ("package"))
+	               (:file "constructors" :depends-on ("package" "classes"))
+	               (:file "methods" :depends-on ("package" "classes" "constructors"))))))))
\ No newline at end of file

--- a/base/classes.lisp	Wed Jul 18 16:12:58 2007 +0100
+++ b/base/classes.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -37,7 +37,7 @@
 (defclass pitch (pitch-designator) ())
 (defclass chromatic-pitch (pitch) 
   ((number :accessor %chromatic-pitch-number :initarg :number)))
-(defclass diatonic-pitch (pitch) 
+(defclass diatonic-pitch (pitch)
   ((name :accessor %diatonic-pitch-name :initarg :name)
    (accidental :accessor %diatonic-pitch-accidental :initarg :accidental)
    (octave :accessor %diatonic-pitch-octave :initarg :octave))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/geerdes/classes.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,52 @@
+(cl:in-package #:amuse-geerdes)
+
+(defclass property-list-mixin ()
+  ((properties :initarg :properties :accessor properties :initform nil)))
+
+(defclass geerdes-identifier (identifier) ())
+(defclass geerdes-identifier-cat-id (geerdes-identifier)
+  ((cat-id :initarg :cat-id
+	   :initform 'nil)))
+(defclass geerdes-identifier-file-id (geerdes-identifier)
+  ((file-id :initarg :file-id
+	    :initform 'nil)))
+
+(defclass geerdes-composition (midi-composition property-list-mixin)
+  ((db-entry :initarg :db-entry
+	     :initform nil
+	     :accessor %db-entry)
+   (bar-numbers :initform nil
+		:accessor %bar-numbers)
+   (monody :initform nil
+	   :accessor %monody)
+   (caches :initform nil
+	   :accessor %caches)
+   (midi-constituents :initarg :constituents
+		      :accessor %midi-constituents)
+   (midi-events :initarg :midi-events
+		:accessor %midi-events)
+   (midi-timebase :initarg :midi-timebase
+		  :accessor %midi-timebase)
+   (identifier :initarg :id
+	       :accessor %fast-identifier)
+   (db-cat-id :initarg :cat-id
+	      :accessor %db-cat-id)
+   (db-file-id :initarg :file-id
+	       :accessor %db-file-id)))
+
+(defclass geerdes-monody (monody geerdes-composition)
+  ;; FIXME: necessary slots? Do we even use them?
+  ((inter-onset-intervals :initarg :i-o-i
+			  :initform nil
+			  :accessor %i-o-i)
+   (inter-onset-interval-mode :initarg :ioi-mode
+			      :initform 0
+			      :accessor %ioi-mode)))
+
+(defclass geerdes-pitched-event (midi-pitched-event property-list-mixin)
+  ((id :initarg :id
+       :accessor %geerdes-pitched-event-id)))
+
+(defclass geerdes-percussive-event (midi-percussive-event property-list-mixin)
+  ((id :initarg :id
+       :accessor %geerdes-percussive-event-id)))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/geerdes/connect.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,11 @@
+(in-package #:amuse-geerdes)
+
+;; N.B. This file contains an access password for the database in
+;; plain text...
+
+(defun get-amuse-connection ()
+  (clsql:connect '("vaughan-williams.doc.gold.ac.uk" "amuse" "LispMidi" "clsql")
+		 :if-exists :old :database-type :mysql))
+
+;; might as well connect while I'm at it 
+(get-amuse-connection)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/geerdes/constructors.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,178 @@
+(cl:in-package #:amuse-geerdes)
+
+(defgeneric %initialise-notes (composition))
+(defmethod %initialise-notes ((composition geerdes-composition))
+  (let ((notes) (l 0) (last-time 0) (monody-notes)
+	(monody (make-instance 'geerdes-monody :file-id (file-id composition)))
+	(timebase (%midi-timebase composition)))
+    (dolist (row (%midi-events composition))
+      (let* ((note (if (pitched-row-p row)
+		      (make-geerdes-pitched-event (%fast-pitch row)
+						  (%fast-velocity row)
+						  (%fast-patch row)
+						  (%fast-channel row)
+						  (%fast-track row)
+						  (%fast-onset row timebase)
+						  (%fast-duration row timebase)
+						  (%fast-id row))
+		      (make-geerdes-percussive-event (%fast-pitch row)
+						     (%fast-velocity row)
+						     (%fast-patch row)
+						     (%fast-channel row)
+						     (%fast-track row)
+						     (%fast-onset row timebase)
+						     (%fast-duration row timebase)
+						     (%fast-id row)))))
+	(when (%fast-monodyp row)
+	  (push note monody-notes))
+	(when (> (timepoint (cut-off note)) last-time)
+	  (setf last-time (timepoint (cut-off note))))
+	(push note notes)
+	(incf l)))
+    (sequence:adjust-sequence composition l :initial-contents (reverse notes))
+    (setf (duration composition) last-time
+	  (timepoint composition) 0)
+    (when monody-notes
+      (setf (%monody composition) (sequence:adjust-sequence monody (length monody-notes)
+							    :initial-contents (reverse monody-notes))
+	    (timepoint (%monody composition)) (timepoint (elt monody 0))
+	    (duration (%monody composition)) (- (timepoint (cut-off (car monody-notes)))
+						(timepoint (elt monody 0)))))
+    composition))
+
+(defgeneric %initialise-constituents (composition))
+(defmethod %initialise-constituents ((composition geerdes-composition))
+  ;; FIXME: Should the duration of composition be affected by this? On
+  ;; the one hand, it makes no difference to the musical content, but
+  ;; on the other, it seems illogical to reach outside the period.
+  (let ((timebase (%midi-timebase composition))
+	(time-sigs)
+	(tempi)
+	(mystery 0))
+    (dolist (row (%midi-constituents composition))
+      (cond
+	((%fast-tempo row)
+	 (push (make-tempo
+		(microsecond-per-crotchet-to-bpm
+		 (%fast-tempo row))
+		(%fast-onset row timebase)
+		(%fast-duration row timebase))
+	       tempi))
+	((%fast-numerator row)
+	 (push (make-basic-time-signature
+		(%fast-numerator row)
+		(%fast-denominator row)
+		(%fast-onset row timebase)
+		(%fast-duration row timebase))
+	       time-sigs))
+	(t (incf mystery))))
+    (setf (time-signatures composition) (reverse time-sigs)
+	  (tempi composition) (reverse tempi))
+    (when (%monody composition)
+      (setf (time-signatures (%monody composition)) (time-signatures composition)
+	    (tempi (%monody composition)) (tempi composition)))
+    (format t "There are ~D constituents not processed~%" mystery)
+    composition))
+
+(defun %fast-track (row)
+  (first row))
+(defun %fast-channel (row)
+  (second row))
+(defun %fast-onset (row timebase)
+  (/ (third row) timebase))
+(defun %fast-duration (row timebase)
+  (/ (fourth row) timebase))
+(defun %fast-patch (event-row)
+  (fifth event-row))
+(defun %fast-pitch (event-row)
+  (sixth event-row))
+(defun %fast-velocity (event-row)
+  (seventh event-row))
+(defun %fast-id (event-row)
+  (eighth event-row))
+(defun %fast-monodyp (event-row)
+  (ninth event-row))
+
+(defun %fast-tempo (tp-row)
+  (eighth tp-row))
+(defun %fast-numerator (ts-row)
+  (ninth ts-row))
+(defun %fast-denominator (ts-row)
+  (tenth ts-row))
+
+(defun pitched-row-p (event-row)
+  (and (not (= (%fast-channel event-row) 10))
+       (< (%fast-patch event-row) 112)))
+
+(defun make-geerdes-pitched-event (pitch-number velocity patch
+				channel track onset duration id)
+  (make-instance 'geerdes-pitched-event
+		 :number pitch-number
+		 :velocity velocity
+		 :patch patch
+		 :channel channel
+		 :track track
+		 :time onset
+		 :interval duration
+		 :id id))
+
+(defun make-geerdes-percussive-event (pitch-number velocity patch
+				   channel track onset duration id)
+  (make-instance 'geerdes-percussive-event
+		 :sound pitch-number
+		 :velocity velocity
+		 :patch patch
+		 :channel channel
+		 :track track
+		 :time onset
+		 :interval duration
+		 :id id))
+
+(defgeneric copy-event (event))
+(defmethod copy-event ((event geerdes-pitched-event))
+  (with-slots ((channel amuse-midi::channel)
+	       (track amuse-midi::track)
+	       (number amuse::number)
+	       (time amuse::time)
+	       (interval amuse::interval)
+	       (velocity amuse-midi::velocity)
+	       (patch amuse-midi::patch) id)
+      event
+    (make-instance 'geerdes-pitched-event
+		   :channel channel
+		   :track track
+		   :number number
+		   :time time
+		   :interval interval
+		   :velocity velocity
+		   :patch patch
+		   :id id)))
+(defmethod copy-event ((event geerdes-percussive-event)) 
+  (with-slots ((channel amuse-midi::channel)
+	       (track amuse-midi::track)
+	       (time amuse::time)
+	       (interval amuse::interval)
+	       (velocity amuse-midi::velocity)
+	       (patch amuse-midi::patch)
+	       (sound amuse-midi::sound) id)
+      event
+    (make-instance 'geerdes-percussive-event
+		   :channel channel 
+		   :track track
+		   :time time
+		   :interval interval
+		   :velocity velocity
+		   :patch patch
+		   :sound sound
+		   :id id)))
+
+;; We want any function that generates a sequence from a geerdes
+;; composition to preserve all slot values:
+(defmethod sequence:make-sequence-like :around ((o geerdes-composition)
+						length
+						&key (initial-element nil iep)
+						(initial-contents nil icp))
+  (declare (ignore iep icp length initial-element initial-contents))
+  (let ((result (call-next-method)))
+    (setf (%db-entry result) (%db-entry o))
+    result))

--- /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

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/geerdes/package.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -0,0 +1,16 @@
+(cl:defpackage #:amuse-geerdes
+  (:use #:common-lisp #:amuse #:amuse-utils #:amuse-midi #:amuse-segmentation)
+  (:export 
+   ;; classes
+   #:geerdes-composition
+   #:geerdes-monody
+   ;; identifier constructors
+   #:g-id
+   #:g-id-file-id
+   ;; database identification
+   #:cat-id
+   #:file-id
+   ;; other (caching)
+   #:properties)
+  (:documentation "Package for MIDI pop-song database, originating
+  from Geerdes, a commercial supplier."))
\ No newline at end of file

--- a/tools/segmentation/simple-example.lisp	Wed Jul 18 16:12:58 2007 +0100
+++ b/tools/segmentation/simple-example.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -71,4 +71,3 @@
                          modal-count value)))
              hits)
     (values i-o-i-list (* modal-value rounding-divisor) (and real-time i-o-i-secs-list))))
-		

--- a/utils/package.lisp	Wed Jul 18 16:12:58 2007 +0100
+++ b/utils/package.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -14,4 +14,6 @@
 	   #:get-n-gram
 	   #:n-gram-stats
 	   #:monodificate
+	   #:significantly-louderp
+	   #:substantially-louderp
 	   ))

--- a/utils/utils.lisp	Wed Jul 18 16:12:58 2007 +0100
+++ b/utils/utils.lisp	Fri Jul 20 17:12:42 2007 +0100
@@ -30,8 +30,8 @@
 		 (amuse:microseconds-per-crotchet tempo))))))
 (defmethod beats-to-seconds ((object1 moment)
 			     (object2 constituent))
-  (beats-to-seconds (make-anchored-period 0
-					  (timepoint object1))
+  (beats-to-seconds (time- (timepoint object1)
+			   (make-moment 0))
 		    object2))
 					  
 ;; Not as simple as it seems - have to take into account numbering