diff utils/utils.lisp @ 36:ad321ce17e3e

Moving some functionality from specialised geerdes area. Also added mcsv output

darcs-hash:20070511120916-f76cc-d6f1b566eea7115c5de1d3aad285c84b304730b7.gz

--- a/utils/utils.lisp	Wed May 02 16:30:16 2007 +0100
+++ b/utils/utils.lisp	Fri May 11 13:09:16 2007 +0100
@@ -17,6 +17,21 @@
 	(den (time-signature-denominator time-signature)))
     (* num (/ 4 den))))
 
+(defgeneric beats-to-seconds (object1 object2))
+(defmethod beats-to-seconds ((object1 anchored-period)
+			     (object2 constituent))
+  (let ((tempi (get-applicable-tempi object1 object2))
+	(s 0))
+    (dolist (tempo tempi (/ s 1000000))
+      (incf s (* (duration (period-intersection tempo object1))
+		 (amuse:microseconds-per-crotchet tempo))))))
+(defmethod beats-to-seconds ((object1 moment)
+			     (object2 constituent))
+  (beats-to-seconds (make-anchored-period 0
+					  (timepoint object1))
+		    object2))
+					  
+
 ;; Pitch methods
 
 (defgeneric sounding-events (anchored-period sequence))
@@ -76,5 +91,58 @@
 ;; practices and leading silences in representations where bar number
 ;; isn't part of the explicit structure.
 (defgeneric bar-number (moment composition))
+(defgeneric bar-onset (bar-number composition))
 
-(defgeneric bass-note (anchored-period composition))
\ No newline at end of file
+(defgeneric bass-note (anchored-period composition))
+
+(defun vector-correlation (vector1 vector2)
+  ;; useful for Krumhansl-Schmukler-like calculations
+  (assert (= (length vector1) (length vector2)))
+  (let* ((n (length vector1))
+	 (sum-x (loop for i from 0 to (1- n)
+		      sum (aref vector1 i)))
+	 (sum-y (loop for i from 0 to (1- n)
+		      sum (aref vector2 i)))
+	 (equation-bl (sqrt (- (* n
+				  (loop for i from 0 to (1- n)
+					sum (expt (aref vector1 i) 2)))				  
+			       (expt sum-x 2))))
+	 (equation-br (sqrt (- (* n
+				  (loop for i from 0 to (1- n)
+					sum (expt (aref vector2 i) 2)))
+			       (expt sum-y 2))))
+	 (equation-b (* equation-br equation-bl))
+	 (equation-tr (* sum-x sum-y))
+	 (equation-t 0)
+	 (results-array (make-array n)))
+    (do ((i 0 (1+ i)))
+	((= i n) results-array)
+      (setf equation-t (- (* n (loop for j from 0 to (1- n)
+				       sum (* (aref vector1 (mod (+ i j) n))
+					      (aref vector2 j))))
+			  equation-tr)
+	    (aref results-array i) (/ equation-t equation-b)))))
+
+
+(defparameter *krumhansl-schmuckler-major-key*
+  (make-array 12 :initial-contents '(6.33 2.68 3.52 5.38 2.6 3.53 2.54 4.75 3.98 2.69 3.34 3.17)))
+
+(defparameter *krumhansl-schmuckler-minor-key*
+  (make-array 12 :initial-contents '(6.35 2.23 3.48 2.33 4.38 4.09 2.52 5.19 2.39 3.66 2.29 2.88)))
+
+(defun krumhansl-key-finder (anchored-period composition
+			     &key (major *krumhansl-schmuckler-major-key*)
+			     (minor *krumhansl-schmuckler-minor-key*))
+  (let* ((key) (best-score -1)
+	 (pitches (pitch-class-distribution anchored-period composition))
+	 (majors (vector-correlation pitches major))
+	 (minors (vector-correlation pitches minor)))
+    (loop for i from 0 to 11
+	  do (when (> (aref majors i) best-score)
+	       (setf key (list i :major)
+		     best-score (aref majors i))))
+    (loop for i from 0 to 11
+	  do (when (> (aref minors i) best-score)
+	       (setf key (list i :minor)
+		     best-score (aref minors i))))
+    key))