m@23: ;;; General purpose utilities m@23: m@23: (cl:in-package #:amuse-utils) m@23: d@33: ;; Booleans (for filters) d@33: (defgeneric pitchedp (event) d@33: (:method (e) (declare (ignore e)) nil)) d@33: (defmethod pitchedp ((event amuse:pitched-event)) d@33: T) d@33: (defgeneric unpitchedp (event) d@33: (:method (e) (not (pitchedp e)))) d@33: d@33: ;; Rhythm methods d@33: (defgeneric crotchets-in-a-bar (time-signature)) d@33: (defmethod crotchets-in-a-bar ((time-signature basic-time-signature)) d@33: (let ((num (time-signature-numerator time-signature)) d@33: (den (time-signature-denominator time-signature))) d@33: (* num (/ 4 den)))) d@33: d@36: (defgeneric beats-to-seconds (object1 object2)) d@36: (defmethod beats-to-seconds ((object1 anchored-period) d@36: (object2 constituent)) d@36: (let ((tempi (get-applicable-tempi object1 object2)) d@36: (s 0)) d@36: (dolist (tempo tempi (/ s 1000000)) d@36: (incf s (* (duration (period-intersection tempo object1)) d@36: (amuse:microseconds-per-crotchet tempo)))))) d@36: (defmethod beats-to-seconds ((object1 moment) d@36: (object2 constituent)) d@36: (beats-to-seconds (make-anchored-period 0 d@36: (timepoint object1)) d@36: object2)) d@36: d@36: d@33: ;; Pitch methods d@33: d@33: (defgeneric sounding-events (anchored-period sequence)) d@33: (defmethod sounding-events ((anchored-period anchored-period) d@33: (sequence composition)) d@33: (let ((sounding)) d@33: (sequence:dosequence (event sequence (reverse sounding)) d@33: (cond d@33: ((time>= event (cut-off anchored-period)) d@33: (return-from sounding-events (reverse sounding))) d@33: ((period-intersection anchored-period event) d@33: (push event sounding)))))) d@33: d@33: (defgeneric midi-pitch-distribution (anchored-period composition)) d@33: (defmethod midi-pitch-distribution ((anchored-period anchored-period) d@33: composition) d@33: (let ((pitches (make-array 128 :initial-element 0))) d@33: (dolist (event (remove-if #'unpitchedp (sounding-events anchored-period composition)) pitches) d@33: (let ((overlap (period-intersection anchored-period event))) d@33: (if overlap d@33: (incf (aref pitches (midi-pitch-number event)) d@33: (duration overlap)) d@33: (if (= (duration event) 0) d@33: (format t "~%Note ~D beats in has no duration" (timepoint event)) d@33: (error "This function has gone wrong - looking for overlaps that don't exist"))))))) d@33: d@33: (defgeneric pitch-class-distribution (anchored-period composition)) d@33: (defmethod pitch-class-distribution ((anchored-period anchored-period) d@33: composition) d@33: (let ((pitches (make-array 12 :initial-element 0))) d@33: (dolist (event (remove-if #'unpitchedp (sounding-events anchored-period composition)) pitches) d@33: (let ((overlap (period-intersection anchored-period event))) d@33: (if overlap d@33: (incf (aref pitches (pitch-class event)) d@33: (duration overlap)) d@33: (if (= (duration event) 0) d@33: (format t "~%Note ~D beats in has no duration" (timepoint event)) d@33: (error "This function has gone wrong - looking for overlaps that don't exist"))))))) d@33: d@33: (defun normalised-midi-pitch-distribution (object1 object2) d@33: (normalise-vector (midi-pitch-distribution object1 object2))) d@33: (defun normalised-pitch-class-distribution (object1 object2) d@33: (normalise-vector (pitch-class-distribution object1 object2))) d@33: (defun normalise-vector (vector &optional (target-sum 1)) d@33: (let ((total (loop for i from 0 to (1- (length vector)) d@33: sum (aref vector i)))) d@33: (cond d@33: ((= total target-sum) d@33: vector) d@33: ((= total 0) d@33: (make-array (length vector) d@33: :initial-element (/ target-sum (length vector)))) d@33: (t d@33: (map 'vector #'(lambda (x) (* x (/ target-sum total))) vector))))) d@33: d@33: ;; Not as simple as it seems - have to take into account numbering d@33: ;; practices and leading silences in representations where bar number d@33: ;; isn't part of the explicit structure. d@33: (defgeneric bar-number (moment composition)) d@36: (defgeneric bar-onset (bar-number composition)) d@33: d@36: (defgeneric bass-note (anchored-period composition)) d@36: d@36: (defun vector-correlation (vector1 vector2) d@36: ;; useful for Krumhansl-Schmukler-like calculations d@36: (assert (= (length vector1) (length vector2))) d@36: (let* ((n (length vector1)) d@36: (sum-x (loop for i from 0 to (1- n) d@36: sum (aref vector1 i))) d@36: (sum-y (loop for i from 0 to (1- n) d@36: sum (aref vector2 i))) d@36: (equation-bl (sqrt (- (* n d@36: (loop for i from 0 to (1- n) d@36: sum (expt (aref vector1 i) 2))) d@36: (expt sum-x 2)))) d@36: (equation-br (sqrt (- (* n d@36: (loop for i from 0 to (1- n) d@36: sum (expt (aref vector2 i) 2))) d@36: (expt sum-y 2)))) d@36: (equation-b (* equation-br equation-bl)) d@36: (equation-tr (* sum-x sum-y)) d@36: (equation-t 0) d@36: (results-array (make-array n))) d@36: (do ((i 0 (1+ i))) d@36: ((= i n) results-array) d@36: (setf equation-t (- (* n (loop for j from 0 to (1- n) d@36: sum (* (aref vector1 (mod (+ i j) n)) d@36: (aref vector2 j)))) d@36: equation-tr) d@36: (aref results-array i) (/ equation-t equation-b))))) d@36: d@36: d@36: (defparameter *krumhansl-schmuckler-major-key* d@36: (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))) d@36: d@36: (defparameter *krumhansl-schmuckler-minor-key* d@36: (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))) d@36: d@36: (defun krumhansl-key-finder (anchored-period composition d@36: &key (major *krumhansl-schmuckler-major-key*) d@36: (minor *krumhansl-schmuckler-minor-key*)) d@36: (let* ((key) (best-score -1) d@36: (pitches (pitch-class-distribution anchored-period composition)) d@36: (majors (vector-correlation pitches major)) d@36: (minors (vector-correlation pitches minor))) d@36: (loop for i from 0 to 11 d@36: do (when (> (aref majors i) best-score) d@36: (setf key (list i :major) d@36: best-score (aref majors i)))) d@36: (loop for i from 0 to 11 d@36: do (when (> (aref minors i) best-score) d@36: (setf key (list i :minor) d@36: best-score (aref minors i)))) d@36: key))