changeset 286:d22c67dac97d

add minimal backend for Dave Meredith's data

Ignore-this: 91608f727967a4c5709bd41634ab9ae2

darcs-hash:20090524193956-16a00-038e6f7cb235dea4e7efcc70c4d1a7bc7fd402a6.gz

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/amuse-meredith.asd	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,21 @@
+;;;; -*- Mode: Lisp -*-
+
+(asdf:defsystem amuse-meredith
+  :name "amuse-meredith"
+  :description ""
+  :depends-on ("amuse-database-admin" "amuse" "split-sequence")
+  :components
+  ((:module implementations
+	    :components
+	    ((:module meredith
+		      :components
+		      ((:file "classes" :depends-on ("package"))
+		       (:file "constructors" :depends-on ("package"
+							  "classes"))
+		       (:file "database-setup" :depends-on ("package"))
+		       (:file "import->db" :depends-on ("package"))
+		       (:file "methods" :depends-on ("package"
+						     "classes"
+						     "constructors"))
+		       (:file "package")))
+	     ))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/classes.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,49 @@
+(cl:in-package #:amuse-meredith)
+
+;;; Top-level class
+
+(defclass meredith-data-object (amuse:amuse-object) ())
+
+;;; Identifiers
+
+(defclass meredith-identifier (meredith-data-object) ())
+
+(defclass meredith-composition-identifier (composition-identifier
+					   meredith-identifier)
+  ((composition-id
+   :initarg :composition-id
+   :reader composition-id)))
+
+(defclass meredith-event-identifier (event-identifier
+				     meredith-identifier)
+  ((event-id :initarg :event-id
+	     :reader event-id)))
+
+;;; Music objects
+
+(defclass meredith-music-object (meredith-data-object) ())
+
+(defclass meredith-composition (amuse:standard-composition
+				meredith-music-object)
+  ((identifier :initarg :identifier :reader identifier)
+   (description :initarg :description :reader description)))
+
+(defclass meredith-event (amuse:chromatic-pitched-event
+			  amuse:diatonic-pitched-event
+			  amuse:standard-anchored-period
+			  meredith-music-object)
+  ((identifier :initarg :identifier :accessor identifier)
+   (tatum-on :initarg :tatum-on :accessor tatum-on)
+   (tatum-dur :initarg :tatum-dur :accessor tatum-dur)
+   (tactus-on :initarg :tactus-on :accessor tactus-on)
+   (tactus-dur :initarg :tactus-dur :accessor tactus-dur)
+   (tatum-on-ms :initarg :tatum-on-ms :accessor tatum-on-ms)
+   (tatum-dur-ms :initarg :tatum-dur-ms :accessor tatum-dur-ms)
+   (beat-on-ms :initarg :beat-on-ms :accessor beat-on-ms)
+   (beat-dur-ms :initarg :beat-dur-ms :accessor beat-dur-ms)
+   (crot-on-ms :initarg :crot-on-ms :accessor crot-on-ms)
+   (crot-dur-ms :initarg :crot-dur-ms :accessor crot-dur-ms)
+   (pitch-name :initarg :pitch-name :accessor pitch-name)
+   (voice :initarg :voice :accessor voice)))
+
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/constructors.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,43 @@
+(cl:in-package #:amuse-meredith)
+
+(defun make-meredith-composition-identifier (composition-id)
+  (make-instance 'meredith-composition-identifier
+		 :composition-id composition-id))
+
+(defun make-meredith-composition (&key events time interval
+				  identifier description)
+  (make-instance 'meredith-composition
+		 :%data events
+		 :time time
+		 :interval interval
+		 :identifier identifier
+		 :description description))
+
+(defun make-meredith-event (&rest args)
+  (apply #'make-instance 'meredith-event args))
+
+(defun db-event->meredith-event (db-event)
+  (destructuring-bind (event-id tatum-on tatum-dur tactus-on
+				tactus-dur crot-on crot-dur
+				tatum-on-ms tatum-dur-ms beat-on-ms
+				beat-dur-ms crot-on-ms crot-dur-ms
+				pitch-name midi-note-number cpitch
+				mpitch voice) db-event
+    (make-meredith-event :identifier event-id
+			 :tatum-on tatum-on
+			 :tatum-dur tatum-dur
+			 :tactus-on tactus-on
+			 :tactus-dur tactus-dur
+			 :time crot-on	; define crotchet as standard time
+			 :interval crot-dur
+			 :tatum-on-ms tatum-on-ms
+			 :tatum-dur-ms tatum-dur-ms
+			 :beat-on-ms beat-on-ms
+			 :beat-dur-ms beat-dur-ms
+			 :crot-on-ms crot-on-ms
+			 :crot-dur-ms crot-dur-ms
+			 :pitch-name pitch-name
+			 :number midi-note-number
+			 :cp cpitch
+			 :mp mpitch
+			 :voice voice)))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/database-setup.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,61 @@
+(cl:in-package #:amuse-meredith)
+
+(defun create-meredith-tables (database)
+  (%create-compositions-table database)
+  (%create-events-table database))
+
+(defun drop-meredith-tables (database)
+  (%drop-compositions-table database)
+  (%drop-events-table database))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Helper functions
+
+(defun %create-compositions-table (database)
+  #.(clsql:locally-enable-sql-reader-syntax)
+  (clsql:create-table "meredith_compositions"
+		      '(([|composition-id|] clsql:smallint :unsigned
+			 :not-null :auto-increment :primary-key)
+			([|description|] (clsql:varchar 255)
+			 :not-null))
+		      :database database
+		      :transactions t)
+  #.(clsql:locally-disable-sql-reader-syntax))
+
+(defun %create-events-table (database)
+  #.(clsql:locally-enable-sql-reader-syntax)
+  (clsql:create-table "meredith_events"
+		'(([|composition-id|] clsql:smallint :unsigned
+		   :not-null)
+		  ([|event-id|] clsql:smallint :unsigned
+		   :not-null :auto-increment :unique)
+		  ([|tatum-on|] clsql:smallint :unsigned :not-null)
+		  ([|pitch-name|] (clsql:varchar 32) :not-null)
+		  ([|tatum-dur|] clsql:smallint :unsigned :not-null)
+		  ([|voice|] clsql:smallint :unsigned :not-null)
+		  ([|tactus-on|] clsql::float :unsigned :not-null)
+		  ([|tactus-dur|] clsql::float :unsigned :not-null)
+		  ([|crot-on|] clsql::float :unsigned :not-null)
+		  ([|crot-dur|] clsql::float :unsigned :not-null)
+		  ([|midi-note-number|] clsql:smallint :unsigned :not-null)
+		  ([|chrom-pitch|] clsql:smallint :unsigned :not-null)
+		  ([|morph-pitch|] clsql:smallint :unsigned :not-null)
+		  ([|tatum-on-ms|] clsql:smallint :unsigned :not-null)
+		  ([|tatum-dur-ms|] clsql:smallint :unsigned :not-null)
+		  ([|beat-on-ms|] clsql:smallint :unsigned :not-null)
+		  ([|beat-dur-ms|] clsql:smallint :unsigned :not-null)
+		  ([|crot-on-ms|] clsql:smallint :unsigned :not-null)
+		  ([|crot-dur-ms|] clsql:smallint :unsigned :not-null))
+		:constraints '("PRIMARY KEY (composition_id, event_id)")
+		:database database
+		:transactions t)
+  #.(clsql:locally-disable-sql-reader-syntax))
+
+(defun %drop-compositions-table (database)
+  (clsql:drop-table "meredith_compositions"
+		    :database database))
+
+(defun %drop-events-table (database)
+  (clsql:drop-table "meredith_events"
+		    :database database))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/import->db.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,125 @@
+(cl:in-package #:amuse-meredith)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Importing
+
+(defun make-path (base-path file-prefix file-id file-suffix)
+  (pathname (concatenate 'string
+			 base-path
+			 file-prefix
+			 (princ-to-string file-id)
+			 file-suffix)))
+
+(defun file->list-of-lists (path)
+  (with-open-file (stream path)
+     (loop
+	for row-strings = (split-sequence:split-sequence
+			   #\space (read-line stream nil)
+			   :remove-empty-subseqs t)
+	while row-strings
+	collect (loop
+		   for value in row-strings
+		   collect (read-from-string value)
+		   into row-objects
+		   finally (return row-objects))
+	into results
+	finally (return (cdr results)))))
+
+(defvar *import-file* (pathname "/tmp/raph-c.txt"))
+
+(defun write-to-db-file (composition-id datapoints)
+  (with-open-file (stream *import-file*
+			  :direction :output
+			  :if-exists :supersede
+			  :external-format :latin1)
+    (sequence:dosequence (datapoint datapoints)
+      (format stream
+	      "~S	\\N	~{~S	~}~%"
+	      composition-id datapoint)))
+  t)
+
+(defun import-meredith-composition (event-lists &key description
+				    database)
+  "Import a composition into the database. A composition is a list of
+lists (dataset in the SIA sense), where each internal list (datapoint)
+represents an event. All datapoints are the same cardinality. The
+description is a string of up to 255 characters."
+  #.(clsql:locally-enable-sql-reader-syntax)
+  (clsql:with-transaction
+      (:database database)
+    (let (composition-id)
+      (clsql:insert-records :into "meredith_compositions"
+			    :attributes '([description])
+			    :values (list description)
+			    :database database)
+      #.(clsql:locally-disable-sql-reader-syntax)
+      (setf composition-id (clsql-mysql::mysql-insert-id
+			    (clsql-mysql::database-mysql-ptr
+			     database)))
+      (write-to-db-file composition-id event-lists)
+      (clsql:execute-command
+       (concatenate 'string
+		    "LOAD DATA LOCAL INFILE '"
+		    (namestring *import-file*)
+		    "' INTO TABLE "
+		    "meredith_events")
+       :database database)
+      (delete-file *import-file*)
+      (format t "composition added to db, id: ~A~%" composition-id)
+      (make-meredith-composition-identifier composition-id))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Import functions for specific datasets.
+
+(defun import-bach-inv+sin (&optional (database *amuse-database*))
+  "Imports all of Dave's encodings of Bach's Inventions and Sinfonias,
+and assigns them all so a unique dataset."
+  (clsql:with-transaction
+      (:database database)
+    (let ((dataset-identifier (make-new-dataset
+				  "Bach Inventions and Sinfonias"
+				  database)))
+      (import-bach-inventions database dataset-identifier)
+      (import-bach-sinfonias database dataset-identifier))))
+
+(defun import-bach-inventions (database &optional dataset-identifier)
+  "Imports all of Dave's encodings of Bach's Inventions."
+  (let ((base-path "/home/jamie/Music/meredith-data/20060301raph-c/")
+	(file-prefix "bachrasmussinventio0")
+	(file-suffix "01.raph-c"))
+    (loop for file-id from 772 to 786
+       for composition-order from 1
+       for composition-identifier =
+	 (import-meredith-composition
+	  (file->list-of-lists
+	   (make-path base-path file-prefix file-id file-suffix))
+	  :description (concatenate 'string
+				    "Bach Invention No."
+				    (princ-to-string composition-order)
+				    " BWV "
+				    (princ-to-string file-id))
+	  :database database)
+       do (when dataset-identifier
+	    (assign-composition-to-dataset
+	     composition-identifier dataset-identifier database)))))
+
+(defun import-bach-sinfonias (database &optional dataset-identifier)
+  "Imports all of Dave's encodings of Bach's Sinfonias."
+  (let ((base-path "/home/jamie/Music/meredith-data/20060301raph-c/")
+	(file-prefix "bachrasmusssinfonie0")
+	(file-suffix "01.raph-c"))
+    (loop for file-id from 787 to 801
+       for composition-order from 1
+       for composition-identifier =
+	 (import-meredith-composition
+	  (file->list-of-lists
+	   (make-path base-path file-prefix file-id file-suffix))
+	  :description (concatenate 'string
+				    "Bach Sinfonia No."
+				    (princ-to-string composition-order)
+				    " BWV "
+				    (princ-to-string file-id))
+	  :database database)
+       do (when dataset-identifier
+	    (assign-composition-to-dataset
+	     composition-identifier dataset-identifier database)))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/methods.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,94 @@
+(cl:in-package #:amuse-meredith)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Specialised constructors
+(defmethod make-composition-identifier ((package (eql *package*))
+				       composition-id)
+  (make-meredith-composition-identifier composition-id))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compositions
+
+(defvar *event-attributes*
+  #.(clsql:locally-enable-sql-reader-syntax)
+  (list [event-id] [tatum-on] [tatum-dur] [tactus-on] [tactus-dur]
+	[crot-on] [crot-dur] [tatum-on-ms] [tatum-dur-ms] [beat-on-ms]
+	[beat-dur-ms] [crot-on-ms] [crot-dur-ms] [pitch-name]
+	[midi-note-number] [chrom-pitch] [morph-pitch] [voice])
+  #.(clsql:locally-disable-sql-reader-syntax))
+
+(defmethod get-composition ((identifier meredith-composition-identifier))
+  #.(clsql:locally-enable-sql-reader-syntax)
+  (let* ((composition-id (composition-id identifier))
+	 (where-clause [= [composition-id] composition-id])
+	 (description
+	  (car (clsql:select [description] :from [|meredith-compositions|]
+			     :where where-clause :flatp t :field-names nil)))
+	 (db-events (apply #'clsql:select
+                           (append *event-attributes*
+                                   (list :from [|meredith-events|]
+                                         :order-by '(([event-id] :asc))
+                                         :where where-clause))))
+         (events nil))
+    (dolist (e db-events)
+      (push (db-event->meredith-event e) events))
+    (let* ((composition
+	    (make-meredith-composition :identifier identifier
+				       :description description)))
+      (sequence:adjust-sequence composition (length events)
+ 				:initial-contents (nreverse events))
+      composition))
+  #.(clsql:locally-disable-sql-reader-syntax))
+
+(defmethod copy-event (event)
+  (with-slots (identifier tatum-on tatum-dur tactus-on tactus-dur
+			  (time amuse::time)
+			  (interval amuse::interval) tatum-on-ms
+			  tatum-dur-ms beat-on-ms beat-dur-ms
+			  crot-on-ms crot-dur-ms pitch-name
+			  (midi-note-number amuse::number)
+			  (cp amuse::cp) (mp amuse::mp) voice) event
+    (make-meredith-event :identifier identifier
+			 :tatum-on tatum-on
+			 :tatum-dur tatum-dur
+			 :tactus-on tactus-on
+			 :tactus-dur tactus-dur
+			 :time time
+			 :interval interval
+			 :tatum-on-ms tatum-on-ms
+			 :tatum-dur-ms tatum-dur-ms
+			 :beat-on-ms beat-on-ms
+			 :beat-dur-ms beat-dur-ms
+			 :crot-on-ms crot-on-ms
+			 :crot-dur-ms crot-dur-ms
+			 :pitch-name pitch-name
+			 :number midi-note-number
+			 :cp cp
+			 :mp mp
+			 :voice voice)))
+
+(defmethod get-applicable-key-signatures ((event meredith-event)
+					  (composition
+					   meredith-composition))
+  nil)
+
+(defmethod get-applicable-key-signatures ((event meredith-composition)
+					  o)
+  nil)
+
+(defmethod get-applicable-time-signatures ((event meredith-event)
+					   (composition
+					    meredith-composition))
+    (make-standard-time-signature-period 4 4 0 (duration composition)))
+
+(defmethod time-signatures ((composition meredith-composition))
+  (list (make-standard-time-signature-period 4 4 0 (duration composition))))
+
+(defmethod crotchet ((event meredith-composition))
+  (amuse:make-standard-period 1))
+
+(defmethod crotchet ((event meredith-event))
+  (amuse:make-standard-period 1))
+
+(defmethod tempi ((composition meredith-composition))
+  (list (make-standard-tempo-period 120 0 88)))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/package.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,4 @@
+(cl:defpackage #:amuse-meredith
+  (:use #:cl #:amuse #:amuse-database-admin))
+
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/meredith/tests/import-raph-c-data.lisp	Sun May 24 20:39:56 2009 +0100
@@ -0,0 +1,28 @@
+(cl:in-package #:amuse-meredith)
+
+(asdf:oos 'asdf:load-op 'amuse-meredith)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tell the database about the new implementation.
+(amuse-database-admin:register-new-implementation *package*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Add the datasets to the database
+(connect-to-database :database-name "test")
+
+(create-meredith-tables *amuse-database*)
+
+(import-bach-inv+sin *amuse-database*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Retrieve compositions
+(defparameter *bach*
+  (get-composition (make-meredith-composition-identifier 1)))
+
+(defparameter *bach-dataset*
+  (get-dataset (make-amuse-dataset-identifier 1)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tidy up
+;;(drop-meredith-tables *amuse-database*)
+(disconnect-from-database)