annotate base/methods.lisp @ 83:ae06767e84c5

base/: pitch

darcs-hash:20070717153457-c0ce4-cd5350c65ee8414bda17d40eb0e149063f2c22d7.gz

(cl:in-package #:amuse) 

;;; diatonic pitch 

(defmethod pitch= ((p1 diatonic-pitch) (p2 diatonic-pitch))
  (let ((n1 (%diatonic-pitch-name p1))
        (a1 (%diatonic-pitch-accidental p1))
        (o1 (%diatonic-pitch-accidental p1))
        (n2 (%diatonic-pitch-name p2))
        (a2 (%diatonic-pitch-accidental p2))
        (o2 (%diatonic-pitch-accidental p2)))
    (and n1 n2 (= n1 n2)
         a1 a2 (= a1 a2)
         o1 o2 (= o1 o2))))

(defmethod middle-c ((dp diatonic-pitch))
  (make-diatonic-pitch 2 0 4))

(defmethod diatonic-pitch ((dp diatonic-pitch))
  dp)

(defmethod diatonic-pitch-name ((dp diatonic-pitch))
  (elt "ABCDEFG" (%diatonic-pitch-name dp)))

(defmethod asa-pitch-string ((dp diatonic-pitch))
  (concatenate 'string
               (diatonic-pitch-name dp)
               (let ((a (%diatonic-pitch-accidental dp)))
                 (cond ((plusp a) 
                        (make-sequence 'string a :initial-element "s"))
                       ((minusp a)
                        (make-sequence 'string (abs a) :initial-element "f"))
                       (t "n")))
               (%diatonic-pitch-octave dp)))

(defmethod mips-pitch ((dp diatonic-pitch))
  (let ((mips-pitch (mips:pn-p (asa-pitch-string dp))))
    (make-mips-pitch (first mips-pitch) (second mips-pitch))))
(defmethod midi-pitch-number ((dp diatonic-pitch))
  (midi-pitch-number (mips-pitch dp)))
(defmethod chromatic-pitch ((dp diatonic-pitch))
  (make-chromatic-pitch (midi-pitch-number dp)))
(defmethod meredith-chromatic-pitch-number ((dp diatonic-pitch))
  (meredith-chromatic-pitch-number (mips-pitch dp)))
(defmethod meredith-morphetic-pitch-number ((dp diatonic-pitch))
  (meredith-morphetic-pitch-number (mips-pitch dp)))

;;; MIPS pitch 

(defmethod pitch= ((p1 mips-pitch) (p2 mips-pitch))
  (let ((c1 (meredith-chromatic-pitch-number p1))
        (m1 (meredith-morphetic-pitch-number p1))
        (c2 (meredith-chromatic-pitch-number p2))
        (m2 (meredith-morphetic-pitch-number p2)))
    (and c1 c2 (= c1 c2)
         m1 m2 (= m1 m2))))

(defmethod middle-c ((mp mips-pitch))
  (make-mips-pitch 39 23))

(defmethod mips-pitch ((mp mips-pitch))
  mp)

(defmethod diatonic-pitch ((mp mips-pitch))
  (let ((asa-pitch (mips:p-pn (list (%p-pc mp) (%p-pm mp))))
        (accidental-count nil))
    (make-diatonic-pitch 
     (position (elt asa-pitch 0) "ABCDEFG")
     (ecase (elt asa-pitch 1)
       (#\n 0)
       (#\s 
        (let ((c (count #\s asa-pitch)))
          (setf accidental-count c)
          c))
       (#\f 
        (let ((c (count #\f asa-pitch)))
          (setf accidental-count c)
          (- c))))
     (parse-integer 
      asa-pitch :start (if accidental-count (1+ accidental-count) 2)))))

(defmethod meredith-chromatic-pitch-number ((mp mips-pitch)) 
  (%p-pc mp))
(defmethod meredith-morphetic-pitch-number ((mp mips-pitch)) 
  (%p-pm mp))
(defmethod midi-pitch-number ((mp mips-pitch))
  (+ (meredith-chromatic-pitch-number mp) 21))
(defmethod chromatic-pitch ((mp mips-pitch))
  (make-chromatic-pitch (midi-pitch-number mp)))
(defmethod asa-pitch-string ((mp mips-pitch))
  (mips:p-pn (list (meredith-chromatic-pitch-number mp)
                   (meredith-morphetic-pitch-number mp))))
(defmethod diatonic-pitch-name ((mp mips-pitch))
  (elt (asa-pitch-string mp) 0))

;;; Chromatic pitch 

(defmethod middle-c ((cp chromatic-pitch))
  (make-chromatic-pitch 60))

(defmethod chromatic-pitch ((pitch-designator chromatic-pitch))
  pitch-designator)

(defmethod midi-pitch-number ((pitch-designator chromatic-pitch))
  (%chromatic-pitch-number pitch-designator))

(defmethod midi-pitch-number ((pitch-designator pitch))
  (%chromatic-pitch-number (chromatic-pitch pitch-designator)))

(defmethod span ((pitch-interval-designator pitch-interval))
  (%pitch-interval-span pitch-interval-designator))

(defmethod duration ((period-designator period))
  (%period-interval period-designator))

(defmethod (setf duration) ((value real) (period-designator period))
  (setf (%period-interval period-designator) value))

(defmethod timepoint ((moment-designator moment))
  (%moment-time moment-designator))

(defmethod (setf timepoint) ((value real) (moment-designator moment))
  (setf (%moment-time moment-designator) value))

(defmethod cut-off ((anchored-period-designator anchored-period))
  (make-instance 'moment
		 :time (+ (%moment-time anchored-period-designator)
			  (%period-interval anchored-period-designator))))

(defmethod beat-units-per-bar ((time-signature basic-time-signature))
  (%basic-time-signature-numerator time-signature))

(defmethod beat-units ((time-signature basic-time-signature))
  (%basic-time-signature-denominator time-signature))

(defmethod time-signature-equal ((ts1 basic-time-signature) 
                                 (ts2 basic-time-signature))
  (let ((n1 (time-signature-numerator ts1))
        (n2 (time-signature-numerator ts2))
        (d1 (time-signature-denominator ts1))
        (d2 (time-signature-denominator ts2)))
    (and n1 n2 (= n1 n2) 
         d1 d2 (= d1 d2))))

(defmethod key-signature-sharps ((key-signature basic-key-signature))
  (%basic-key-signature-sharp-count key-signature))

(defmethod key-signature-mode ((ks midi-key-signature))
  (%midi-key-signature-mode ks))

(defmethod key-signature-equal ((ks1 basic-key-signature) 
                                (ks2 basic-key-signature))
  (let ((s1 (key-signature-sharps ks1))
        (s2 (key-signature-sharps ks2)))
    (and s1 s2 (= s1 s2))))

(defmethod key-signature-equal ((ks1 midi-key-signature) 
                                (ks2 midi-key-signature))
  (let ((s1 (key-signature-sharps ks1))
        (s2 (key-signature-sharps ks2))
        (m1 (key-signature-mode   ks1))
        (m2 (key-signature-mode   ks2)))
    (and s1 s2 (= s1 s2) 
         m1 m2 (= m1 m2))))

(defmethod bpm ((tempo tempo))
  (%tempo-bpm tempo))

(defmethod tempo-equal ((t1 tempo) (t2 tempo))
  (and (bpm t1) (bpm t2) (= t1 t2)))
       

;; Time protocol

(defmethod time+ ((object1 moment) (object2 period))
  (make-moment (+ (timepoint object1) (duration object2))))

(defmethod time+ ((object1 period) (object2 moment)) ;?
  (time+ object2 object1))

(defmethod time+ ((object1 period) (object2 period))
  (make-floating-period (+ (duration object1)
			   (duration object2))))

(defmethod time+ ((object1 moment) (object2 moment))
  (error 'undefined-action :operation 'time+ :datatype (list (class-of object1) (class-of object2))))

(defmethod time- ((object1 moment) (object2 moment))
  (make-anchored-period (timepoint object2)
			(- (timepoint object1)
			   (timepoint object2))))

(defmethod time- ((object1 moment) (object2 period))
  (make-moment (- (timepoint object1) (duration object2))))

(defmethod time- ((object1 period) (object2 moment)) ;?
  (error 'undefined-action
	 :operation 'time-
	 :datatype (list (class-of object1) (class-of object2))))

(defmethod time- ((object1 period) (object2 period))
  (make-floating-period (- (duration object2)
			   (duration object1))))

;; these ones are less certain. I've just put them in, but think I
;; should remove them and force the user to specify what they mean
;; when they give objects that are both moments *and* periods to these
;; functions.

(defmethod time- ((object1 anchored-period) (object2 anchored-period)) ;? 
  (time- (moment object1) (moment object2)))

(defmethod time- (object1 (object2 anchored-period)) ;?
  (time- object1 (moment object2)))

(defmethod time- ((object1 anchored-period) object2) ;?
  (time- (moment object1) object2))

(defmethod time> ((object1 moment) (object2 moment))
  (> (timepoint object1) (timepoint object2)))

(defmethod time< ((object1 moment) (object2 moment))
  (< (timepoint object1) (timepoint object2)))

(defmethod time= ((object1 moment) (object2 moment))
  (= (timepoint object1) (timepoint object2)))

(defmethod duration> ((object1 period) (object2 period))
  (> (duration object1) (duration object2)))

(defmethod duration= ((object1 period) (object2 period))
  (= (duration object1) (duration object2)))

(defmethod duration* ((object1 period) (object2 number))
  (make-floating-period (* (duration object1) object2)))

(defmethod duration* ((object1 number) (object2 period))
  (duration* object2 object1))

(defmethod duration/ ((object1 period) (object2 number))
  (make-floating-period (/ (duration object1) object2)))

;; Pitch protocol

(defmethod pitch+ ((object1 pitch-designator)
		   (object2 pitch-designator))
  (error 'undefined-action :operation 'pitch+
	 :datatype (list (class-of object1) (class-of object2))))

(defmethod pitch+ ((object1 pitch-designator)
		   (object2 pitch-interval)) ; or should I check the
					     ; pitch/interval types?
  (make-chromatic-pitch (+ (midi-pitch-number object1)
			   (span object2))))

(defmethod pitch+  ((object1 pitch-interval)
		    (object2 pitch-designator)) ;?
  (pitch+ object2 object1))

(defmethod pitch+ ((object1 pitch-interval)
		   (object2 pitch-interval))
  (make-pitch-interval (+ (span object1)
			  (span object2))))

(defmethod pitch- ((object1 pitch-designator)
		   (object2 pitch-designator))
  (make-pitch-interval (- (midi-pitch-number object1)
			  (midi-pitch-number object2))))

(defmethod pitch- ((object1 pitch-designator)
		   (object2 pitch-interval))
  (make-chromatic-pitch (- (midi-pitch-number object1)
			   (span object2))))

(defmethod pitch- ((object1 pitch-interval)
		   (object2 pitch-interval))
  (make-pitch-interval (- (span object1)
			  (span object2))))

(defmethod pitch- ((object1 pitch-interval)
		   (object2 pitch-designator))
  (error 'undefined-action :operation 'pitch-
	 :datatype (list (class-of object1) (class-of object2))))

(defmethod pitch> ((object1 pitch-designator)
		   (object2 pitch-designator))
  (> (midi-pitch-number object1)
     (midi-pitch-number object2)))

(defmethod pitch= ((object1 pitch-designator)
		   (object2 pitch-designator))
  (= (midi-pitch-number object1)
     (midi-pitch-number object2)))

(defmethod interval> ((object1 pitch-interval)
		   (object2 pitch-interval))
  (> (span object1)
     (span object2)))

(defmethod interval= ((object1 pitch-interval)
		   (object2 pitch-interval))
  (= (span object1)
     (span object2)))



;; Allen

(defmethod meets ((object1 anchored-period)
		  (object2 anchored-period))
  (or (time= (cut-off object1) object2)
      (time= (cut-off object2) object1)))

(defmethod before ((object1 anchored-period)
		   (object2 anchored-period))
  (time> object2 (cut-off object1)))

(defmethod overlaps ((object1 anchored-period)
		     (object2 anchored-period))
  ;; FIXME: Is there a tidier method?
  (or (and (time> object2 object1) ; object1 starts before object2
	   (time> (cut-off object1) object2) ; object1 ends after object2 starts
	   (time> (cut-off object2) (cut-off object1))) ; object1 ends before object2 does
      (and (time> object1 object2) ; object1 starts after object2
	   (time> (cut-off object2) object1) ; object1 starts before object2 ends
	   (time> (cut-off object1) (cut-off object2))))) ; object1 ends after object2 does

(defmethod during ((object1 anchored-period)
		   (object2 anchored-period))
  (and (time> object1 object2)
       (time< (cut-off object2) (cut-off object2))))

(defmethod starts ((object1 anchored-period)
		   (object2 anchored-period))
  (time= object1 object2))

(defmethod ends ((object1 anchored-period)
		 (object2 anchored-period))
  (time= (cut-off object1) (cut-off object2)))

;; ...and

(defmethod period= ((object1 anchored-period)
		     (object2 anchored-period))
  (and (time= object1 object2)
       (duration= object1 object2)))
(defmethod period= ((object1 floating-period)
		    (object2 floating-period))
  (duration= object1 object2))

(defmethod period-intersection ((object1 anchored-period)
				(object2 anchored-period))
  (cond
    ((disjoint object1 object2)
     ;; if they don't overlap, return nil, not a negative-valued
     ;; period
     nil)
    ((let* ((start (if (time> (onset object2) (onset object1))
		       (onset object2)
		       (onset object1)))
	    (duration (duration (time- (if (time> (cut-off object2) (cut-off object1))
					   (cut-off object1)
					   (cut-off object2))
				       start))))
       (make-anchored-period (timepoint start) duration)))))