Mercurial > hg > amuse

(cl:in-package #:amuse)

;;; monody

(defmethod ensure-monody ((m standard-monody))
  (let ((result t))
    (dotimes (i (1- (length m)) result)
      ;; assumes the events are time ordered which (since monody is a
      ;; subclass of time-ordered-constituent) they ought to be.
      (let ((e1 (elt m i))
            (e2 (elt m (1+ i))))
        (unless (or (before e1 e2) (meets e1 e2))
          (setf result nil))))))

;;; diatonic pitch (represented using MIPS)

(defmethod asa-pitch-string ((mp diatonic-pitch))
  (mips:p-pn (list (%p-pc mp) (%p-pm mp))))

(defmethod diatonic-pitch-octave ((mp diatonic-pitch))
  (let* ((asa-string (asa-pitch-string mp))
         (start (position-if #'digit-char-p asa-string)))
    (values (parse-integer asa-string :start start))))

(defmethod diatonic-pitch-accidental ((mp diatonic-pitch))
  (let* ((asa-string (asa-pitch-string mp))
         (start 1)
         (end (position-if #'digit-char-p asa-string))
         (malist '((#\n . 0) (#\s . +1) (#\f . -1)))
         (multiplier (cdr (assoc (char asa-string 1) malist))))
    (* multiplier (- end start))))

(defmethod diatonic-pitch-name ((mp diatonic-pitch))
  (elt (asa-pitch-string mp) 0))

(defmethod middle-c ((mp diatonic-pitch))
  (make-diatonic-pitch #\C 0 4))

(defmethod midi-pitch-number ((mp diatonic-pitch))
  (+ (%p-pc mp) 21))

(defmethod octave ((mp diatonic-pitch))
  (1- (floor (midi-pitch-number mp) 12)))

(defmethod diatonic-pitch ((mp diatonic-pitch))
  mp)

(defmethod print-object ((o diatonic-pitch) stream)
  (print-unreadable-object (o stream :type t)
    (let ((asa-string (asa-pitch-string o)))
      (write asa-string :stream stream))))

(defmethod asa-interval-string ((mpi diatonic-pitch-interval))
  (mips:pi-pin (%diatonic-pitch-interval-span mpi)))

(defmethod print-object ((o diatonic-pitch-interval) stream)
  (print-unreadable-object (o stream :type t)
    (let ((asa-string (asa-interval-string o)))
      (write asa-string :stream stream))))

;;; Chromatic pitch

(defmethod octave ((cp chromatic-pitch))
  (1- (floor (%chromatic-pitch-number cp) 12)))

(defmethod middle-c ((cp chromatic-pitch))
  (make-chromatic-pitch 60))

(defmethod chromatic-pitch ((pitch chromatic-pitch))
  pitch)

(defmethod midi-pitch-number ((pitch chromatic-pitch))
  (%chromatic-pitch-number pitch))

(defmethod midi-pitch-number ((pitch pitch))
  (%chromatic-pitch-number (chromatic-pitch pitch)))

(defmethod print-object ((o chromatic-pitch) stream)
  (print-unreadable-object (o stream :type t)
    (write (midi-pitch-number o) :stream stream)))

(defmethod print-object ((o chromatic-pitch-interval) stream)
  (print-unreadable-object (o stream :type t)
    (write (span o) :stream stream)))


(defmethod span ((pitch-interval chromatic-pitch-interval))
  (%chromatic-pitch-interval-span pitch-interval))

(defmethod duration ((period standard-period))
  (%period-interval period))

(defmethod (setf duration) ((value real) (period standard-period))
  (setf (%period-interval period) value))

(defmethod timepoint ((moment standard-moment))
  (%moment-time moment))

(defmethod (setf timepoint) ((value real) (moment standard-moment))
  (setf (%moment-time moment) value))

(defmethod cut-off ((anchored-period standard-anchored-period))
  (make-instance 'standard-moment
		 :time (+ (%moment-time anchored-period)
			  (%period-interval anchored-period))))

(defmethod print-object ((o standard-moment) stream)
  (print-unreadable-object (o stream :type t)
    (write (timepoint o) :stream stream)))

(defmethod print-object ((o standard-period) stream)
  (print-unreadable-object (o stream :type t)
    (write (duration o) :stream stream)))

(defmethod print-object ((o standard-anchored-period) stream)
  (print-unreadable-object (o stream :type t)
    (format stream "~A ~A" (timepoint o) (duration o))))

(defmethod beat-units-per-bar ((time-signature standard-time-signature))
  (%basic-time-signature-numerator time-signature))

(defmethod beat-units ((time-signature standard-time-signature))
  (%basic-time-signature-denominator time-signature))

(defmethod time-signature-equal ((ts1 standard-time-signature)
                                 (ts2 standard-time-signature))
  (let ((n1 (time-signature-numerator ts1))
        (n2 (time-signature-numerator ts2))
        (d1 (time-signature-denominator ts1))
        (d2 (time-signature-denominator ts2)))
    (and n1 n2 (= n1 n2)
         d1 d2 (= d1 d2))))

(defmethod print-object ((sts standard-time-signature) stream)
  (print-unreadable-object (sts stream :type t)
    (format stream "~A/~A" (beat-units-per-bar sts) (beat-units sts))))

(defmethod key-signature-sharps ((key-signature standard-key-signature))
  (%basic-key-signature-sharp-count key-signature))

(defmethod key-signature-mode ((ks midi-key-signature))
  (%midi-key-signature-mode ks))

(defmethod print-object ((mks midi-key-signature) stream)
  (print-unreadable-object (mks stream :type t)
    (format stream "~A ~A"
            (%basic-key-signature-sharp-count mks)
            (%midi-key-signature-mode mks))))

(defmethod key-signature-equal ((ks1 standard-key-signature)
                                (ks2 standard-key-signature))
  (let ((s1 (key-signature-sharps ks1))
        (s2 (key-signature-sharps ks2)))
    (and s1 s2 (= s1 s2))))

(defmethod key-signature-equal ((ks1 midi-key-signature)
                                (ks2 midi-key-signature))
  (let ((s1 (key-signature-sharps ks1))
        (s2 (key-signature-sharps ks2))
        (m1 (key-signature-mode   ks1))
        (m2 (key-signature-mode   ks2)))
    (and s1 s2 (= s1 s2)
         m1 m2 (= m1 m2))))

(defmethod bpm ((tempo standard-tempo))
  (%tempo-bpm tempo))

(defmethod print-object ((tempo standard-tempo) stream)
  (print-unreadable-object (tempo stream :type t)
    (write (bpm tempo) :stream stream)))

(defmethod tempo-equal ((t1 tempo) (t2 tempo))
  (and (bpm t1) (bpm t2) (= t1 t2)))


;; Time protocol

(defmethod time+ ((moment standard-moment) (period standard-period))
  "Returns a <standard-moment>. Implemented as a straightforward
summation."
  (make-standard-moment (+ (timepoint moment) (duration period))))

(defmethod time+ ((period standard-period) (moment standard-moment)) ;?
  "Returns a <standard-moment>. Implemented as a straightforward
summation and defined by default as (time+ <moment> <period>)."
  (time+ moment period))

(defmethod time+ ((period1 standard-period)
		  (period2 standard-period))
  "Returns a <standard-period>. Implemented as a straightforward
summation."
  (make-standard-period (+ (duration period1)
			   (duration period2))))

(defmethod time+ ((moment1 moment) (moment2 moment))
  "Returns <condition:undefined-action>. The question makes no
sense."
  (error 'undefined-action :operation 'time+
	 :datatype (list (class-of moment1) (class-of moment2))))

(defmethod time- ((moment1 standard-moment) (moment2 standard-moment))
  "Returns <standard-anchored-period> with an onset at moment2 and
  extending to moment1"
  (make-standard-anchored-period (timepoint moment2)
				 (- (timepoint moment1)
				    (timepoint moment2))))

(defmethod time- ((moment standard-moment) (period standard-period))
  "Returns <standard-moment>. Simple subtraction."
  (make-standard-moment (- (timepoint moment)
			   (duration period))))

(defmethod time- ((period period) (moment moment)) ;?
  "Returns <condition:undefined-action>. The question makes no
sense"
  (error 'undefined-action
	 :operation 'time-
	 :datatype (list (class-of period) (class-of moment))))

(defmethod time- ((period1 standard-period) (period2 standard-period))
  "Returns <standard-period> spanning the difference of the
periods"
  (make-standard-period (- (duration period2)
			   (duration period1))))

;; 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 time= ((object1 moment) (object2 moment))
  (= (timepoint object1) (timepoint object2)))

(defmethod duration> ((period1 standard-period) (period2 standard-period))
  (> (duration period1) (duration period2)))

(defmethod duration= ((period1 standard-period) (period2 standard-period))
  (= (duration period1) (duration period2)))

(defmethod duration* ((period1 standard-period) (object2 number))
  (make-standard-period (* (duration period1) object2)))

(defmethod duration* ((object1 number) (period standard-period))
  (duration* period object1))

(defmethod duration/ ((period standard-period) (object2 number))
  (make-standard-period (/ (duration period) object2)))

;;;; Pitch protocol

;;; Some catch-all methods for undefined operations and cases where we
;;; don't have enough information:
(macrolet ((def (name class1 class2)
             `(defmethod ,name ((object1 ,class1) (object2 ,class2))
               (error 'undefined-action :operation ',name
                :datatype (list (class-of object1) (class-of object2))))))
  (def pitch+ pitch pitch)
  (def pitch- pitch-interval pitch))

(macrolet ((def (name class1 class2)
             `(defmethod ,name ((object1 ,class1) (object2 ,class2))
               (error 'insufficient-information :operation ',name
                :datatype (list (class-of object1) (class-of object2))))))
  (def pitch+ pitch pitch-interval)
  (def pitch+ pitch-interval pitch)
  (def pitch+ pitch-interval pitch-interval)
  (def pitch- pitch pitch)
  (def pitch- pitch pitch-interval)
  (def pitch- pitch-interval pitch-interval))

;;; chromatic pitch intervals

(defmethod pitch+ ((object1 chromatic-pitch)
		   (object2 chromatic-pitch-interval))
  (make-chromatic-pitch (+ (midi-pitch-number object1) (span object2))))

(defmethod pitch+  ((object1 chromatic-pitch-interval)
		    (object2 chromatic-pitch))
  (make-chromatic-pitch (+ (span object1) (midi-pitch-number object2))))

(defmethod pitch+ ((object1 chromatic-pitch-interval)
		   (object2 chromatic-pitch-interval))
  (make-chromatic-pitch-interval (+ (span object1) (span object2))))

(defmethod pitch- ((object1 chromatic-pitch)
                   (object2 chromatic-pitch))
  (make-chromatic-pitch-interval
   (- (midi-pitch-number object1) (midi-pitch-number object2))))

(defmethod pitch- ((object1 chromatic-pitch)
                   (object2 chromatic-pitch-interval))
  (make-chromatic-pitch (- (midi-pitch-number object1) (span object2))))

(defmethod pitch- ((object1 chromatic-pitch-interval)
		   (object2 chromatic-pitch-interval))
  (make-chromatic-pitch-interval (- (span object1) (span object2))))

(defmethod pitch> ((object1 chromatic-pitch)
		   (object2 chromatic-pitch))
  (> (midi-pitch-number object1) (midi-pitch-number object2)))

(defmethod pitch= ((object1 chromatic-pitch)
		   (object2 chromatic-pitch))
  (= (midi-pitch-number object1) (midi-pitch-number object2)))

(defmethod interval> ((object1 chromatic-pitch-interval)
                      (object2 chromatic-pitch-interval))
  (> (span object1) (span object2)))

(defmethod interval= ((object1 chromatic-pitch-interval)
                      (object2 chromatic-pitch-interval))
  (= (span object1) (span object2)))

;;; diatonic pitch intervals

(defmethod pitch+ ((object1 diatonic-pitch) (object2 diatonic-pitch-interval))
  (let* ((cp (%p-pc object1))
         (mp (%p-pm object1))
         (span (span object2))
         (cps (first span))
         (mps (second span)))
    (make-mips-pitch (+ cp cps) (+ mp mps))))

(defmethod pitch+ ((object1 diatonic-pitch-interval) (object2 diatonic-pitch))
  (let* ((cp (%p-pc object2))
         (mp (%p-pm object2))
         (span (span object1))
         (cps (first span))
         (mps (second span)))
    (make-mips-pitch (+ cp cps) (+ mp mps))))

(defmethod pitch+ ((object1 diatonic-pitch-interval)
		   (object2 diatonic-pitch-interval))
  (let* ((span1 (span object1))
         (span2 (span object2)))
    (make-mips-pitch-interval (+ (first span1) (first span2))
                              (+ (second span1) (second span2)))))

(defmethod pitch- ((object1 diatonic-pitch) (object2 diatonic-pitch))
  (let ((cp1 (%p-pc object1))
        (mp1 (%p-pm object1))
        (cp2 (%p-pc object2))
        (mp2 (%p-pm object2)))
    (make-mips-pitch-interval (- cp1 cp2) (- mp1 mp2))))

(defmethod pitch- ((object1 diatonic-pitch) (object2 diatonic-pitch-interval))
  (let* ((cp (%p-pc object1))
         (mp (%p-pm object1))
         (span (span object2))
         (cps (first span))
         (mps (second span)))
    (make-mips-pitch (- cp cps) (- mp mps))))

(defmethod pitch- ((object1 diatonic-pitch-interval)
		   (object2 diatonic-pitch-interval))
  (let ((span1 (span object1))
        (span2 (span object2)))
    (make-mips-pitch-interval (- (first span1) (first span2))
                              (- (second span1) (second span2)))))

(defmethod pitch> ((p1 diatonic-pitch) (p2 diatonic-pitch))
  (error 'undefined-action :operation 'pitch>
         :datatype (list (class-of p1) (class-of p2))))

(defmethod pitch= ((p1 diatonic-pitch) (p2 diatonic-pitch))
  (let ((c1 (%p-pc p1)) (m1 (%p-pm p1))
        (c2 (%p-pc p2)) (m2 (%p-pm p2)))
    (and c1 c2 (= c1 c2)
         m1 m2 (= m1 m2))))


;; 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))
  (or (and (time> object1 object2)
	   (time<= (cut-off object1) (cut-off object2)))
      (and (time>= object1 object2)
	   (time< (cut-off object1) (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= ((object1 anchored-period)
                    (object2 anchored-period))
  (and (time= object1 object2)
       (duration= object1 object2)))
(defmethod period= ((object1 period)
		    (object2 period))
  (duration= object1 object2))

(defmethod period-intersection ((object1 standard-anchored-period)
				(object2 standard-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)))))

;; Time constructors
(defmethod make-moment ((time-value real))
  "Returns STANDARD-MOMENT given a real"
  (make-standard-moment time-value))
(defmethod make-period ((duration-value real))
  "Returns STANDARD-PERIOD given a real"
  (make-standard-period duration-value))
(defmethod make-anchored-period ((onset-value real) (duration-value real))
  "Returns STANDARD-ANCHORED-PERIOD given a real"
  (make-standard-anchored-period onset-value duration-value))

;; Needed by some sequence functions, notably remove-if.
(defmethod sequence:make-sequence-like :around ((o standard-composition) length
						&key (initial-element nil iep)
						(initial-contents nil icp))
  "Around method for make-sequence-like, only with all slots
  preserved from the source sequence (except onset and duration,
  which are calculated afresh)."
  (declare (ignore length initial-element initial-contents iep icp))
  (let ((new-sequence (call-next-method)) (slot-name))
    ;; Get timing information
    (setf new-sequence (%recompute-standard-composition-period new-sequence))
    (dolist (slotd (sb-mop:class-slots (class-of new-sequence)) new-sequence)
      (setf slot-name (sb-mop:slot-definition-name slotd))
      (unless (or (equal slot-name '%data)
               (equal slot-name 'time)
               (equal slot-name 'interval)
               (not (slot-boundp o slot-name)))
        (setf (sb-mop:slot-value-using-class (class-of new-sequence)
					     new-sequence
					     slotd)
              (sb-mop:slot-value-using-class (class-of new-sequence)
                                             o ;; if this isn't the same, we're lost anyway
                                             slotd))))))

(defun %recompute-standard-composition-period (composition)
  "Find onset and duration times for newly-made composition object."
  (let ((start) (finish))
    (sequence:dosequence (element composition)
      ;; Actually, this next bit is pretty stupid - I know this is
      ;; ordered, so this bit could be replaced by
      ;; (setf (timepoint new-sequence)
      ;;    (timepoint (elt new-sequence 0)))
      ;; outside of the loop.
      (when (and element
                 (or (null start)
                     (< (timepoint element) start)))
        (setf start (timepoint element)))
      (when (and element
                 (or (null finish)
                     (> (timepoint (cut-off element))
                        finish)))
        (setf finish (timepoint (cut-off element)))))
    (unless start
      (setf start 0))
    (unless finish
      (setf finish 0))
    (setf (timepoint composition) start
          (duration composition) (- finish start))
    composition))


(defmethod sequence:adjust-sequence :around ((o standard-composition) length
                                             &key initial-element
                                             (initial-contents nil icp))
  (declare (ignore length o initial-element initial-contents icp))
  (%recompute-standard-composition-period (call-next-method)))

(defmethod get-constituents ((identifier composition-identifier))
  (list (get-composition identifier)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Experimental:
;;

;; Some not obviously correct implementations of the new metre
;; functions. These are no worse than we're already using (they should
;; be more or less equivalent)

(defmethod bar-period ((time-signature standard-time-signature)
                       object)
  (make-standard-period (* (duration (crotchet object))
                           (time-signature-numerator time-signature)
                           (/ 4 (time-signature-denominator time-signature)))))

(defmethod current-bar ((moment standard-moment) (composition composition))
  (let* ((time-sig (car (get-applicable-time-signatures
                         (make-standard-anchored-period (timepoint moment)
                                                        (duration (crotchet composition)))
                         composition)))
         (bar-duration (bar-period time-sig composition)))
    (do* ((start (onset time-sig) next-start)
          (next-start (time+ start bar-duration) (time+ start bar-duration)))
         ((time> next-start moment)
          (make-standard-anchored-period (timepoint start)
                                         (duration bar-duration))))))

(defmethod beat-period ((moment standard-moment)
                        (time-signature standard-time-signature)
                        (composition composition))
  ;; Simple example - standard-time-signature has constant tactus
  (let* ((containing-bar (current-bar moment composition))
         (beat-duration (* (duration (crotchet composition))
                           (tactus-duration time-signature)))
         (beat-period (make-standard-anchored-period (timepoint containing-bar)
                                                     beat-duration)))
    (do ()
        ((time> (cut-off beat-period) moment) beat-period)
      (setf (timepoint beat-period) (timepoint (cut-off beat-period))))))

(defmethod current-beat ((moment standard-moment) (composition composition))
  ;; Assume at most one time signature per bar (otherwise, this is hell)
  (let* ((time-sig (car (get-applicable-time-signatures (current-bar moment composition) composition))))
    (if time-sig
        (beat-period moment time-sig composition)
        ;; If no time-sig, there's no way of answering this
        ;; directly. There may be sensible defaults, but it's the job
        ;; of an implementation's author to solve that.
        (error 'insufficient-information :operation 'beat-period :datatype (class-of composition)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Copying events in time

(defmethod move-to-first-bar ((composition composition))
  (let ((offset (floor (timepoint (elt composition 0)))))
    (loop
       for event in (%list-slot-sequence-data composition)
       do (setf event (copy-event event))
       do (setf (timepoint event)
		(- (timepoint event) offset))
       collect event into shifted-events
       finally (return shifted-events))))
author	j.forth <j.forth@gold.ac.uk>
date	Thu, 24 Feb 2011 11:23:18 +0000
parents	1c58a18161b6
children	32b40c50075e