view implementations/meredith/methods.lisp @ 286:d22c67dac97d

add minimal backend for Dave Meredith's data

Ignore-this: 91608f727967a4c5709bd41634ab9ae2

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

(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)))