d@16: (cl:in-package #:amuse) 
d@16: 
d@16: (defmethod duration ((period-designator period))
d@16:   (%period-interval period-designator))
d@16: 
d@16: (defmethod timepoint ((moment-designator moment))
d@16:   (%moment-time moment-designator))
d@16: 
d@17: (defmethod span ((pitch-interval-designator pitch-interval))
d@17:   (%pitch-interval-span pitch-interval-designator))
d@17: 
d@18: (defmethod chromatic-pitch ((pitch-designator chromatic-pitch))
d@18:   pitch-designator)
d@18: 
d@18: (defmethod chromatic-pitch-number ((pitch-designator chromatic-pitch))
d@18:   (%chromatic-pitch-number pitch-designator))
d@18: 
d@18: (defmethod chromatic-pitch-number ((pitch-designator pitch))
d@18:   (%chromatic-pitch-number (chromatic-pitch pitch-designator)))
d@18: 
d@16: ;; Time protocol
d@16: 
d@16: (defmethod time+ ((object1 moment) (object2 period))
d@16:   (make-moment (+ (timepoint object1) (duration object2))))
d@16: 
d@16: (defmethod time+ ((object1 period) (object2 moment)) ;?
d@16:   (time+ object2 object1))
d@16: 
d@16: (defmethod time+ ((object1 period) (object2 period))
d@16:   (make-floating-period (+ (duration object1)
d@16: 			   (duration object2))))
d@16: 
d@16: (defmethod time+ ((object1 moment) (object2 moment))
d@17:   (error 'undefined-action :operation 'time+ :datatype (list (class-of object1) (class-of object2))))
d@16: 
d@16: (defmethod time- ((object1 moment) (object2 moment))
d@18:   (make-anchored-period (timepoint object2)
d@18: 			(- (timepoint object1)
d@18: 			   (timepoint object2))))
d@16: 
d@16: (defmethod time- ((object1 moment) (object2 period))
d@16:   (make-moment (- (timepoint object1) (duration object2))))
d@16: 
d@16: (defmethod time- ((object1 period) (object2 moment)) ;?
d@16:   (error 'undefined-action
d@16: 	 :operation 'time-
d@17: 	 :datatype (list (class-of object1) (class-of object2))))
d@16: 
d@16: (defmethod time- ((object1 period) (object2 period))
d@16:   (make-floating-period (- (duration object2)
d@16: 			   (duration object1))))
d@16: 
d@18: ;; these ones are less certain. I've just put them in, but think I
d@18: ;; should remove them and force the user to specify what they mean
d@18: ;; when they give objects that are both moments *and* periods to these
d@18: ;; functions.
d@18: 
d@18: (defmethod time- ((object1 anchored-period) (object2 anchored-period)) ;? 
d@18:   (time- (moment object1) (moment object2)))
d@18: 
d@18: (defmethod time- (object1 (object2 anchored-period)) ;?
d@18:   (time- object1 (moment object2)))
d@18: 
d@18: (defmethod time- ((object1 anchored-period) object2) ;?
d@18:   (time- (moment object1) object2))
d@16: 
d@16: (defmethod time> ((object1 moment) (object2 moment))
d@16:   (> (timepoint object1) (timepoint object2)))
d@16: 
d@16: (defmethod time= ((object1 moment) (object2 moment))
d@16:   (= (timepoint object1) (timepoint object2)))
d@16: 
d@16: (defmethod duration> ((object1 period) (object2 period))
d@16:   (> (duration object1) (duration object2)))
d@16: 
d@16: (defmethod duration= ((object1 period) (object2 period))
d@16:   (= (duration object1) (duration object2)))
d@16: 
d@16: (defmethod duration* ((object1 period) (object2 number))
d@18:   (make-floating-period (* (duration object1) object2)))
d@16: 
d@16: (defmethod duration* ((object1 number) (object2 period))
d@16:   (duration* object2 object1))
d@16: 
d@16: (defmethod duration/ ((object1 period) (object2 number))
d@18:   (make-floating-period (/ (duration object1) object2)))
d@16: 
d@16: ;; Pitch protocol
d@16: 
d@17: (defmethod pitch+ ((object1 pitch-designator)
d@17: 		   (object2 pitch-designator))
d@17:   (error 'undefined-action :operation 'pitch+
d@17: 	 :datatype (list (class-of object1) (class-of object2))))
d@17: 
d@17: (defmethod pitch+ ((object1 pitch-designator)
d@17: 		   (object2 pitch-interval)) ; or should I check the
d@17: 					     ; pitch/interval types?
d@17:   (make-chromatic-pitch (+ (chromatic-pitch object1)
d@17: 			   (span object2))))
d@17: 
d@17: (defmethod pitch+  ((object1 pitch-interval)
d@17: 		    (object2 pitch-designator)) ;?
d@17:   (pitch+ object2 object1))
d@17: 
d@17: (defmethod pitch+ ((object1 pitch-interval)
d@17: 		   (object2 pitch-interval))
d@17:   (make-pitch-interval (+ (span object1)
d@17: 			  (span object2))))
d@17: 
d@17: (defmethod pitch- ((object1 pitch-designator)
d@17: 		   (object2 pitch-designator))
d@17:   (make-pitch-interval (- (chromatic-pitch object1)
d@17: 			  (chromatic-pitch object2))))
d@17: 
d@17: (defmethod pitch- ((object1 pitch-designator)
d@17: 		   (object2 pitch-interval))
d@17:   (make-chromatic-pitch (- (chromatic-pitch object1)
d@17: 			   (span object2))))
d@17: 
d@17: (defmethod pitch- ((object1 pitch-interval)
d@17: 		   (object2 pitch-interval))
d@17:   (make-pitch-interval (- (span object1)
d@17: 			  (span object2))))
d@17: 
d@17: (defmethod pitch- ((object1 pitch-interval)
d@17: 		   (object2 pitch-designator))
d@17:   (error 'undefined-action :operation 'pitch-
d@17: 	 :datatype (list (class-of object1) (class-of object2))))
d@17: 
d@17: (defmethod pitch> ((object1 pitch-designator)
d@17: 		   (object2 pitch-designator))
d@17:   (> (chromatic-pitch object1)
d@17:      (chromatic-pitch object2)))
d@17: 
d@17: (defmethod pitch= ((object1 pitch-designator)
d@17: 		   (object2 pitch-designator))
d@17:   (= (chromatic-pitch object1)
d@17:      (chromatic-pitch object2)))
d@17: 
d@17: (defmethod interval> ((object1 pitch-interval)
d@17: 		   (object2 pitch-interval))
d@17:   (> (span object1)
d@17:      (span object2)))
d@17: 
d@17: (defmethod interval= ((object1 pitch-interval)
d@17: 		   (object2 pitch-interval))
d@17:   (= (span object1)
d@17:      (span object2)))
d@17: 
d@17: 
d@16: 
d@16: ;; Allen
d@16: 
d@16: (defmethod meets ((object1 anchored-period)
d@16: 		  (object2 anchored-period))
d@16:   (or (time= (cut-off object1) (onset object2))
d@16:       (time= (cut-off object2) (onset object1))))
d@16: 
d@16: (defmethod before ((object1 anchored-period)
d@16: 		   (object2 anchored-period))
d@16:   (time< (cut-off object1) (onset object2)))
d@16: 
d@16: (defmethod overlaps ((object1 anchored-period)
d@16: 		     (object2 anchored-period))
d@16:   (or (and (time> (cut-off object1) (onset object2))
d@16: 	   (time< (onset object1) (onset object2)))
d@16:       (and (time> (cut-off object1) (cut-off object2))
d@16: 	   (time< (onset object1) (cut-off object2)))))
d@16: 
d@16: (defmethod during ((object1 anchored-period)
d@16: 		   (object2 anchored-period))
d@16:   (and (time> (onset object1) (onset object2))
d@16:        (time< (cut-off object2) (cut-off object2))))
d@16: 
d@16: (defmethod starts ((object1 anchored-period)
d@16: 		   (object2 anchored-period))
d@16:   (time= (onset object1) (onset object2)))
d@16: 
d@16: (defmethod ends ((object1 anchored-period)
d@16: 		 (object2 anchored-period))
d@16:   (time= (cut-off object1) (cut-off object2)))
d@16: 
d@16: ;; ...and
d@16: 
d@16: (defmethod period-intersection ((object1 anchored-period)
d@16: 				(object2 anchored-period))
d@16:   (cond
d@16:     ((disjoint object1 object2)
d@16:      ;; if they don't overlap, return nil, not a negative-valued
d@16:      ;; period
d@16:      nil)
d@16:     (t
d@16:      (let ((new-onset (max (onset object1)
d@16: 			   (onset object2))))
d@16:        (make-anchored-period new-onset
d@16: 			     (time- (min (cut-off object1)
d@16: 					 (cut-off object2))
d@16: 				    new-onset))))))
d@16: 
d@16: 
d@16: