m@24: (cl:in-package #:amuse) m@24: m@89: ;;; monody m@89: m@143: (defmethod ensure-monody ((m standard-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: c@109: ;;; diatonic pitch (represented using MIPS) m@81: c@109: (defmethod asa-pitch-string ((mp diatonic-pitch)) c@106: (mips:p-pn (list (%p-pc mp) (%p-pm mp)))) c@106: c@109: (defmethod diatonic-pitch-octave ((mp diatonic-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: c@109: (defmethod diatonic-pitch-accidental ((mp diatonic-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@109: (defmethod diatonic-pitch-name ((mp diatonic-pitch)) c@106: (elt (asa-pitch-string mp) 0)) m@86: c@109: (defmethod middle-c ((mp diatonic-pitch)) j@187: (make-diatonic-pitch #\C 0 4)) m@81: c@109: (defmethod midi-pitch-number ((mp diatonic-pitch)) c@106: (+ (%p-pc mp) 21)) c@106: c@109: (defmethod octave ((mp diatonic-pitch)) c@106: (1- (floor (midi-pitch-number mp) 12))) c@106: c@109: (defmethod diatonic-pitch ((mp diatonic-pitch)) m@81: mp) m@81: c@109: (defmethod print-object ((o diatonic-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: c@111: (defmethod asa-interval-string ((mpi diatonic-pitch-interval)) c@111: (mips:pi-pin (%diatonic-pitch-interval-span mpi))) c@111: c@111: (defmethod print-object ((o diatonic-pitch-interval) stream) c@111: (print-unreadable-object (o stream :type t) c@111: (let ((asa-string (asa-interval-string o))) c@111: (write asa-string :stream stream)))) c@111: 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: d@136: (defmethod chromatic-pitch ((pitch chromatic-pitch)) d@136: pitch) m@24: d@136: (defmethod midi-pitch-number ((pitch chromatic-pitch)) d@136: (%chromatic-pitch-number pitch)) m@24: d@136: (defmethod midi-pitch-number ((pitch pitch)) d@136: (%chromatic-pitch-number (chromatic-pitch pitch))) m@24: m@113: (defmethod print-object ((o chromatic-pitch) stream) m@113: (print-unreadable-object (o stream :type t) m@113: (write (midi-pitch-number o) :stream stream))) m@113: m@113: (defmethod print-object ((o chromatic-pitch-interval) stream) m@113: (print-unreadable-object (o stream :type t) m@113: (write (span o) :stream stream))) m@113: m@113: d@136: (defmethod span ((pitch-interval chromatic-pitch-interval)) d@136: (%chromatic-pitch-interval-span pitch-interval)) m@24: d@136: (defmethod duration ((period standard-period)) d@136: (%period-interval period)) m@24: d@136: (defmethod (setf duration) ((value real) (period standard-period)) d@136: (setf (%period-interval period) value)) d@33: d@136: (defmethod timepoint ((moment standard-moment)) d@136: (%moment-time moment)) m@24: d@136: (defmethod (setf timepoint) ((value real) (moment standard-moment)) d@136: (setf (%moment-time moment) value)) d@33: d@136: (defmethod cut-off ((anchored-period standard-anchored-period)) d@136: (make-instance 'standard-moment d@136: :time (+ (%moment-time anchored-period) d@136: (%period-interval anchored-period)))) d@73: d@136: (defmethod print-object ((o standard-moment) stream) m@113: (print-unreadable-object (o stream :type t) m@113: (write (timepoint o) :stream stream))) m@113: d@136: (defmethod print-object ((o standard-period) stream) m@113: (print-unreadable-object (o stream :type t) m@113: (write (duration o) :stream stream))) m@113: d@136: (defmethod print-object ((o standard-anchored-period) stream) m@126: (print-unreadable-object (o stream :type t) m@126: (format stream "~A ~A" (timepoint o) (duration o)))) m@113: d@136: (defmethod beat-units-per-bar ((time-signature standard-time-signature)) m@24: (%basic-time-signature-numerator time-signature)) m@24: d@136: (defmethod beat-units ((time-signature standard-time-signature)) m@24: (%basic-time-signature-denominator time-signature)) m@24: d@136: (defmethod time-signature-equal ((ts1 standard-time-signature) d@136: (ts2 standard-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: d@136: (defmethod print-object ((sts standard-time-signature) stream) d@136: (print-unreadable-object (sts stream :type t) d@136: (format stream "~A/~A" (beat-units-per-bar sts) (beat-units sts)))) m@113: d@136: (defmethod key-signature-sharps ((key-signature standard-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@113: (defmethod print-object ((mks midi-key-signature) stream) m@113: (print-unreadable-object (mks stream :type t) m@113: (format stream "~A ~A" m@113: (%basic-key-signature-sharp-count mks) m@113: (%midi-key-signature-mode mks)))) m@113: d@136: (defmethod key-signature-equal ((ks1 standard-key-signature) d@136: (ks2 standard-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: d@136: (defmethod bpm ((tempo standard-tempo)) m@24: (%tempo-bpm tempo)) m@24: d@136: (defmethod print-object ((tempo standard-tempo) stream) m@113: (print-unreadable-object (tempo stream :type t) m@113: (write (bpm tempo) :stream stream))) m@113: 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: d@136: (defmethod time+ ((moment standard-moment) (period standard-period)) d@136: "Returns a . Implemented as a straightforward d@121: summation." d@136: (make-standard-moment (+ (timepoint moment) (duration period)))) m@24: d@136: (defmethod time+ ((period standard-period) (moment standard-moment)) ;? d@136: "Returns a . Implemented as a straightforward d@136: summation and defined by default as (time+ )." d@137: (time+ moment period)) m@24: d@136: (defmethod time+ ((period1 standard-period) d@136: (period2 standard-period)) d@136: "Returns a . Implemented as a straightforward d@121: summation." d@136: (make-standard-period (+ (duration period1) d@136: (duration period2)))) m@24: d@136: (defmethod time+ ((moment1 moment) (moment2 moment)) d@121: "Returns . The question makes no d@121: sense." d@136: (error 'undefined-action :operation 'time+ d@137: :datatype (list (class-of moment1) (class-of moment2)))) m@24: d@136: (defmethod time- ((moment1 standard-moment) (moment2 standard-moment)) d@136: "Returns with an onset at moment2 and d@136: extending to moment1" d@136: (make-standard-anchored-period (timepoint moment2) d@136: (- (timepoint moment1) d@136: (timepoint moment2)))) m@24: d@136: (defmethod time- ((moment standard-moment) (period standard-period)) d@136: "Returns . Simple subtraction." d@136: (make-standard-moment (- (timepoint moment) d@136: (duration period)))) m@24: d@136: (defmethod time- ((period period) (moment moment)) ;? d@121: "Returns . The question makes no d@121: sense" m@24: (error 'undefined-action m@24: :operation 'time- d@137: :datatype (list (class-of period) (class-of moment)))) m@24: d@136: (defmethod time- ((period1 standard-period) (period2 standard-period)) d@136: "Returns spanning the difference of the d@121: periods" d@136: (make-standard-period (- (duration period2) d@136: (duration period1)))) 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: d@136: (defmethod duration> ((period1 standard-period) (period2 standard-period)) d@136: (> (duration period1) (duration period2))) m@24: d@136: (defmethod duration= ((period1 standard-period) (period2 standard-period)) d@136: (= (duration period1) (duration period2))) m@24: d@136: (defmethod duration* ((period1 standard-period) (object2 number)) d@137: (make-standard-period (* (duration period1) object2))) m@24: d@136: (defmethod duration* ((object1 number) (period standard-period)) d@136: (duration* period object1)) m@24: d@136: (defmethod duration/ ((period standard-period) (object2 number)) d@137: (make-standard-period (/ (duration period) object2))) m@24: c@111: ;;;; Pitch protocol m@24: c@111: ;;; Some catch-all methods for undefined operations and cases where we c@111: ;;; don't have enough information: c@111: (macrolet ((def (name class1 class2) c@111: `(defmethod ,name ((object1 ,class1) (object2 ,class2)) c@111: (error 'undefined-action :operation ',name c@111: :datatype (list (class-of object1) (class-of object2)))))) d@136: (def pitch+ pitch pitch) d@136: (def pitch- pitch-interval pitch)) m@24: c@111: (macrolet ((def (name class1 class2) c@111: `(defmethod ,name ((object1 ,class1) (object2 ,class2)) c@111: (error 'insufficient-information :operation ',name c@111: :datatype (list (class-of object1) (class-of object2)))))) d@136: (def pitch+ pitch pitch-interval) d@136: (def pitch+ pitch-interval pitch) d@136: (def pitch+ pitch-interval pitch-interval) d@136: (def pitch- pitch pitch) d@136: (def pitch- pitch pitch-interval) d@136: (def pitch- pitch-interval pitch-interval)) m@24: c@111: ;;; chromatic pitch intervals m@24: c@111: (defmethod pitch+ ((object1 chromatic-pitch) c@111: (object2 chromatic-pitch-interval)) c@111: (make-chromatic-pitch (+ (midi-pitch-number object1) (span object2)))) c@111: c@111: (defmethod pitch+ ((object1 chromatic-pitch-interval) c@111: (object2 chromatic-pitch)) c@111: (make-chromatic-pitch (+ (span object1) (midi-pitch-number object2)))) c@111: c@111: (defmethod pitch+ ((object1 chromatic-pitch-interval) c@111: (object2 chromatic-pitch-interval)) c@105: (make-chromatic-pitch-interval (+ (span object1) (span object2)))) m@24: c@111: (defmethod pitch- ((object1 chromatic-pitch) c@111: (object2 chromatic-pitch)) c@111: (make-chromatic-pitch-interval c@105: (- (midi-pitch-number object1) (midi-pitch-number object2)))) m@24: c@111: (defmethod pitch- ((object1 chromatic-pitch) c@111: (object2 chromatic-pitch-interval)) c@105: (make-chromatic-pitch (- (midi-pitch-number object1) (span object2)))) m@24: c@111: (defmethod pitch- ((object1 chromatic-pitch-interval) c@111: (object2 chromatic-pitch-interval)) c@105: (make-chromatic-pitch-interval (- (span object1) (span object2)))) m@24: c@111: (defmethod pitch> ((object1 chromatic-pitch) c@111: (object2 chromatic-pitch)) c@111: (> (midi-pitch-number object1) (midi-pitch-number object2))) m@24: c@111: (defmethod pitch= ((object1 chromatic-pitch) c@111: (object2 chromatic-pitch)) c@111: (= (midi-pitch-number object1) (midi-pitch-number object2))) m@24: c@111: (defmethod interval> ((object1 chromatic-pitch-interval) c@111: (object2 chromatic-pitch-interval)) c@111: (> (span object1) (span object2))) m@24: c@111: (defmethod interval= ((object1 chromatic-pitch-interval) c@111: (object2 chromatic-pitch-interval)) c@111: (= (span object1) (span object2))) m@24: c@111: ;;; diatonic pitch intervals m@24: c@111: (defmethod pitch+ ((object1 diatonic-pitch) (object2 diatonic-pitch-interval)) c@111: (let* ((cp (%p-pc object1)) c@111: (mp (%p-pm object1)) c@111: (span (span object2)) c@111: (cps (first span)) c@111: (mps (second span))) c@111: (make-mips-pitch (+ cp cps) (+ mp mps)))) c@111: c@111: (defmethod pitch+ ((object1 diatonic-pitch-interval) (object2 diatonic-pitch)) c@111: (let* ((cp (%p-pc object2)) c@111: (mp (%p-pm object2)) c@111: (span (span object1)) c@111: (cps (first span)) c@111: (mps (second span))) c@111: (make-mips-pitch (+ cp cps) (+ mp mps)))) c@111: c@111: (defmethod pitch+ ((object1 diatonic-pitch-interval) c@111: (object2 diatonic-pitch-interval)) c@111: (let* ((span1 (span object1)) c@111: (span2 (span object2))) c@111: (make-mips-pitch-interval (+ (first span1) (first span2)) c@111: (+ (second span1) (second span2))))) c@111: c@111: (defmethod pitch- ((object1 diatonic-pitch) (object2 diatonic-pitch)) c@111: (let ((cp1 (%p-pc object1)) c@111: (mp1 (%p-pm object1)) c@111: (cp2 (%p-pc object2)) c@111: (mp2 (%p-pm object2))) c@111: (make-mips-pitch-interval (- cp1 cp2) (- mp1 mp2)))) c@111: c@111: (defmethod pitch- ((object1 diatonic-pitch) (object2 diatonic-pitch-interval)) c@111: (let* ((cp (%p-pc object1)) c@111: (mp (%p-pm object1)) c@111: (span (span object2)) c@111: (cps (first span)) c@111: (mps (second span))) c@111: (make-mips-pitch (- cp cps) (- mp mps)))) c@111: c@111: (defmethod pitch- ((object1 diatonic-pitch-interval) c@111: (object2 diatonic-pitch-interval)) c@111: (let ((span1 (span object1)) c@111: (span2 (span object2))) c@111: (make-mips-pitch-interval (- (first span1) (first span2)) c@111: (- (second span1) (second span2))))) c@111: c@111: (defmethod pitch> ((p1 diatonic-pitch) (p2 diatonic-pitch)) c@111: (error 'undefined-action :operation 'pitch> c@111: :datatype (list (class-of p1) (class-of p2)))) c@111: c@111: (defmethod pitch= ((p1 diatonic-pitch) (p2 diatonic-pitch)) c@111: (let ((c1 (%p-pc p1)) (m1 (%p-pm p1)) c@111: (c2 (%p-pc p2)) (m2 (%p-pm p2))) c@111: (and c1 c2 (= c1 c2) c@111: m1 m2 (= m1 m2)))) 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@136: (defmethod period= ((object1 period) d@136: (object2 period)) d@33: (duration= object1 object2)) d@33: d@136: (defmethod period-intersection ((object1 standard-anchored-period) d@136: (object2 standard-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: d@136: ;; Time constructors d@136: (defmethod make-moment ((time-value real)) d@136: "Returns STANDARD-MOMENT given a real" d@136: (make-standard-moment time-value)) d@136: (defmethod make-period ((duration-value real)) d@136: "Returns STANDARD-PERIOD given a real" d@136: (make-standard-period duration-value)) d@136: (defmethod make-anchored-period ((onset-value real) (duration-value real)) d@136: "Returns STANDARD-ANCHORED-PERIOD given a real" m@143: (make-standard-anchored-period onset-value duration-value)) d@151: d@151: ;; Needed by some sequence functions, notably remove-if. d@151: (defmethod sequence:make-sequence-like :around ((o standard-composition) length d@151: &key (initial-element nil iep) d@151: (initial-contents nil icp)) d@152: "Around method for make-sequence-like, only with all slots d@151: preserved from the source sequence (except onset and duration, d@151: which are calculated afresh)." d@151: (declare (ignore length initial-element initial-contents iep icp)) d@178: (let ((new-sequence (call-next-method)) (slot-name)) d@151: ;; Get timing information d@153: (setf new-sequence (%recompute-standard-composition-period new-sequence)) d@153: (dolist (slotd (sb-mop:class-slots (class-of new-sequence)) new-sequence) d@178: (setf slot-name (sb-mop:slot-definition-name slotd)) d@178: (unless (or (equal slot-name '%data) d@178: (equal slot-name 'time) d@178: (equal slot-name 'interval) d@178: (not (slot-boundp o slot-name))) d@153: (setf (sb-mop:slot-value-using-class (class-of new-sequence) d@153: new-sequence d@153: slotd) d@153: (sb-mop:slot-value-using-class (class-of new-sequence) d@153: o ;; if this isn't the same, we're lost anyway d@153: slotd)))))) d@153: d@153: (defun %recompute-standard-composition-period (composition) d@153: "Find onset and duration times for newly-made composition object." d@153: (let ((start) (finish)) d@153: (sequence:dosequence (element composition) d@151: ;; Actually, this next bit is pretty stupid - I know this is d@151: ;; ordered, so this bit could be replaced by d@151: ;; (setf (timepoint new-sequence) d@151: ;; (timepoint (elt new-sequence 0))) d@151: ;; outside of the loop. d@152: (when (and element d@152: (or (null start) d@152: (< (timepoint element) start))) d@152: (setf start (timepoint element))) d@152: (when (and element d@152: (or (null finish) d@152: (> (timepoint (cut-off element)) d@152: finish))) d@152: (setf finish (timepoint (cut-off element))))) d@152: (unless start d@152: (setf start 0)) d@152: (unless finish d@152: (setf finish 0)) d@153: (setf (timepoint composition) start d@153: (duration composition) (- finish start)) d@153: composition)) d@153: d@153: d@153: (defmethod sequence:adjust-sequence :around ((o standard-composition) length d@153: &key initial-element d@153: (initial-contents nil icp)) d@153: (declare (ignore length o initial-element initial-contents icp)) d@175: (%recompute-standard-composition-period (call-next-method))) d@175: j@284: (defmethod get-constituents ((identifier composition-identifier)) j@284: (list (get-composition identifier))) d@175: d@175: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; d@175: ;; d@175: ;; Experimental: d@175: ;; d@175: d@175: ;; Some not obviously correct implementations of the new metre d@175: ;; functions. These are no worse than we're already using (they should d@175: ;; be more or less equivalent) d@175: d@175: (defmethod bar-period ((time-signature standard-time-signature) d@175: object) d@175: (make-standard-period (* (duration (crotchet object)) d@175: (time-signature-numerator time-signature) d@175: (/ 4 (time-signature-denominator time-signature))))) d@175: d@175: (defmethod current-bar ((moment standard-moment) (composition composition)) d@175: (let* ((time-sig (car (get-applicable-time-signatures d@175: (make-standard-anchored-period (timepoint moment) d@175: (duration (crotchet composition))) d@175: composition))) d@175: (bar-duration (bar-period time-sig composition))) d@175: (do* ((start (onset time-sig) next-start) d@175: (next-start (time+ start bar-duration) (time+ start bar-duration))) d@175: ((time> next-start moment) d@175: (make-standard-anchored-period (timepoint start) d@175: (duration bar-duration)))))) d@175: j@307: (defmethod ioi-from-bar ((event event)) j@307: (- (timepoint (onset event)) j@307: (timepoint (current-bar event (composition event))))) j@307: j@307: (defmethod ioi-from-bar ((constituent constituent)) j@307: (- (timepoint (onset constituent)) j@307: (timepoint (current-bar constituent constituent)))) j@307: j@307: (defmethod onset-in-bar ((o moment)) j@307: (1+ (ioi-from-bar o))) j@307: d@175: (defmethod beat-period ((moment standard-moment) d@175: (time-signature standard-time-signature) d@175: (composition composition)) d@175: ;; Simple example - standard-time-signature has constant tactus d@175: (let* ((containing-bar (current-bar moment composition)) d@175: (beat-duration (* (duration (crotchet composition)) d@175: (tactus-duration time-signature))) d@175: (beat-period (make-standard-anchored-period (timepoint containing-bar) d@175: beat-duration))) d@175: (do () d@175: ((time> (cut-off beat-period) moment) beat-period) d@175: (setf (timepoint beat-period) (timepoint (cut-off beat-period)))))) d@175: d@175: (defmethod current-beat ((moment standard-moment) (composition composition)) d@175: ;; Assume at most one time signature per bar (otherwise, this is hell) d@175: (let* ((time-sig (car (get-applicable-time-signatures (current-bar moment composition) composition)))) d@175: (if time-sig d@175: (beat-period moment time-sig composition) d@175: ;; If no time-sig, there's no way of answering this d@175: ;; directly. There may be sensible defaults, but it's the job d@175: ;; of an implementation's author to solve that. d@175: (error 'insufficient-information :operation 'beat-period :datatype (class-of composition))))) d@175: j@276: j@320: ;;;===================================================================== j@304: ;;; Copying events in time j@320: ;;;===================================================================== j@276: j@276: (defmethod move-to-first-bar ((composition composition)) j@300: (let ((offset (floor (timepoint (elt composition 0))))) j@276: (loop j@277: for event in (%list-slot-sequence-data composition) j@276: do (setf event (copy-event event)) j@276: do (setf (timepoint event) j@276: (- (timepoint event) offset)) j@276: collect event into shifted-events j@276: finally (return shifted-events)))) j@304: j@304: j@320: ;;;===================================================================== j@304: ;;; Searching for events j@320: ;;;===================================================================== j@304: j@304: (defmethod find-next-event ((source-event event) &key predicate test j@304: break-test search-list) j@304: "Ideally a sorted search list that begins with the first event after j@304: the source-event should be provided, otherwise, the search will begin j@304: from the beginning." j@304: (unless search-list (setf search-list (composition source-event))) j@304: (cond j@304: ((and test predicate) j@304: (error "Supplied both a test and a predicate.")) j@304: (test j@304: (sequence:dosequence (e search-list nil) j@304: (when (and (time> (onset e) (onset source-event)) j@304: (funcall test source-event e)) j@304: (return e)) j@304: (when break-test j@304: (when (funcall break-test source-event e) j@304: (return nil))))) j@304: (predicate j@304: (sequence:dosequence (e search-list nil) j@304: (when (and (time> (onset e) (onset source-event)) j@304: (funcall predicate e)) j@304: (return e)) j@304: (when break-test j@304: (when (funcall break-test source-event e) j@304: (return nil))))))) j@304: j@304: j@320: ;;;===================================================================== j@304: ;;; Sorting Compositions j@320: ;;;===================================================================== j@304: j@304: (defmethod event< ((event1 event) (event2 event) attribute-list) j@304: (dolist (attribute attribute-list nil) ;nil if equal j@304: (if (< (funcall attribute event1) (funcall attribute event2)) j@304: (return t) j@304: (if (> (funcall attribute event1) (funcall attribute event2)) j@304: (return nil))))) j@304: j@304: (defun make-event< (attribute-list) j@304: (lambda (event1 event2) j@304: (funcall #'event< event1 event2 attribute-list))) j@304: j@304: (defmethod sort-composition ((composition composition) dimension-spec) j@304: (sequence:make-sequence-like composition j@304: (length composition) j@304: :initial-contents j@304: (stable-sort j@304: (copy-seq composition) j@304: (make-event< dimension-spec))))