m@24: (cl:in-package #:amuse) m@24: m@89: ;;; monody m@89: m@89: (defmethod ensure-monody ((m monody)) m@89: (let ((result t)) m@89: (dotimes (i (1- (length m)) result) m@89: ;; assumes the events are time ordered which (since monody is a m@89: ;; subclass of time-ordered-constituent) they ought to be. m@89: (let ((e1 (elt m i)) m@89: (e2 (elt m (1+ i)))) m@89: (unless (or (before e1 e2) (meets e1 e2)) m@89: (setf result nil)))))) m@89: m@81: ;;; MIPS pitch m@81: c@106: (defmethod asa-pitch-string ((mp mips-pitch)) c@106: (mips:p-pn (list (%p-pc mp) (%p-pm mp)))) c@106: c@106: (defmethod diatonic-pitch-octave ((mp mips-pitch)) c@106: (let* ((asa-string (asa-pitch-string mp)) c@106: (start (position-if #'digit-char-p asa-string))) c@106: (values (parse-integer asa-string :start start)))) m@86: m@86: (defmethod diatonic-pitch-accidental ((mp mips-pitch)) c@106: (let* ((asa-string (asa-pitch-string mp)) c@106: (start 1) c@106: (end (position-if #'digit-char-p asa-string)) c@106: (malist '((#\n . 0) (#\s . +1) (#\f . -1))) c@106: (multiplier (cdr (assoc (char asa-string 1) malist)))) c@106: (* multiplier (- end start)))) c@106: c@106: (defmethod diatonic-pitch-name ((mp mips-pitch)) c@106: (elt (asa-pitch-string mp) 0)) m@86: m@83: (defmethod pitch= ((p1 mips-pitch) (p2 mips-pitch)) c@106: (let ((c1 (%p-pc p1)) (m1 (%p-pm p1)) c@106: (c2 (%p-pc p2)) (m2 (%p-pm p2))) m@83: (and c1 c2 (= c1 c2) m@83: m1 m2 (= m1 m2)))) m@83: m@81: (defmethod middle-c ((mp mips-pitch)) m@81: (make-mips-pitch 39 23)) m@81: c@106: (defmethod midi-pitch-number ((mp mips-pitch)) c@106: (+ (%p-pc mp) 21)) c@106: c@106: (defmethod octave ((mp mips-pitch)) c@106: (1- (floor (midi-pitch-number mp) 12))) c@106: c@106: (defmethod diatonic-pitch ((mp mips-pitch)) m@81: mp) m@81: c@106: (defmethod print-object ((o mips-pitch) stream) c@106: (print-unreadable-object (o stream :type t) c@106: (let ((asa-string (asa-pitch-string o))) c@106: (write asa-string :stream stream)))) m@81: m@81: ;;; Chromatic pitch m@81: m@86: (defmethod octave ((cp chromatic-pitch)) c@106: (1- (floor (%chromatic-pitch-number cp) 12))) m@86: m@81: (defmethod middle-c ((cp chromatic-pitch)) m@81: (make-chromatic-pitch 60)) m@81: 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: d@73: (defmethod cut-off ((anchored-period-designator anchored-period)) d@73: (make-instance 'moment d@73: :time (+ (%moment-time anchored-period-designator) d@73: (%period-interval anchored-period-designator)))) d@73: 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)) d@100: "(time+ ) -> Implemented as a d@100: straightforward summation." m@24: (make-moment (+ (timepoint object1) (duration object2)))) m@24: m@24: (defmethod time+ ((object1 period) (object2 moment)) ;? d@100: "(time+ ) -> Implemented as a d@100: straightforward summation." m@24: (time+ object2 object1)) m@24: m@24: (defmethod time+ ((object1 period) (object2 period)) d@100: "(time+ ) -> Implemented as a d@100: straightforward summation." m@24: (make-floating-period (+ (duration object1) m@24: (duration object2)))) m@24: m@24: (defmethod time+ ((object1 moment) (object2 moment)) d@100: "(time+ ) -> The d@100: question makes no sense." 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: d@73: (defmethod time< ((object1 moment) (object2 moment)) d@73: (< (timepoint object1) (timepoint object2))) d@73: 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)) c@105: (make-chromatic-pitch-interval (+ (span object1) (span object2)))) m@24: m@24: (defmethod pitch- ((object1 pitch-designator) m@24: (object2 pitch-designator)) c@105: (make-chromatic-pitch-interval c@105: (- (midi-pitch-number object1) (midi-pitch-number object2)))) m@24: m@24: (defmethod pitch- ((object1 pitch-designator) m@24: (object2 pitch-interval)) c@105: (make-chromatic-pitch (- (midi-pitch-number object1) (span object2)))) m@24: m@24: (defmethod pitch- ((object1 pitch-interval) m@24: (object2 pitch-interval)) c@105: (make-chromatic-pitch-interval (- (span object1) (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) c@104: (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) c@105: (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: