m@23: ;;; General purpose utilities 
m@23: 
m@23: (cl:in-package #:amuse-utils) 
m@23: 
d@33: ;; Booleans (for filters)
d@33: (defgeneric pitchedp (event)
d@33:   (:method (e) (declare (ignore e)) nil))
d@33: (defmethod pitchedp ((event amuse:pitched-event))
d@33:   T)
d@33: (defgeneric unpitchedp (event)
d@33:   (:method (e) (not (pitchedp e))))
d@33: 
d@33: ;; Rhythm methods
d@134: (defgeneric crotchets-in-a-bar (time-signature)
d@134:   (:documentation "Convenient function for finding the number of
d@134:   crotchet beats in a bar based on the provided
d@134:   time-signature. It should be borne in mind that this needn't be
d@134:   an integer - a time signature of 3/8, for example, should yield
d@134:   an answer of 3/2"))
d@136: (defmethod crotchets-in-a-bar ((time-signature standard-time-signature))
d@33:   (let ((num (time-signature-numerator time-signature))
d@33: 	(den (time-signature-denominator time-signature)))
d@33:     (* num (/ 4 den))))
d@33: 
d@36: (defgeneric beats-to-seconds (object1 object2))
d@136: (defmethod beats-to-seconds ((object1 standard-anchored-period)
d@36: 			     (object2 constituent))
d@74:   (let ((tempi (or (get-applicable-tempi object1 object2)
d@74: 		   (signal 'undefined-action
d@74: 			   :operation 'beats-to-seconds
d@74: 			   :datatype 'constituent)))
d@36: 	(s 0))
d@36:     (dolist (tempo tempi (/ s 1000000))
d@120:       (incf s (if (disjoint tempo object1)
d@120: 		  0
d@136: 		  (* (/ (duration (period-intersection tempo object1))
m@144: 			(duration (crotchet object2)))
d@120: 		     (amuse:microseconds-per-crotchet tempo)))))))
d@136: (defmethod beats-to-seconds ((object1 standard-moment)
d@36: 			     (object2 constituent))
d@120:   (beats-to-seconds (time- (onset object1)
d@136: 			   (make-standard-moment 0))
d@36: 		    object2))
d@36: 					  
d@33: ;; Not as simple as it seems - have to take into account numbering
d@33: ;; practices and leading silences in representations where bar number
d@33: ;; isn't part of the explicit structure.
d@134: (defgeneric bar-number (moment composition)
d@134:   (:documentation "Returns the bar number of moment in
d@134:   composition. N.B. Although this will be a designated value in
d@134:   some, particularly score-based, implementations, it will be a
d@134:   derived value in others, particularly midi, where it may be
d@134:   necessary to take into account numbering practices and leading
d@134:   silences."))
d@134: (defgeneric bar-onset (bar-number composition)
d@134:   (:documentation "Returns a moment for the beginning of the bar
d@134:   with the given bar-number. Cautions about bar numbering as
d@134:   given in the bar-number documentation apply here also."))
d@33: 
d@36: (defgeneric bass-note (anchored-period composition))
d@36: 
d@37: 
d@37: (defun levenshtein-distance (s1 s2 &key (insertion-cost 1)
d@37: 			  (insertion-function) (deletion-cost 1)
d@37: 			  (deletion-function) (substitution-cost 1)
d@37: 			  (substitution-test #'equal) (substitution-function))
d@37:   ;; This is an implementation of the Levenshtein distance measure
d@37:   ;; based on the cliki asdf package, itself based on the wikipedia
d@37:   ;; scheme example of the same algorithm. This version is generalised
d@37:   ;; such that operations costs may take constant or calculated
d@37:   ;; values. If insertion-function, deletion-function or
d@37:   ;; substitution-test are specified, the applicable cost values are
d@37:   ;; ignored and the function output is used instead.
d@37:   (let* ((width (1+ (length s1)))
d@37: 	 (height (1+ (length s2)))
d@37: 	 (d (make-array (list height width))))
d@37:     (dotimes (x width)
d@37:       (setf (aref d 0 x) (* x deletion-cost)))
d@37:     (dotimes (y height)
d@37:       (setf (aref d y 0) (* y insertion-cost)))
d@37:     (dotimes (x (length s1))
d@37:       (dotimes (y (length s2))
d@37: 	(setf (aref d (1+ y) (1+ x))
d@37: 	      (min (+ (if insertion-function
d@37: 			  (apply insertion-function (elt s1 x))
d@37: 			  insertion-cost)
d@37: 		      (aref d y (1+ x)))
d@37: 		   (+ (if deletion-function
d@37: 			  (apply deletion-function (elt s2 y))
d@37: 			  deletion-cost)
d@37: 		      (aref d (1+ y) x))
d@37: 		   (+ (aref d y x)
d@37: 		      (if substitution-function
d@37: 			  (apply substitution-function (list (elt s1 x) (elt s2 y)))
d@37: 			  (if (apply substitution-test (list (elt s1 x) (elt s2 y)))
d@37: 			      0
d@37: 			      substitution-cost)))))))
d@41:     (aref d (1- height) (1- width))))
d@41: 
d@41: ;;;;;;;;;;;;;;;;;;;;;;
d@41: ;;
d@41: ;; More experimental (from amuse-geerdes)
d@41: ;;
d@41: ;; Monody functions
d@41: 
d@41: (defun monodificate (composition)
d@41:   (let ((events-bags) (latest-cut-off))
d@41:   ;; - Filter out very short notes (<50ms) 
d@41:   ;; - If there are notes with the same onset time or a large
d@41:   ;;   proportion (e.g. >25%) of the notes in the segment have
d@41:   ;;   overlapping durations (of >75%), do for every simultaneous or
d@41:   ;;   overlapping pair of notes
d@41:   ;; -- if one note is louder than the other note (e.g. quieter note
d@41:   ;;    <75% of louder one) select it as melody note
d@41:   ;; -- else select note with higher pitch
d@41:   ;; [FIXME: I'm ignoring overlaps for the time being]
d@41:   ;; - For non-simultaneous notes with little overlap, set note ends
d@41:   ;;   to beginning of of onset of next (overlapping) note.
d@41: 
d@41:   ;; STEP 1: 
d@41:   ;; `Filter out very short notes (<50ms)' and find `segments' for
d@41:   ;; further filtering.
d@41:     (sequence::dosequence (event composition)
d@41:       (when (> (beats-to-seconds event composition)
d@41: 	       1/20)
d@41: 	(if (or (not latest-cut-off)
d@41: 		(time> (onset event) latest-cut-off))
d@41: 	    (push (list event) events-bags)
d@41: 	    (push event (car events-bags)))
d@41: 	(when (or (not latest-cut-off)
d@41: 		  (time> (cut-off event) latest-cut-off))
d@41: 	  (setf latest-cut-off (cut-off event)))))
d@41:     ;; Now check each segment for overlaps and
d@41:     ;; simultanaieties. N.B. this is a reverse list of reversed
d@41:     ;; lists.
d@41:     (let ((adjusted-bags))
d@41:       (dolist (events-bag events-bags)
d@41: 	(setf events-bag (reverse events-bag))
d@41: 	(let ((polyphonic-p (check-events-bag-for-polyphony events-bag)))
d@41: 	  (cond
d@41: 	    (polyphonic-p
d@41: 	     (push (resolve-polyphony events-bag composition) adjusted-bags))
d@41: 	    (t
d@41: 	     (if (cdr events-bag)		   
d@41: 		 (push (adjust-durations events-bag) adjusted-bags)
d@41: 		 (push events-bag adjusted-bags))))))
d@41:       (apply #'nconc adjusted-bags))))
d@41: 
d@41: (defun resolve-polyphony (event-list composition)
d@41:   (do ((i 0 (1+ i)))
d@41:       ((>= i (length event-list)) event-list)
d@41:     (let ((event (nth i event-list)))
d@41:       (do ((j (1+ i) (1+ j)))
d@41: 	  ((or (>= j (length event-list))
d@41: 	       (time>= (onset (nth j event-list))
d@41: 		       (cut-off event))))
d@41: 	(let* ((event-2 (nth j event-list))
d@41: 	       (inter-onset (time- (onset event-2) (onset event))))
d@41: 	  (cond
d@41: 	    ((and inter-onset
d@41: 		  (< (* 2 (duration inter-onset))
d@41: 		      (duration event))
d@41: 		  (< (* 2 (duration inter-onset))
d@41: 		      (duration event-2))
d@41: 		  (< (beats-to-seconds inter-onset composition)
d@41: 		      1/8))
d@41: 	     ;; This is clearly polyphony
d@41: 	     (cond
d@41: 	       ((significantly-louderp event-2 event)
d@41: 		;; Take event-2
d@41: 		(setf event-list (remove event event-list))
d@41: 		(decf i)
d@41: 		(return))
d@41: 	       ((significantly-louderp event event-2)
d@41: 		;; Take event
d@41: 		(setf event-list (remove event-2 event-list))
d@41: 		(decf j))
d@41: 	       ((pitch> event event-2)
d@41: 		;; Take event
d@41: 		(setf event-list (remove event-2 event-list))
d@41: 		(decf j))
d@41: 	       (t
d@41: 		;; Take event-2
d@41: 		(setf event-list (remove event event-list))
d@41: 		(decf i)
d@41: 		(return))))
d@41: 	    (t
d@41: 	     (cond
d@41: 	       ((substantially-louderp event-2 event)
d@41: 		;; Take event-2
d@41: 		(setf event-list (remove event event-list))
d@41: 		(decf i)
d@41: 		(return))
d@41: 	       ((substantially-louderp event event-2)
d@41: 		;; Take event
d@41: 		(setf event-list (remove event-2 event-list))
d@41: 		(decf j))
d@41: 	       (t
d@41: 		;; Take both
d@41: 		(let ((event-overlap (period-intersection event event-2)))
d@41: 		  (when event-overlap
d@41: 		    (setf (duration event)
d@41: 			  (duration (time- event-overlap event))))))))))))))
d@41: 
d@41: (defgeneric significantly-louderp (event1 event2)
d@41:   ;; noticably louder
d@41:   (:method (e1 e2) (declare (ignore e1 e2)) nil))
d@41: 
d@41: (defgeneric substantially-louderp (event1 event2)
d@41:   ;; much louder
d@41:   (:method (e1 e2) (declare (ignore e1 e2)) nil))
d@41: 
d@41: (defun adjust-durations (events-list)
d@41:   (do* ((old-list events-list (cdr old-list))
d@41: 	(event (first old-list) (first old-list))
d@41: 	(event-2 (second old-list) (second old-list)))
d@41:        ((not event-2) events-list)
d@41:     (let ((event-overlap (period-intersection event event-2)))
d@41:       (when event-overlap
d@41: 	(setf (duration event)
d@41: 	      (duration (time- event-overlap event)))))))
d@41: 
d@41: (defun check-events-bag-for-polyphony (events-bag)
d@41:   (let ((overlaps (make-array (length events-bag) :initial-element nil)))
d@41:     (when (= (length events-bag) 1)
d@41:       ;; obviously no overlaps
d@41:       (return-from check-events-bag-for-polyphony nil))
d@41:     (unless (= (length (remove-duplicates events-bag :test #'time=))
d@41: 	       (length events-bag))
d@41:       ;; Duplicated onsets
d@41:       (return-from check-events-bag-for-polyphony 'T))
d@41:     ;; Now for the main bit
d@41:     (do* ((events events-bag (cdr events))
d@41: 	  (i 0 (1+ i))
d@41: 	  (event (car events) (car events)))
d@41: 	 ((null (cdr events)))
d@41:       (unless (and (aref overlaps i)
d@41: 		   (= (aref overlaps i) 1))
d@41: 	;; Would mean we already have a maximal value
d@41: 	;; and don't need any more checks
d@41: 	(do* ((events-2 (cdr events) (cdr events-2))
d@41: 	      (j (1+ i) (1+ j))
d@41: 	      (event-2 (car events-2) (car events-2)))
d@41: 	     ((null events-2))
d@41: 	  (when (time>= (onset event-2) (cut-off event))
d@41: 	    ;; So no more overlaps
d@41: 	    (return))
d@41: 	  (let ((shorter (if (duration< event event-2)
d@41: 			     i
d@41: 			     j))
d@41: 		(overlap (/ (duration (period-intersection event event-2))
d@41: 			    (min (duration event) (duration event-2)))))
d@41: 	    ;; only look at pairings for the shorter note. This can
d@41: 	    ;; have odd side effects, but means we never
d@41: 	    ;; under-represent an overlap (I think)
d@132: 	    (when (>= overlap 3/4)
d@132: 	      (return-from check-events-bag-for-polyphony T))
d@41: 	    (when (or (not (aref overlaps shorter))
d@41: 		      (>= overlap (aref overlaps shorter)))
d@41: 	      (setf (aref overlaps shorter) overlap)
d@41: 	      (when (and (= shorter i)
d@41: 			 (= overlap 1))
d@41: 		;; Maximum value - we can stop
d@41: 		(return)))))))
d@41:     (let ((total 0) (overs 0))
d@41:       (loop for i from 0 to (1- (length events-bag))
d@41: 	 do (when (aref overlaps i)
d@41: 	      (incf total)
d@132: 	      (when (>= (aref overlaps i) 1/2)
d@41: 		(incf overs))))
d@41:       (if (and (> total 0)
d@41: 	       (>= (/ overs total)
d@41: 		   1/4))
d@132: 	  T
d@132: 	  nil))))
d@47: 
d@47: (defgeneric inter-onset-intervals (composition &key rounding-divisor))
d@47: (defmethod inter-onset-intervals ((composition composition) &key (rounding-divisor 1/4))
d@47:   ;; returns values - list inter-onset intervals in beats, modal i-o-i
d@47:   ;; and i-o-is in seconds.
d@47:   ;; ** Only makes sense for monodic music
d@47:   ;; FIXME: Should this keep in objects or am I right to make numbers
d@47:   ;; here?
d@47:   ;; FIXME: Should I (do I) filter out 0s?
d@47:   (let ((i-o-i-list) (i-o-i-secs-list) (prev)
d@65: 	(hits (make-array (1+ (/ 32 rounding-divisor)))))
d@47:     (loop for event being the elements of composition
d@47:        do (progn
d@47: 	    (when prev
d@47: 	      (let* ((i-o-i-period (inter-onset-interval prev event))
d@47: 		     (i-o-i (duration i-o-i-period))
d@65: 		     (i-o-i-secs (beats-to-seconds i-o-i-period composition)))
d@47: 		(when (= i-o-i-secs 0)
d@47: 		  (format t "~D, ~D -- " (timepoint prev) (timepoint event)))
d@47: 		(push i-o-i i-o-i-list)
d@47: 		(push i-o-i-secs i-o-i-secs-list)
d@47: 		(when (< i-o-i 32)
d@47: 		  ;; Not really interested in very long results for the
d@47: 		  ;; modal value anyway.
d@47: 		  (incf (aref hits (round i-o-i rounding-divisor))))))
d@47: 	    (setf prev event)))
d@47:     (let ((mode '(0 0)))
d@47:       ;; we want the position of the highest mode
d@47:       (loop for i downfrom (1- (length hits)) to 0
d@47: 	 when (> (aref hits i) (car mode))
d@47: 	 do (setf mode (list (aref hits i) i)))
d@47:       (values (reverse i-o-i-list)
d@47: 	      (* (cadr mode) rounding-divisor)
d@47: 	      (reverse i-o-i-secs-list)))))
d@47: 
d@47: (defun pitch-interval-list (composition)
d@47:   (let ((intervals)
d@47: 	(previous-event))
d@47:     (sequence:dosequence (event composition (reverse intervals))
d@47:       (when previous-event
d@47: 	(push (span (pitch- event previous-event))
d@47: 	      intervals))
m@54:       (setf previous-event event))))