m@24: (cl:in-package #:amuse) 
m@24: 
m@24: (defmethod chromatic-pitch ((pitch-designator chromatic-pitch))
m@24:   pitch-designator)
m@24: 
m@24: (defmethod midi-pitch-number ((pitch-designator chromatic-pitch))
m@24:   (%chromatic-pitch-number pitch-designator))
m@24: 
m@24: (defmethod midi-pitch-number ((pitch-designator pitch))
m@24:   (%chromatic-pitch-number (chromatic-pitch pitch-designator)))
m@24: 
m@24: (defmethod span ((pitch-interval-designator pitch-interval))
m@24:   (%pitch-interval-span pitch-interval-designator))
m@24: 
m@24: (defmethod duration ((period-designator period))
m@24:   (%period-interval period-designator))
m@24: 
d@33: (defmethod (setf duration) ((value real) (period-designator period))
d@33:   (setf (%period-interval period-designator) value))
d@33: 
m@24: (defmethod timepoint ((moment-designator moment))
m@24:   (%moment-time moment-designator))
m@24: 
d@33: (defmethod (setf timepoint) ((value real) (moment-designator moment))
d@33:   (setf (%moment-time moment-designator) value))
d@33: 
m@24: (defmethod beat-units-per-bar ((time-signature basic-time-signature))
m@24:   (%basic-time-signature-numerator time-signature))
m@24: 
m@24: (defmethod beat-units ((time-signature basic-time-signature))
m@24:   (%basic-time-signature-denominator time-signature))
m@24: 
m@67: (defmethod time-signature-equal ((ts1 basic-time-signature) 
m@67:                                  (ts2 basic-time-signature))
m@67:   (let ((n1 (time-signature-numerator ts1))
m@67:         (n2 (time-signature-numerator ts2))
m@67:         (d1 (time-signature-denominator ts1))
m@67:         (d2 (time-signature-denominator ts2)))
m@67:     (and n1 n2 (= n1 n2) 
m@67:          d1 d2 (= d1 d2))))
m@67: 
m@24: (defmethod key-signature-sharps ((key-signature basic-key-signature))
m@24:   (%basic-key-signature-sharp-count key-signature))
m@24: 
m@45: (defmethod key-signature-mode ((ks midi-key-signature))
m@45:   (%midi-key-signature-mode ks))
m@45: 
m@67: (defmethod key-signature-equal ((ks1 basic-key-signature) 
m@67:                                 (ks2 basic-key-signature))
m@67:   (let ((s1 (key-signature-sharps ks1))
m@67:         (s2 (key-signature-sharps ks2)))
m@67:     (and s1 s2 (= s1 s2))))
m@67: 
m@67: (defmethod key-signature-equal ((ks1 midi-key-signature) 
m@67:                                 (ks2 midi-key-signature))
m@67:   (let ((s1 (key-signature-sharps ks1))
m@67:         (s2 (key-signature-sharps ks2))
m@67:         (m1 (key-signature-mode   ks1))
m@67:         (m2 (key-signature-mode   ks2)))
m@67:     (and s1 s2 (= s1 s2) 
m@67:          m1 m2 (= m1 m2))))
m@67: 
m@24: (defmethod bpm ((tempo tempo))
m@24:   (%tempo-bpm tempo))
m@24: 
m@67: (defmethod tempo-equal ((t1 tempo) (t2 tempo))
m@67:   (and (bpm t1) (bpm t2) (= t1 t2)))
m@67:        
m@67: 
m@24: ;; Time protocol
m@24: 
m@24: (defmethod time+ ((object1 moment) (object2 period))
m@24:   (make-moment (+ (timepoint object1) (duration object2))))
m@24: 
m@24: (defmethod time+ ((object1 period) (object2 moment)) ;?
m@24:   (time+ object2 object1))
m@24: 
m@24: (defmethod time+ ((object1 period) (object2 period))
m@24:   (make-floating-period (+ (duration object1)
m@24: 			   (duration object2))))
m@24: 
m@24: (defmethod time+ ((object1 moment) (object2 moment))
m@24:   (error 'undefined-action :operation 'time+ :datatype (list (class-of object1) (class-of object2))))
m@24: 
m@24: (defmethod time- ((object1 moment) (object2 moment))
m@24:   (make-anchored-period (timepoint object2)
m@24: 			(- (timepoint object1)
m@24: 			   (timepoint object2))))
m@24: 
m@24: (defmethod time- ((object1 moment) (object2 period))
m@24:   (make-moment (- (timepoint object1) (duration object2))))
m@24: 
m@24: (defmethod time- ((object1 period) (object2 moment)) ;?
m@24:   (error 'undefined-action
m@24: 	 :operation 'time-
m@24: 	 :datatype (list (class-of object1) (class-of object2))))
m@24: 
m@24: (defmethod time- ((object1 period) (object2 period))
m@24:   (make-floating-period (- (duration object2)
m@24: 			   (duration object1))))
m@24: 
m@24: ;; these ones are less certain. I've just put them in, but think I
m@24: ;; should remove them and force the user to specify what they mean
m@24: ;; when they give objects that are both moments *and* periods to these
m@24: ;; functions.
m@24: 
m@24: (defmethod time- ((object1 anchored-period) (object2 anchored-period)) ;? 
m@24:   (time- (moment object1) (moment object2)))
m@24: 
m@24: (defmethod time- (object1 (object2 anchored-period)) ;?
m@24:   (time- object1 (moment object2)))
m@24: 
m@24: (defmethod time- ((object1 anchored-period) object2) ;?
m@24:   (time- (moment object1) object2))
m@24: 
m@24: (defmethod time> ((object1 moment) (object2 moment))
m@24:   (> (timepoint object1) (timepoint object2)))
m@24: 
m@24: (defmethod time= ((object1 moment) (object2 moment))
m@24:   (= (timepoint object1) (timepoint object2)))
m@24: 
m@24: (defmethod duration> ((object1 period) (object2 period))
m@24:   (> (duration object1) (duration object2)))
m@24: 
m@24: (defmethod duration= ((object1 period) (object2 period))
m@24:   (= (duration object1) (duration object2)))
m@24: 
m@24: (defmethod duration* ((object1 period) (object2 number))
m@24:   (make-floating-period (* (duration object1) object2)))
m@24: 
m@24: (defmethod duration* ((object1 number) (object2 period))
m@24:   (duration* object2 object1))
m@24: 
m@24: (defmethod duration/ ((object1 period) (object2 number))
m@24:   (make-floating-period (/ (duration object1) object2)))
m@24: 
m@24: ;; Pitch protocol
m@24: 
m@24: (defmethod pitch+ ((object1 pitch-designator)
m@24: 		   (object2 pitch-designator))
m@24:   (error 'undefined-action :operation 'pitch+
m@24: 	 :datatype (list (class-of object1) (class-of object2))))
m@24: 
m@24: (defmethod pitch+ ((object1 pitch-designator)
m@24: 		   (object2 pitch-interval)) ; or should I check the
m@24: 					     ; pitch/interval types?
d@34:   (make-chromatic-pitch (+ (midi-pitch-number object1)
m@24: 			   (span object2))))
m@24: 
m@24: (defmethod pitch+  ((object1 pitch-interval)
m@24: 		    (object2 pitch-designator)) ;?
m@24:   (pitch+ object2 object1))
m@24: 
m@24: (defmethod pitch+ ((object1 pitch-interval)
m@24: 		   (object2 pitch-interval))
m@24:   (make-pitch-interval (+ (span object1)
m@24: 			  (span object2))))
m@24: 
m@24: (defmethod pitch- ((object1 pitch-designator)
m@24: 		   (object2 pitch-designator))
d@34:   (make-pitch-interval (- (midi-pitch-number object1)
d@34: 			  (midi-pitch-number object2))))
m@24: 
m@24: (defmethod pitch- ((object1 pitch-designator)
m@24: 		   (object2 pitch-interval))
d@34:   (make-chromatic-pitch (- (midi-pitch-number object1)
m@24: 			   (span object2))))
m@24: 
m@24: (defmethod pitch- ((object1 pitch-interval)
m@24: 		   (object2 pitch-interval))
m@24:   (make-pitch-interval (- (span object1)
m@24: 			  (span object2))))
m@24: 
m@24: (defmethod pitch- ((object1 pitch-interval)
m@24: 		   (object2 pitch-designator))
m@24:   (error 'undefined-action :operation 'pitch-
m@24: 	 :datatype (list (class-of object1) (class-of object2))))
m@24: 
m@24: (defmethod pitch> ((object1 pitch-designator)
m@24: 		   (object2 pitch-designator))
d@34:   (> (midi-pitch-number object1)
d@34:      (midi-pitch-number object2)))
m@24: 
m@24: (defmethod pitch= ((object1 pitch-designator)
m@24: 		   (object2 pitch-designator))
d@34:   (= (midi-pitch-number object1)
d@34:      (midi-pitch-number object2)))
m@24: 
m@24: (defmethod interval> ((object1 pitch-interval)
m@24: 		   (object2 pitch-interval))
m@24:   (> (span object1)
m@24:      (span object2)))
m@24: 
m@24: (defmethod interval= ((object1 pitch-interval)
m@24: 		   (object2 pitch-interval))
m@24:   (= (span object1)
m@24:      (span object2)))
m@24: 
m@24: 
m@24: 
m@24: ;; Allen
m@24: 
m@24: (defmethod meets ((object1 anchored-period)
m@24: 		  (object2 anchored-period))
m@24:   (or (time= (cut-off object1) object2)
m@24:       (time= (cut-off object2) object1)))
m@24: 
m@24: (defmethod before ((object1 anchored-period)
m@24: 		   (object2 anchored-period))
m@24:   (time> object2 (cut-off object1)))
m@24: 
m@24: (defmethod overlaps ((object1 anchored-period)
m@24: 		     (object2 anchored-period))
m@24:   ;; FIXME: Is there a tidier method?
m@24:   (or (and (time> object2 object1) ; object1 starts before object2
m@24: 	   (time> (cut-off object1) object2) ; object1 ends after object2 starts
m@24: 	   (time> (cut-off object2) (cut-off object1))) ; object1 ends before object2 does
m@24:       (and (time> object1 object2) ; object1 starts after object2
m@24: 	   (time> (cut-off object2) object1) ; object1 starts before object2 ends
m@24: 	   (time> (cut-off object1) (cut-off object2))))) ; object1 ends after object2 does
m@24: 
m@24: (defmethod during ((object1 anchored-period)
m@24: 		   (object2 anchored-period))
m@24:   (and (time> object1 object2)
m@24:        (time< (cut-off object2) (cut-off object2))))
m@24: 
m@24: (defmethod starts ((object1 anchored-period)
m@24: 		   (object2 anchored-period))
m@24:   (time= object1 object2))
m@24: 
m@24: (defmethod ends ((object1 anchored-period)
m@24: 		 (object2 anchored-period))
m@24:   (time= (cut-off object1) (cut-off object2)))
m@24: 
m@24: ;; ...and
m@24: 
d@33: (defmethod period= ((object1 anchored-period)
d@33: 		     (object2 anchored-period))
d@33:   (and (time= object1 object2)
d@33:        (duration= object1 object2)))
d@33: (defmethod period= ((object1 floating-period)
d@33: 		    (object2 floating-period))
d@33:   (duration= object1 object2))
d@33: 
m@24: (defmethod period-intersection ((object1 anchored-period)
m@24: 				(object2 anchored-period))
m@24:   (cond
m@24:     ((disjoint object1 object2)
m@24:      ;; if they don't overlap, return nil, not a negative-valued
m@24:      ;; period
m@24:      nil)
m@24:     ((let* ((start (if (time> (onset object2) (onset object1))
m@24: 		       (onset object2)
m@24: 		       (onset object1)))
m@24: 	    (duration (duration (time- (if (time> (cut-off object2) (cut-off object1))
m@24: 					   (cut-off object1)
m@24: 					   (cut-off object2))
m@24: 				       start))))
m@24:        (make-anchored-period (timepoint start) duration)))))
m@24: 
m@24: