view utils/utils.lisp @ 139:ebfe054eea1c

Bug fixes from name changes

darcs-hash:20070918114952-f76cc-feb59725a2f67edd6242947a5c2311d0a724cc43.gz

;;; General purpose utilities 

(cl:in-package #:amuse-utils) 

;; Booleans (for filters)
(defgeneric pitchedp (event)
  (:method (e) (declare (ignore e)) nil))
(defmethod pitchedp ((event amuse:pitched-event))
  T)
(defgeneric unpitchedp (event)
  (:method (e) (not (pitchedp e))))

;; Rhythm methods
(defgeneric crotchets-in-a-bar (time-signature)
  (:documentation "Convenient function for finding the number of
  crotchet beats in a bar based on the provided
  time-signature. It should be borne in mind that this needn't be
  an integer - a time signature of 3/8, for example, should yield
  an answer of 3/2"))
(defmethod crotchets-in-a-bar ((time-signature standard-time-signature))
  (let ((num (time-signature-numerator time-signature))
	(den (time-signature-denominator time-signature)))
    (* num (/ 4 den))))

(defgeneric beats-to-seconds (object1 object2))
(defmethod beats-to-seconds ((object1 standard-anchored-period)
			     (object2 constituent))
  (let ((tempi (or (get-applicable-tempi object1 object2)
		   (signal 'undefined-action
			   :operation 'beats-to-seconds
			   :datatype 'constituent)))
	(s 0))
    (dolist (tempo tempi (/ s 1000000))
      (incf s (if (disjoint tempo object1)
		  0
		  (* (/ (duration (period-intersection tempo object1))
			(duration (crotchet object2)))
		     (amuse:microseconds-per-crotchet tempo)))))))
(defmethod beats-to-seconds ((object1 standard-moment)
			     (object2 constituent))
  (beats-to-seconds (time- (onset object1)
			   (make-standard-moment 0))
		    object2))
					  
;; Not as simple as it seems - have to take into account numbering
;; practices and leading silences in representations where bar number
;; isn't part of the explicit structure.
(defgeneric bar-number (moment composition)
  (:documentation "Returns the bar number of moment in
  composition. N.B. Although this will be a designated value in
  some, particularly score-based, implementations, it will be a
  derived value in others, particularly midi, where it may be
  necessary to take into account numbering practices and leading
  silences."))
(defgeneric bar-onset (bar-number composition)
  (:documentation "Returns a moment for the beginning of the bar
  with the given bar-number. Cautions about bar numbering as
  given in the bar-number documentation apply here also."))

(defgeneric bass-note (anchored-period composition))


(defun levenshtein-distance (s1 s2 &key (insertion-cost 1)
			  (insertion-function) (deletion-cost 1)
			  (deletion-function) (substitution-cost 1)
			  (substitution-test #'equal) (substitution-function))
  ;; This is an implementation of the Levenshtein distance measure
  ;; based on the cliki asdf package, itself based on the wikipedia
  ;; scheme example of the same algorithm. This version is generalised
  ;; such that operations costs may take constant or calculated
  ;; values. If insertion-function, deletion-function or
  ;; substitution-test are specified, the applicable cost values are
  ;; ignored and the function output is used instead.
  (let* ((width (1+ (length s1)))
	 (height (1+ (length s2)))
	 (d (make-array (list height width))))
    (dotimes (x width)
      (setf (aref d 0 x) (* x deletion-cost)))
    (dotimes (y height)
      (setf (aref d y 0) (* y insertion-cost)))
    (dotimes (x (length s1))
      (dotimes (y (length s2))
	(setf (aref d (1+ y) (1+ x))
	      (min (+ (if insertion-function
			  (apply insertion-function (elt s1 x))
			  insertion-cost)
		      (aref d y (1+ x)))
		   (+ (if deletion-function
			  (apply deletion-function (elt s2 y))
			  deletion-cost)
		      (aref d (1+ y) x))
		   (+ (aref d y x)
		      (if substitution-function
			  (apply substitution-function (list (elt s1 x) (elt s2 y)))
			  (if (apply substitution-test (list (elt s1 x) (elt s2 y)))
			      0
			      substitution-cost)))))))
    (aref d (1- height) (1- width))))

;;;;;;;;;;;;;;;;;;;;;;
;;
;; More experimental (from amuse-geerdes)
;;
;; Monody functions

(defun monodificate (composition)
  (let ((events-bags) (latest-cut-off))
  ;; - Filter out very short notes (<50ms) 
  ;; - If there are notes with the same onset time or a large
  ;;   proportion (e.g. >25%) of the notes in the segment have
  ;;   overlapping durations (of >75%), do for every simultaneous or
  ;;   overlapping pair of notes
  ;; -- if one note is louder than the other note (e.g. quieter note
  ;;    <75% of louder one) select it as melody note
  ;; -- else select note with higher pitch
  ;; [FIXME: I'm ignoring overlaps for the time being]
  ;; - For non-simultaneous notes with little overlap, set note ends
  ;;   to beginning of of onset of next (overlapping) note.

  ;; STEP 1: 
  ;; `Filter out very short notes (<50ms)' and find `segments' for
  ;; further filtering.
    (sequence::dosequence (event composition)
      (when (> (beats-to-seconds event composition)
	       1/20)
	(if (or (not latest-cut-off)
		(time> (onset event) latest-cut-off))
	    (push (list event) events-bags)
	    (push event (car events-bags)))
	(when (or (not latest-cut-off)
		  (time> (cut-off event) latest-cut-off))
	  (setf latest-cut-off (cut-off event)))))
    ;; Now check each segment for overlaps and
    ;; simultanaieties. N.B. this is a reverse list of reversed
    ;; lists.
    (let ((adjusted-bags))
      (dolist (events-bag events-bags)
	(setf events-bag (reverse events-bag))
	(let ((polyphonic-p (check-events-bag-for-polyphony events-bag)))
	  (cond
	    (polyphonic-p
	     (push (resolve-polyphony events-bag composition) adjusted-bags))
	    (t
	     (if (cdr events-bag)		   
		 (push (adjust-durations events-bag) adjusted-bags)
		 (push events-bag adjusted-bags))))))
      (apply #'nconc adjusted-bags))))

(defun resolve-polyphony (event-list composition)
  (do ((i 0 (1+ i)))
      ((>= i (length event-list)) event-list)
    (let ((event (nth i event-list)))
      (do ((j (1+ i) (1+ j)))
	  ((or (>= j (length event-list))
	       (time>= (onset (nth j event-list))
		       (cut-off event))))
	(let* ((event-2 (nth j event-list))
	       (inter-onset (time- (onset event-2) (onset event))))
	  (cond
	    ((and inter-onset
		  (< (* 2 (duration inter-onset))
		      (duration event))
		  (< (* 2 (duration inter-onset))
		      (duration event-2))
		  (< (beats-to-seconds inter-onset composition)
		      1/8))
	     ;; This is clearly polyphony
	     (cond
	       ((significantly-louderp event-2 event)
		;; Take event-2
		(setf event-list (remove event event-list))
		(decf i)
		(return))
	       ((significantly-louderp event event-2)
		;; Take event
		(setf event-list (remove event-2 event-list))
		(decf j))
	       ((pitch> event event-2)
		;; Take event
		(setf event-list (remove event-2 event-list))
		(decf j))
	       (t
		;; Take event-2
		(setf event-list (remove event event-list))
		(decf i)
		(return))))
	    (t
	     (cond
	       ((substantially-louderp event-2 event)
		;; Take event-2
		(setf event-list (remove event event-list))
		(decf i)
		(return))
	       ((substantially-louderp event event-2)
		;; Take event
		(setf event-list (remove event-2 event-list))
		(decf j))
	       (t
		;; Take both
		(let ((event-overlap (period-intersection event event-2)))
		  (when event-overlap
		    (setf (duration event)
			  (duration (time- event-overlap event))))))))))))))

(defgeneric significantly-louderp (event1 event2)
  ;; noticably louder
  (:method (e1 e2) (declare (ignore e1 e2)) nil))

(defgeneric substantially-louderp (event1 event2)
  ;; much louder
  (:method (e1 e2) (declare (ignore e1 e2)) nil))

(defun adjust-durations (events-list)
  (do* ((old-list events-list (cdr old-list))
	(event (first old-list) (first old-list))
	(event-2 (second old-list) (second old-list)))
       ((not event-2) events-list)
    (let ((event-overlap (period-intersection event event-2)))
      (when event-overlap
	(setf (duration event)
	      (duration (time- event-overlap event)))))))

(defun check-events-bag-for-polyphony (events-bag)
  (let ((overlaps (make-array (length events-bag) :initial-element nil)))
    (when (= (length events-bag) 1)
      ;; obviously no overlaps
      (return-from check-events-bag-for-polyphony nil))
    (unless (= (length (remove-duplicates events-bag :test #'time=))
	       (length events-bag))
      ;; Duplicated onsets
      (return-from check-events-bag-for-polyphony 'T))
    ;; Now for the main bit
    (do* ((events events-bag (cdr events))
	  (i 0 (1+ i))
	  (event (car events) (car events)))
	 ((null (cdr events)))
      (unless (and (aref overlaps i)
		   (= (aref overlaps i) 1))
	;; Would mean we already have a maximal value
	;; and don't need any more checks
	(do* ((events-2 (cdr events) (cdr events-2))
	      (j (1+ i) (1+ j))
	      (event-2 (car events-2) (car events-2)))
	     ((null events-2))
	  (when (time>= (onset event-2) (cut-off event))
	    ;; So no more overlaps
	    (return))
	  (let ((shorter (if (duration< event event-2)
			     i
			     j))
		(overlap (/ (duration (period-intersection event event-2))
			    (min (duration event) (duration event-2)))))
	    ;; only look at pairings for the shorter note. This can
	    ;; have odd side effects, but means we never
	    ;; under-represent an overlap (I think)
	    (when (>= overlap 3/4)
	      (return-from check-events-bag-for-polyphony T))
	    (when (or (not (aref overlaps shorter))
		      (>= overlap (aref overlaps shorter)))
	      (setf (aref overlaps shorter) overlap)
	      (when (and (= shorter i)
			 (= overlap 1))
		;; Maximum value - we can stop
		(return)))))))
    (let ((total 0) (overs 0))
      (loop for i from 0 to (1- (length events-bag))
	 do (when (aref overlaps i)
	      (incf total)
	      (when (>= (aref overlaps i) 1/2)
		(incf overs))))
      (if (and (> total 0)
	       (>= (/ overs total)
		   1/4))
	  T
	  nil))))

(defgeneric inter-onset-intervals (composition &key rounding-divisor))
(defmethod inter-onset-intervals ((composition composition) &key (rounding-divisor 1/4))
  ;; returns values - list inter-onset intervals in beats, modal i-o-i
  ;; and i-o-is in seconds.
  ;; ** Only makes sense for monodic music
  ;; FIXME: Should this keep in objects or am I right to make numbers
  ;; here?
  ;; FIXME: Should I (do I) filter out 0s?
  (let ((i-o-i-list) (i-o-i-secs-list) (prev)
	(hits (make-array (1+ (/ 32 rounding-divisor)))))
    (loop for event being the elements of composition
       do (progn
	    (when prev
	      (let* ((i-o-i-period (inter-onset-interval prev event))
		     (i-o-i (duration i-o-i-period))
		     (i-o-i-secs (beats-to-seconds i-o-i-period composition)))
		(when (= i-o-i-secs 0)
		  (format t "~D, ~D -- " (timepoint prev) (timepoint event)))
		(push i-o-i i-o-i-list)
		(push i-o-i-secs i-o-i-secs-list)
		(when (< i-o-i 32)
		  ;; Not really interested in very long results for the
		  ;; modal value anyway.
		  (incf (aref hits (round i-o-i rounding-divisor))))))
	    (setf prev event)))
    (let ((mode '(0 0)))
      ;; we want the position of the highest mode
      (loop for i downfrom (1- (length hits)) to 0
	 when (> (aref hits i) (car mode))
	 do (setf mode (list (aref hits i) i)))
      (values (reverse i-o-i-list)
	      (* (cadr mode) rounding-divisor)
	      (reverse i-o-i-secs-list)))))

(defun pitch-interval-list (composition)
  (let ((intervals)
	(previous-event))
    (sequence:dosequence (event composition (reverse intervals))
      (when previous-event
	(push (span (pitch- event previous-event))
	      intervals))
      (setf previous-event event))))