Mercurial > hg > amuse
changeset 36:ad321ce17e3e
Moving some functionality from specialised geerdes area. Also added mcsv output
darcs-hash:20070511120916-f76cc-d6f1b566eea7115c5de1d3aad285c84b304730b7.gz
| author | David Lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Fri, 11 May 2007 13:09:16 +0100 |
| parents | 1d757c33e00e |
| children | 9aeb5bff013a |
| files | amuse.asd implementations/midi/midifile-import.lisp utils/package.lisp utils/utils.lisp |
| diffstat | 4 files changed, 88 insertions(+), 15 deletions(-) [+] |
line wrap: on
line diff
--- a/amuse.asd Wed May 02 16:30:16 2007 +0100 +++ b/amuse.asd Fri May 11 13:09:16 2007 +0100 @@ -24,7 +24,8 @@ ((:file "package") (:file "classes" :depends-on ("package")) (:file "gamma" :depends-on ("package")) - (:file "chord-labelling" :depends-on ("gamma" "package" "classes")))))) + (:file "chord-labelling" + :depends-on ("gamma" "package" "classes")))))) (:module implementations :components ((:module midi @@ -33,6 +34,5 @@ (:file "classes" :depends-on ("package")) (:file "constructors" :depends-on ("package" "classes")) (:file "methods" :depends-on ("package" "classes")) - (:file "midifile-import" - :depends-on ("package" "classes" "constructors" "methods")))))))) + (:file "midifile-import" :depends-on ("package" "classes" "constructors" "methods"))))))))
--- a/implementations/midi/midifile-import.lisp Wed May 02 16:30:16 2007 +0100 +++ b/implementations/midi/midifile-import.lisp Fri May 11 13:09:16 2007 +0100 @@ -29,9 +29,9 @@ (and (= (midi:message-time x) (midi:message-time y)) (typep x 'midi:note-off-message)))))) - (let ((ons (make-array '(17 128) :initial-element nil)) + (let ((ons (make-array '(16 128) :initial-element nil)) (offs) - (patches (make-array 17 :initial-element 0))) + (patches (make-array 16 :initial-element 0))) (dolist (event track) (when (> (midi:message-time event) last-time) (setf last-time (midi:message-time event))) @@ -40,7 +40,7 @@ (and (typep event 'midi:note-on-message) (= (midi:message-velocity event) 0))) (let ((pitch (midi:message-key event)) - (channel (1+ (midi:message-channel event))) + (channel (midi:message-channel event)) (t-off (midi:message-time event))) (if (aref ons channel pitch) (push (make-event-from-on-off-pair (aref ons channel pitch) @@ -54,7 +54,7 @@ (push event offs)))) ((typep event 'midi:note-on-message) (let ((pitch (midi:message-key event)) - (channel (1+ (midi:message-channel event))) + (channel (midi:message-channel event)) (t-off (midi:message-time event))) (when (aref ons channel pitch) ;; there's a note already sounding. End it. @@ -77,7 +77,7 @@ :time (/ (midi:message-time event) division) :numerator (midi:message-numerator event) - :denominator (midi:message-denominator event)) + :denominator (expt 2 (midi:message-denominator event))) time-sigs)) ((typep event 'midi:tempo-message) (when tempi @@ -91,7 +91,7 @@ :bpm (microsecond-per-crotchet-to-bpm (midi:message-tempo event))) tempi)) ((typep event 'midi:program-change-message) - (setf (aref patches (1+ (midi:message-channel event))) + (setf (aref patches (midi:message-channel event)) (midi:message-program event))) (t (incf misses)))))) (when tempi @@ -102,17 +102,19 @@ (let ((composition (make-instance 'midi-composition :time 0 :interval (/ last-time division) - :time-signatures (sort time-sigs #'time<) + :time-signatures (if time-sigs + (sort time-sigs #'time<) + (list (make-instance 'basic-time-signature + :time 0 + :interval (/ last-time division) + :numerator 4 + :denominator 4))) :tempi (sort tempi #'time<)))) (sequence:adjust-sequence composition (length notes) :initial-contents (sort notes #'time<))))) -(defparameter *short* nil) - (defun make-event-from-on-off-pair (note-on cut-off divisions track patch) - (when (< (/ (- cut-off (midi:message-time note-on)) divisions) 1/8) - (push (cons note-on cut-off) *short*)) (cond ((or (= (midi:message-channel note-on) 9) (> patch 111))
--- a/utils/package.lisp Wed May 02 16:30:16 2007 +0100 +++ b/utils/package.lisp Fri May 11 13:09:16 2007 +0100 @@ -8,6 +8,7 @@ #:normalised-pitch-class-distribution #:normalise-vector #:bar-number + #:bar-onset #:bass-note #:crotchets-in-a-bar #:sounding-events @@ -20,4 +21,6 @@ #:get-channel-for-midi #:get-pitch-for-midi #:get-velocity-for-midi + #:vector-correlation + #:krumhansl-key-finder ))
--- 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))