comparison base/methods.lisp @ 24:8d2b1662f658

base/*.lisp: move files in amuse-base to subdirectory.

darcs-hash:20061215161617-aa3d6-1b63bd555b02ec02aa2db12d335e8b726e2108cd.gz

+(cl:in-package #:amuse) 
+
+(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 timepoint ((moment-designator moment))
+  (%moment-time moment-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 key-signature-sharps ((key-signature basic-key-signature))
+  (%basic-key-signature-sharp-count key-signature))
+
+(defmethod bpm ((tempo tempo))
+  (%tempo-bpm tempo))
+
+;; 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 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 (+ (chromatic-pitch 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 (- (chromatic-pitch object1)
+			  (chromatic-pitch object2))))
+
+(defmethod pitch- ((object1 pitch-designator)
+		   (object2 pitch-interval))
+  (make-chromatic-pitch (- (chromatic-pitch 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))
+  (> (chromatic-pitch object1)
+     (chromatic-pitch object2)))
+
+(defmethod pitch= ((object1 pitch-designator)
+		   (object2 pitch-designator))
+  (= (chromatic-pitch object1)
+     (chromatic-pitch 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-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)))))
+			   
+
+
+