comparison utils/utils.lisp @ 41:90abdf9adb60

monodising and some n-gram utilities

darcs-hash:20070614140028-f76cc-9bdeba6db4097e425b1fee4f58a3327eeb486685.gz

 			  (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 (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) 3/4)
+		(incf overs))))
+      (if (and (> total 0)
+	       (>= (/ overs total)
+		   1/4))
+	  'T
+	  'nil))))