view implementations/tabcode/methods.lisp @ 226:64b795c2ff18

Fix bug in move-to-first-bar.

Ignore-this: 52a48e8771d159294e9ad51cbe04034d

darcs-hash:20090905200027-16a00-539b473b27ebd6b75282dac335cc8617403ed3ad.gz

committer: Jamie Forth <[e-mail]>

(in-package "AMUSE-TABCODE")

(defmethod tempi ((composition tabcode-composition))
  ())
(defmethod time-signatures ((composition tabcode-composition))
  (metrical-signs composition))
(defmethod amuse-tools:get-patch-for-midi ((event tabcode-object))
  24)
(defmethod amuse-tools:get-velocity-for-midi ((event tabcode-object))
  70)
(defmethod amuse-tools:default-tempo-for-midi ((tab-comp tabcode-composition))
  (make-standard-tempo-period 60 (timepoint tab-comp) (duration tab-comp)))
(defmethod get-applicable-key-signatures (object (composition tabcode-composition))
  (restart-case 
      (error 'insufficient-information
	     :operation 'beat-period
	     :datatype (class-of composition))
    (amuse:guess () (multiple-value-bind (x key)
			(amuse-harmony:krumhansl-key-finder composition composition)
		      (declare (ignore x))
		      (list key)))))

(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)))
    (restart-case
	(let ((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. Better errors would be a gould start.
	       (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))
		 (unless (>= proportion 1/4)
		   (setf beat-duration (round (/ (duration bar)
						 beats-in-bar)))
		   (return))))
	      ((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)))
	       ;; clearly wrong, but for the time being try this (better is
	       ;; work out for the whole piece
	       (do ((proportion 4 (/ proportion 2)))
		   ((= (rem (/ (duration bar) proportion)
			    beats-in-bar) 0)
		    (setf beat-duration proportion))
		 (unless (>= proportion 2)
		   (setf beat-duration 2)
		   (return)))))
	    (unless (= (rem (duration bar)
			    (* beat-duration beats-in-bar))
		       0)
	      (print "Bar length doesn't match metrical symbol, I think"))
	    (find-current-beat-with-bar-start-and-constant-beat
	     moment bar beat-duration)))
      (amuse:use-whole-bar () :report "Use whole bar" bar)
      (amuse:use-crotchet-beat () :report "Use crotchet as beat"
			 (find-current-beat-with-bar-start-and-constant-beat
			  moment bar 1))
      (use-value-for-beat (new-beat) :report "Supply beat"
			  :interactive (lambda ()
					 (format t "Beat value:")
					 (list (eval (read))))
			  (find-current-beat-with-bar-start-and-constant-beat
			   moment bar new-beat)))))
    
(defun find-current-beat-with-bar-start-and-constant-beat (current-moment bar-period beat-duration)
  (let ((beat-period (make-standard-anchored-period
		      (timepoint bar-period) beat-duration)))
    (do ()
	((time> (cut-off beat-period) current-moment) beat-period)
      (setf (timepoint beat-period)
	    (timepoint (cut-off beat-period))))))

(defmethod amuse-tools::gsharp-staff-string ((event tabcode-pitched-event))
  (if (< (midi-pitch-number event) 60)
      "bass"
      "treble"))