view implementations/tabcode/methods.lisp @ 179:88089258e08d

initial tabcode work

darcs-hash:20080708152042-40ec0-f6bf9befa5dc8d6eaf51dd1cbff68c78a09de896.gz

(in-package "AMUSE-TABCODE")

(defmethod tempi ((composition tabcode-composition))
  ())
(defmethod time-signatures ((composition tabcode-composition))
  ())

(defmethod get-applicable-key-signatures (object (composition tabcode-composition))
 ())

(defmethod crotchet ((object tabcode-object))
  (make-standard-period 1))

(defmethod current-bar ((moment standard-moment) (composition tabcode-composition))
  (find-if #'(lambda (x) (and (time< moment (cut-off x))
			      (time>= moment (onset x))))
	   (tabcode-bars composition)))

(defmethod current-beat ((moment standard-moment) (composition tabcode-composition))
  ;; clearly broken, but can unbreak unusual cases as they arise (?!)
  (let ((bar (current-bar moment composition))
	(metre (find-if #'(lambda (x) (and (time< moment (cut-off x))
					   (time>= moment (onset x))))
			(metrical-signs composition))))
    (unless (and bar metre)
      (error 'insufficient-information
	     :operation 'beat-period
	     :datatype (class-of composition)))
    (let ((beats-in-bar) (beat-duration))
      (cond
	((ur metre)
	 ;; we have a weird compound signature, goodness knows what to
	 ;; do. This probably means that one of them is a proportion
	 ;; sign.
	 (error 'insufficient-information
		:operation 'beat-period
		:datatype (class-of composition)))
	((and (ll metre)
	      (numberp (ll metre)) ;; we have a `standard
	      (numberp (ul metre)));; time sig'
	 (setf beats-in-bar (ul metre)
	       beat-duration (/ 4 (ll metre)))
	 (when (and (> beats-in-bar 3)
		    (= (rem beats-in-bar 3) 0))
	   (setf beats-in-bar (/ beats-in-bar 3)
		 beat-duration (* beat-duration 3))))
	((and (null (ll metre))
	      (numberp (ul metre)))
	 (setf beats-in-bar (ul metre))
	 (do ((proportion 4 (/ proportion 2)))
	     ((= (rem (/ (duration bar) proportion)
		      beats-in-bar) 0)
	      (setf beat-duration proportion))))
	((null (ll metre))
	 (cond
	   ((string= (ul metre) "C")
	    (setf beats-in-bar 4)
	    (setf beat-duration 1))
	   ((string= (ul metre) "C/")
	    (setf beats-in-bar 2)
	    (setf beat-duration 2)))))
      (unless (= (rem (duration bar)
		      (* beat-duration beats-in-bar))
		 0)
	(error "Bar length doesn't match metrical symbol, I think"))
      (let ((beat-period (make-standard-anchored-period
			  (timepoint bar) beat-duration)))
	(do ()
	    ((time> (cut-off beat-period) moment) beat-period)
	  (setf (timepoint beat-period)
		(timepoint (cut-off beat-period))))))))