Mercurial > hg > amuse

--- a/amuse.asd	Wed Jun 06 14:49:40 2007 +0100
+++ b/amuse.asd	Thu Jun 14 15:00:28 2007 +0100
@@ -17,6 +17,7 @@
             :components
             ((:file "package")
              (:file "utils" :depends-on ("package"))
+	     (:file "n-grams" :depends-on ("package"))
 	     (:file "midi-output" :depends-on ("package" "utils"))
 	     (:module harmony
 	              :depends-on ("utils")
--- a/implementations/midi/methods.lisp	Wed Jun 06 14:49:40 2007 +0100
+++ b/implementations/midi/methods.lisp	Thu Jun 14 15:00:28 2007 +0100
@@ -109,4 +109,23 @@
   (midi-drum-sound event))

 (defmethod get-pitch-for-midi ((event midi-pitched-event))
-  (midi-pitch-number event))
\ No newline at end of file
+  (midi-pitch-number event))
+
+;; Have avoided percussion vs pitched, as this is more obviously
+;; meaningless.
+(defmethod significantly-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event))
+  (>= (/ (midi-velocity event1)
+	 (midi-velocity event2))
+      4/3))
+(defmethod significantly-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event))
+  (>= (/ (midi-velocity event1)
+	 (midi-velocity event2))
+      4/3))
+(defmethod substantially-louderp ((event1 midi-pitched-event) (event2 midi-pitched-event))
+  (>= (/ (midi-velocity event1)
+	 (midi-velocity event2))
+      2))
+(defmethod substantially-louderp ((event1 midi-percussive-event) (event2 midi-percussive-event))
+  (>= (/ (midi-velocity event1)
+	 (midi-velocity event2))
+      2))
--- a/utils/harmony/chord-labelling.lisp	Wed Jun 06 14:49:40 2007 +0100
+++ b/utils/harmony/chord-labelling.lisp	Thu Jun 14 15:00:28 2007 +0100
@@ -578,6 +578,7 @@
 ;;
 ;; Likelihood (structure) manipulation and access methods
 ;;
+;; FIXME: Explain this?? Is it ((pc :type) . p(chord))?

 (defgeneric set-likelihood (likelihoods offset chord likelihood))
 (defmethod set-likelihood ((likelihoods list) chord offset likelihood)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/utils/n-grams.lisp	Thu Jun 14 15:00:28 2007 +0100
@@ -0,0 +1,48 @@
+(in-package "AMUSE-UTILS")
+
+(defun get-n-grams (state-sequence start-n &optional (finish-n nil))
+  (let ((memory (make-array (or finish-n start-n) :initial-element :BLANK))
+	(pointer 0) (step 0)
+	(n-grams (make-array (or finish-n start-n)
+			     :initial-element nil))
+	(current-sequence) (last-time))
+    (dolist (state state-sequence n-grams)
+      (setf (aref memory pointer) state
+	    current-sequence nil
+	    last-time nil
+	    step (1+ step))
+      (do ((i (mod (1+ pointer) (length memory)) (mod (1+ i) (length memory))))
+	  (last-time (setf current-sequence (reverse current-sequence)))
+	(when (= pointer i)
+	  (setf last-time t))
+	(push (aref memory i) current-sequence))
+      (setf pointer (mod (1+ pointer) (length memory)))
+      (loop for i from start-n to (or finish-n start-n)
+	 do (when (> step i)
+	      (unless (aref n-grams (1- i))
+		(setf (aref n-grams (1- i)) (make-hash-table :test #'equal)))
+	      (if (gethash (subseq current-sequence (- (or finish-n start-n) i))
+			   (aref n-grams (1- i)))
+		  (incf (gethash (subseq current-sequence (- (or finish-n start-n) i))
+				 (aref n-grams (1- i))))
+		  (setf (gethash (subseq current-sequence (- (or finish-n start-n) i))
+				 (aref n-grams (1- i)))
+			1)))))))
+
+(defun get-n-gram (state-sequence n)
+  (aref (get-n-grams state-sequence n) (1- n)))
+
+(defun n-gram-stats (n-gram &key (alphabet-size nil))
+  (let ((count 0)
+	(frequencies)
+	(n))
+    (maphash #'(lambda (key val)
+		 (push (cons key val) frequencies)
+		 (incf count val)
+		 (unless n
+		   (setf n (length key))))
+	     n-gram)
+    (if alphabet-size
+	(values count (hash-table-count n-gram) frequencies (/ (hash-table-count n-gram)
+							       (expt alphabet-size n)))
+	(values count (hash-table-count n-gram) frequencies))))
--- a/utils/package.lisp	Wed Jun 06 14:49:40 2007 +0100
+++ b/utils/package.lisp	Thu Jun 14 15:00:28 2007 +0100
@@ -25,4 +25,6 @@
 	   #:krumhansl-key-finder
 	   #:levenshtein-distance
 	   #:beats-to-seconds
+	   #:get-n-grams
+	   #:monodificate
 	   ))
--- a/utils/utils.lisp	Wed Jun 06 14:49:40 2007 +0100
+++ b/utils/utils.lisp	Thu Jun 14 15:00:28 2007 +0100
@@ -184,4 +184,179 @@
 			  (if (apply substitution-test (list (elt s1 x) (elt s2 y)))
 			      0
 			      substitution-cost)))))))
-    (aref d (1- height) (1- width))))
\ No newline at end of file
+    (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))))
\ No newline at end of file