annotate implementations/geerdes/constructors.lisp @ 279:c591a5034da6

New base module for general database functions

Ignore-this: 403f22ca6285cba4a23eeddb1d0a806f

Currently just provides a slightly more secure way of connecting to a database.

darcs-hash:20090519135617-16a00-ce026a38abfb53e5728cd0cbb6c976e403691dde.gz

(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)
	  (let ((monody-note (copy-event note)))
	     (setf (duration monody-note) (%fast-monody-duration row timebase))
	     (push monody-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-standard-tempo-period
		(microsecond-per-crotchet-to-bpm
		 (%fast-tempo row))
		(%fast-onset row timebase)
		(%fast-duration row timebase))
	       tempi))
	((%fast-numerator row)
	 (push (make-standard-time-signature-period
		(%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-monody-duration (event-row timebase)
  (/ (tenth event-row) timebase))

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

(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:
#+nil
(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))