Mercurial > hg > amuse
changeset 33:d1010755f507
Large upload of local changes. Many additions, such as harmony and piece-level objects
darcs-hash:20070413100909-f76cc-a8aa8dfc07f438dc0c1a7c45cee7ace2ecc1e6a5.gz
| author | David Lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Fri, 13 Apr 2007 11:09:09 +0100 |
| parents | 5e705b6f94b6 |
| children | 81b4228e26f5 |
| files | amuse.asd base/classes.lisp base/constructors.lisp base/extended-sequence.lisp base/generics.lisp base/methods.lisp base/package.lisp implementations/midi/classes.lisp implementations/midi/package.lisp utils/harmony/chord-labelling.lisp utils/harmony/classes.lisp utils/harmony/evaluation.lisp utils/harmony/gamma.lisp utils/harmony/methods.lisp utils/harmony/package.lisp utils/midi-output.lisp utils/package.lisp utils/utils.lisp |
| diffstat | 18 files changed, 2309 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- a/amuse.asd Mon Dec 18 13:23:31 2006 +0000 +++ b/amuse.asd Fri Apr 13 11:09:09 2007 +0100 @@ -2,25 +2,35 @@ :name "amuse" :description "" :serial t + :depends-on ("midi") :components - ((:module utils + ((:module base + :components + ((:file "package") + (:file "conditions" :depends-on ("package")) + (:file "extended-sequence" :depends-on ("package")) + (:file "classes" :depends-on ("package")) + (:file "constructors" :depends-on ("package")) + (:file "generics" :depends-on ("package")) + (:file "methods" :depends-on ("package")))) + (:module utils :components ((:file "package") - (:file "utils"))) - (:module base - :components - ((:file "package") - (:file "conditions") - (:file "classes") - (:file "constructors") - (:file "generics") - (:file "methods"))) + (:file "utils" :depends-on ("package")) + (:file "midi-output" :depends-on ("package" "utils")) + (:module harmony + :depends-on ("utils") + :components + ((:file "package") + (:file "classes" :depends-on ("package")) + (:file "gamma" :depends-on ("package")) + (:file "chord-labelling" :depends-on ("gamma" "package" "classes")))))) (:module implementations :components ((:module midi :components ((:file "package") - (:file "classes") - (:file "constructors") - (:file "methods"))))))) + (:file "classes" :depends-on ("package")) + (:file "constructors" :depends-on ("package" "classes")) + (:file "methods" :depends-on ("package" "classes"))))))))
--- a/base/classes.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/base/classes.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -2,9 +2,13 @@ ;; collections of more than one event -(defclass constituent () ()) -(defclass composition (constituent) ()) -(defclass monody (constituent) ()) +(defclass constituent (anchored-period) ()) +(defclass time-ordered-constituent (constituent list-slot-sequence) + ;; this won't work if lisp implementation doesn't support extensible + ;; sequences. + ()) +(defclass composition (time-ordered-constituent) ()) +(defclass monody (time-ordered-constituent) ()) ;; types of information-specifiers
--- a/base/constructors.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/base/constructors.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -11,6 +11,8 @@ (defun make-floating-period (interval) (make-instance 'floating-period :interval interval)) + +;; Should this take a moment and/or a period too? (defun make-anchored-period (onset interval) (make-instance 'anchored-period :time onset
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/extended-sequence.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,74 @@ +(cl:in-package #:amuse) + +;; Defines a set of methods for a sequence one of whose slots is the +;; real sequence (in this case a list). This allows the allocation of +;; other slots for state information. +;; +;; Requires a lisp with extensible lists (Rhodes, User-extensible +;; Sequences, 2006/7??). Currently, that means SBCL >1.0 only. +;; +;; The code here draws heavily on Christophe's examples + +(defclass list-slot-sequence (sequence standard-object) + ((%data :accessor %list-slot-sequence-data + :initform nil))) + +(defmethod sequence:length ((o list-slot-sequence)) + (length (%list-slot-sequence-data o))) + +(defmethod sequence:elt ((o list-slot-sequence) index) + (elt (%list-slot-sequence-data o) index)) + +(defmethod (setf sequence:elt) (new-value (o list-slot-sequence) index) + (setf (elt (%list-slot-sequence-data o) index) new-value)) + +(defmethod sequence:make-sequence-like ((o list-slot-sequence) length + &key (initial-element nil iep) + (initial-contents nil icp)) + (let ((result (make-instance (class-of o)))) + (cond + ((and iep icp) + (error "Supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like)) + (icp + (unless (= (length initial-contents) length) + (error "Length mismatch in ~S" 'make-sequence-like)) + (setf (%list-slot-sequence-data result) (coerce initial-contents 'list)) + result) + (t + (dotimes (i length result) + (push initial-element (%list-slot-sequence-data result))))))) + +(defmethod sequence:adjust-sequence ((o list-slot-sequence) length + &key initial-element + (initial-contents nil icp)) + (cond + ((= length 0) + (setf (%list-slot-sequence-data o) nil)) + (icp + (setf (%list-slot-sequence-data o) + (sequence:adjust-sequence (%list-slot-sequence-data o) + length + :initial-contents initial-contents))) + (t (setf (%list-slot-sequence-data o) + (sequence:adjust-sequence (%list-slot-sequence-data o) + length + :initial-element initial-element)))) + o) + +(defmethod sequence:make-simple-sequence-iterator + ((o list-slot-sequence) &rest args &key from-end start end) + (declare (ignore from-end start end)) + (apply #'sequence:make-simple-sequence-iterator + (%list-slot-sequence-data o) args)) +(defmethod sequence:iterator-step ((o list-slot-sequence) iterator from-end) + (sequence:iterator-step (%list-slot-sequence-data o) iterator from-end)) +(defmethod sequence:iterator-endp ((o list-slot-sequence) iterator limit from-end) + (sequence:iterator-endp (%list-slot-sequence-data o) iterator limit from-end)) +(defmethod sequence:iterator-element ((o list-slot-sequence) iterator) + (sequence:iterator-element (%list-slot-sequence-data o) iterator)) +(defmethod (setf sequence:iterator-element) (new-value (o list-slot-sequence) iterator) + (setf (sequence:iterator-element (%list-slot-sequence-data o) iterator) new-value)) +(defmethod sequence:iterator-index ((o list-slot-sequence) iterator) + (sequence:iterator-index (%list-slot-sequence-data o) iterator)) +(defmethod sequence:iterator-copy ((o list-slot-sequence) iterator) + (sequence:iterator-copy (%list-slot-sequence-data o) iterator)) \ No newline at end of file
--- a/base/generics.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/base/generics.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -4,6 +4,15 @@ (defgeneric get-composition (identifier)) +;;; Getting constituents from compositions +;; IS this the mechanism we want to use +(defgeneric time-signatures (composition)) +(defgeneric (setf time-signatures) (sequence composition)) +(defgeneric tempi (composition)) +(defgeneric (setf tempi) (sequence composition)) +(defgeneric key-signatures (composition)) +(defgeneric (setf key-signatures) (sequence composition)) + ;;; Simple Accessors ;; pitch-based @@ -44,6 +53,16 @@ (defgeneric beat-units (time-signature)) (defgeneric time-signature-denominator (time-signature) (:method (ts) (beat-units ts))) +(defgeneric tactus-duration (time-signature) + ;; basic, but should do? + (:method (ts) + (cond + ((and (not (= (beat-units-per-bar ts) 3)) + (= (rem (beat-units-per-bar ts) 3) 0)) + ;; compound time + (* (/ 4 (beat-units ts)) + 3)) + (t (/ 4 (beat-units ts)))))) (defgeneric key-signature-sharps (key-signature)) @@ -178,6 +197,15 @@ (or (before o1 o2) (meets o1 o2) (meets o2 o1) (before o2 o1)))) ;;; More time-based functions + +(defgeneric period= (object1 object2) + (:method (x y) nil)) + +(defgeneric find-overlapping (anchored-period sequence) + ;; Returns all members of a sequence of period signifiers that overlap + ;; with the supplied period + (:method (ap s) (remove-if #'(lambda (x) (amuse:disjoint ap x)) s))) + ;; Return the anchored-period representing the intersection of two ;; anchored-period-specifiers. (defgeneric period-intersection (anchored-period-specifier1 @@ -189,11 +217,13 @@ ;;; Time Signature -(defgeneric get-applicable-time-signatures (object1 object2)) +(defgeneric get-applicable-time-signatures (anchored-period composition) + (:method (ap c) (find-overlapping ap (time-signatures c)))) ;;; Tempo -(defgeneric get-applicable-tempi (object1 object2)) +(defgeneric get-applicable-tempi (anchored-period composition) + (:method (ap c) (find-overlapping ap (tempi c)))) ;;; Tonality (Key Signature / Mode)
--- a/base/methods.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/base/methods.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -15,9 +15,15 @@ (defmethod duration ((period-designator period)) (%period-interval period-designator)) +(defmethod (setf duration) ((value real) (period-designator period)) + (setf (%period-interval period-designator) value)) + (defmethod timepoint ((moment-designator moment)) (%moment-time moment-designator)) +(defmethod (setf timepoint) ((value real) (moment-designator moment)) + (setf (%moment-time moment-designator) value)) + (defmethod beat-units-per-bar ((time-signature basic-time-signature)) (%basic-time-signature-numerator time-signature)) @@ -197,6 +203,14 @@ ;; ...and +(defmethod period= ((object1 anchored-period) + (object2 anchored-period)) + (and (time= object1 object2) + (duration= object1 object2))) +(defmethod period= ((object1 floating-period) + (object2 floating-period)) + (duration= object1 object2)) + (defmethod period-intersection ((object1 anchored-period) (object2 anchored-period)) (cond @@ -212,7 +226,5 @@ (cut-off object2)) start)))) (make-anchored-period (timepoint start) duration))))) - - \ No newline at end of file
--- a/base/package.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/base/package.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -26,6 +26,9 @@ #:basic-key-signature #:tempo #:get-composition + #:time-signatures + #:tempi + #:key-signatures #:chromatic-pitch #:diatonic-pitch #:midi-pitch-number @@ -34,18 +37,19 @@ #:span #:duration #:timepoint - #:onset #:cut-off #:beat-units-per-bar #:time-signature-numerator #:beat-units #:time-signature-denominator + #:tactus-duration #:key-signature-sharps #:bpm #:microseconds-per-crotchet #:anchored-period #:floating-period #:moment + #:onset #:time+ #:time- #:time> @@ -84,6 +88,8 @@ #:ends #:subinterval #:disjoint + #:period= + #:find-overlapping #:period-intersection #:inter-onset-interval #:get-applicable-time-signatures
--- a/implementations/midi/classes.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/implementations/midi/classes.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -1,5 +1,16 @@ (cl:in-package #:amuse-midi) +(defclass midi-composition (amuse:composition) + ((time-signatures :initarg :time-signatures + :initform 'nil + :accessor %midi-time-signatures) + (tempi :initarg :tempi + :initform 'nil + :accessor %midi-tempi) + (misc-controllers :initarg :controllers + :initform 'nil + :accessor %midi-misc-controllers))) + (defclass midi-message () ;? ((channel :accessor %midi-message-channel :initarg :channel) (track :accessor %midi-message-track :initarg :track))) @@ -13,8 +24,10 @@ (defclass midi-percussive-event (percussive-event midi-message) ((velocity :initarg :velocity :accessor %midi-percussive-event-velocity) - (patch :initarg :patch) - (sound :initarg :sound))) + (patch :initarg :patch + :accessor %midi-percussive-event-patch) + (sound :initarg :sound + :accessor %midi-percussive-event-sound))) (defclass midi-key-signature (basic-key-signature) ;; Is mode ever used in real life? Is it ever accurately used in
--- a/implementations/midi/package.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/implementations/midi/package.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -1,6 +1,7 @@ (cl:defpackage #:amuse-midi - (:use #:common-lisp #:amuse) - (:export #:midi-pitched-event + (:use #:common-lisp #:amuse #:amuse-utils) + (:export #:midi-composition + #:midi-pitched-event #:midi-percussive-event #:midi-key-signature #:make-midi-pitched-event @@ -9,5 +10,10 @@ #:midi-channel #:midi-track #:midi-velocity - #:midi-patch)) + #:midi-patch + #:midi-drum-sound + #:time-signatures + #:tempi + #:microsecond-per-crotchet-to-bpm + ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/harmony/chord-labelling.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,683 @@ +(in-package #:amuse-harmony) + +;; This file contains functions for performing harmonic analysis and +;; chord labelling. At the moment it's quite crude. +;; +;; Probability can be estimated based on a function that must take a +;; window on the music (i.e. an anchored period and a composition (? +;; or perhaps a 'constituent' in future?). The functionality below is +;; a cut-down version of its predecessors and only models one pitch +;; model, derived by combining dirichlet distributions on the local +;; distribution of pitch-class durations in terms of +;; chord-note:non-chord-note ratios and relative weighting of chord +;; notes. +;; +;; * Chord objects contain details of chord types including the +;; intervals of their constituents and any putative distributional +;; information or note profiles or templates. +;; +;; * Chordset objects gather chord-types together for a given +;; experiment. They have a slot for priors for historical reasons, but +;; at the moment this is unused - I'm using other structures for this. +;; +;; * likelihoods are currently alists with a host of methods. (FIXME: +;; this doesn't seem very clever) +;; + +;; FIXME: this is in the wrong place +(defparameter *keys* (make-array 12 :initial-contents '(:c :c# :d :eb :e :f :f# :g :g# :a :bb :b))) + +(defparameter *path-options* + ;; Each of these is a set of division-of-the-bar options for each + ;; metrical type. + ;; + ;; FIXME: behaviour if the time-signature numerator is absent from + ;; the alist is undefined. + '((4 (1 1 1 1) (1 1 2) (1 2 1) (1 3) + (2 1 1) (2 2) (3 1) (4)) + ;; (4 (1 1 1 1) (1 1 2) (2 1 1) (2 2) (4)) + (2 (1 1) (2)) + (3 (1 1 1) (1 2) (2 1) (3)) + (6 (3 3) (6)) + (5 (1 1 1 1 1) (1 1 1 2) (1 1 2 1) (1 1 3) + (1 2 1 1) (1 2 2) (1 3 1) (1 4) + (2 1 1 1) (2 1 2) (2 2 1) (2 3) + (3 1 1) (3 2) (4 1) (5)) + (9 (3 3 3) (3 6) (6 3) (9)) + (12 (3 3 3 3) (3 3 6) (3 6 3) (3 9) + (6 3 3) (6 6) (9 3) (12)))) + +#+nil +(defparameter *default-models* '(:constant-prior :gamma)) +#+nil +(defparameter *default-models* '(:scaled-prior :gamma :naive-bass)) +;; #+nil +(defparameter *default-models* '(:scaled-prior :gamma)) +#+nil +(defparameter *default-models* '(:scaled-prior :gamma :metrical-prior)) + +;;; ACCESSORS +;; Nearly empty now. And not much point in what's left +(defgeneric normalised-distribution (chord &optional total)) +(defmethod normalised-distribution ((chord chord) &optional (total 1)) + ;; normalised distributions will be reused, so it makes sense to + ;; store them. + ;; FIXME: Are these ever going to be useful again? + (unless (assoc total (slot-value chord 'normalised-distribution)) + (setf (slot-value chord 'normalised-distribution) + (acons total (normalise-vector (slot-value chord 'distribution) total) + (slot-value chord 'normalised-distribution)))) + (cdr (assoc total (slot-value chord 'normalised-distribution)))) + +;;; Object definitions + +#+nil +(defparameter *major-ratios* (mapcar (lambda (x) (/ x 217)) + '(180 1 1 1 20 1 1 8 1 1 1 1))) +#+nil +(defparameter *major-ratios* (mapcar (lambda (x) (/ x 20)) + '(5 1 2 1 3 1 1 2 1 1 1 1))) +(defparameter *major-ratios* #(0.72 0.02 0.02 0.02 0.08 0.02 0.02 0.02 0.02 0.02 0.02 0.02)) +#+nil +(defparameter *minor-ratios* (mapcar (lambda (x) (/ x 302)) + '(280 1 1 4 1 1 1 9 1 1 1 1))) +(defparameter *minor-ratios* #(0.78 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02)) +#+nil +(defparameter *minor-ratios* (mapcar (lambda (x) (/ x 20)) + '(7 1 2 2 1 1 1 1 1 1 1 1))) +#+nil +(defparameter *sus-ratios* (mapcar (lambda (x) (/ x 21)) + '(10 1 1 1 1 1 1 1 1 1 1 1))) +(defparameter *sus-ratios* #(0.78 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02 0.02)) + +(defparameter *dim-ratios* (copy-seq *sus-ratios*)) +(defparameter *aug-ratios* (copy-seq *sus-ratios*)) + +;; Chords +(defparameter *major-chord* + (make-instance 'chord + :label :major + :notes '(0 4 7) + :bass-likelihoods (make-array 12 + :initial-contents *major-ratios*) + :min-distribution (make-array 4 :initial-contents '(35 25 20 20)) + :distribution (make-array 12 + :initial-contents '(6 1 2 1 5 2 1 5 1 2 2 2)))) + +(defparameter *minor-chord* + (make-instance 'chord :label :minor :notes '(0 3 7) + :min-distribution (make-array 4 :initial-contents '(35 25 20 20)) + :bass-likelihoods (make-array 12 + :initial-contents *minor-ratios*) + :distribution (make-array 12 + :initial-contents '(6 1 2 5 1 2 1 5 2 1 2 1)))) + +(defparameter *diminished-chord* + (make-instance 'chord :label :dim :notes '(0 3 6) + :min-distribution (make-array 4 :initial-contents '(35 25 20 20)) + :bass-likelihoods (make-array 12 + :initial-contents *dim-ratios*) + :distribution (make-array 12 + :initial-contents '(6 1 1 5 1 1 5 1 1 4 1 1)))) + +(defparameter *diminished-chord-short* + (make-instance 'chord :label :dim :notes '(0 3 6 9) + :min-distribution (make-array 4 :initial-contents '(35 25 20 20)) + :distribution (make-array 3 + :initial-contents '(6 1 1)))) + +(defparameter *augmented-chord* + (make-instance 'chord :label :aug :notes '(0 4 8) :min-distribution #(35 25 20 20) + :bass-likelihoods (make-array 12 + :initial-contents *aug-ratios*) + :distribution (make-array 12 + :initial-contents '(6 1 1 1 5 1 1 1 5 1 1 1)))) + +(defparameter *augmented-chord-short* + (make-instance 'chord :label :aug :notes '(0 4 8) + :distribution (make-array 4 + :initial-contents '(6 1 1 1)))) + +(defparameter *suspended4th-chord* + (make-instance 'chord :label :sus4 :notes '(0 5 7) + :min-distribution (make-array 4 :initial-contents '(35 25 20 20)) + :bass-likelihoods (make-array 12 + :initial-contents *sus-ratios*) + :distribution (make-array 12 + :initial-contents '(6 1 2 3 3 5 1 5 1 1 2 2)))) + +(defparameter *suspended9th-chord* + (make-instance 'chord :label :sus9 :notes '(0 2 7) + :min-distribution (make-array 4 :initial-contents '(35 25 20 20)) + :bass-likelihoods (make-array 12 + :initial-contents *sus-ratios*) + :distribution (make-array 12 + :initial-contents '(6 1 5 2 2 2 1 5 1 2 2 1)))) + +;; CHORDSETS +(defparameter *full-set* + (make-instance 'chordset :chords (list *major-chord* *minor-chord* + *diminished-chord* *augmented-chord* + *suspended4th-chord* *suspended9th-chord*))) + +(defparameter *full-set-variable-length* + (make-instance 'chordset :chords (list *major-chord* *minor-chord* + *diminished-chord-short* *augmented-chord-short* + *suspended4th-chord* *suspended9th-chord*))) + +(defparameter *partial-set* + (make-instance 'chordset :chords (list *major-chord* *minor-chord* + *diminished-chord* *augmented-chord*))) + +(defparameter *partial-set-variable-length* + (make-instance 'chordset + :chords (list *major-chord* *minor-chord* + *diminished-chord-short* + *augmented-chord-short*))) + +(defparameter *minimal-set* + (make-instance 'chordset :chords (list *major-chord* *minor-chord*))) + +#+nil +(defparameter *chord-proportions* ;; guess + (list (cons *major-chord* 17/30) (cons *minor-chord* 10/30) + (cons *diminished-chord* 1/60) (cons *augmented-chord* 1/60) + (cons *suspended4th-chord* 1/30) (cons *suspended9th-chord* 1/30))) + +#+nil +(defparameter *chord-proportions* ;; another guess + (list (cons *major-chord* 1/3) (cons *minor-chord* 1/3) + (cons *diminished-chord* 1/30) (cons *augmented-chord* 1/60) + (cons *suspended4th-chord* 1/5) (cons *suspended9th-chord* 1/12))) +#+nil +(defparameter *chord-proportions* ;; flat + (list (cons *major-chord* 1/6) (cons *minor-chord* 1/6) + (cons *diminished-chord* 1/6) (cons *augmented-chord* 1/6) + (cons *suspended4th-chord* 1/6) (cons *suspended9th-chord* 1/6))) + +(defparameter *chord-proportions* + ;; observed + ;; FIXME: This seriously impairs dim and aug. Do they ever get + ;; diagnosed now? + (list (cons *major-chord* 546/917) (cons *minor-chord* 312/917) + (cons *diminished-chord* 2/917) (cons *augmented-chord* 1/917) + (cons *suspended4th-chord* 44/917) (cons *suspended9th-chord* 12/917))) + + +;; First steps to chord labelling +(defun get-chord-likelihoods-for-model (anchored-period music + &key (model :gamma) + (chordset *full-set*)) + ;; Currently expects and returns an alist of (identifier + ;; . likelihood) (unnormalised, but can use normalise-likelihoods) + (ecase model + (:constant-prior + ;; results are divided by number of chords in chordset (times 12) + (constant-prior-likelihoods anchored-period + music + chordset)) + (:scaled-prior + ;; results are divided by preset chord weightings (times 12) + (scaled-prior-likelihoods anchored-period + music + chordset)) + (:naive-bass + (naive-bass-prior-likelihoods anchored-period + music + chordset)) + (:metrical-prior + (metrical-prior-likelihoods anchored-period + music + chordset)) + (:gamma + ;; dirichlet-based likelihood calculation + (3ple-gamma-likelihoods anchored-period + music + chordset)))) + +;; LIKELIHOOD-CALCULATION FUNCTIONS +(defgeneric metrical-prior-likelihoods (anchored-period music chordset)) +(defmethod metrical-prior-likelihoods ((anchored-period anchored-period) + music chordset) + (let* ((metrical-level (metrical-level-for-likelihood anchored-period music)) + (p (if (= metrical-level 1) + 0.51 + 0.07))) + (loop for chord in (chords chordset) + nconc (loop for i from 0 to 11 + collect (cons (list i chord) + (/ p (* 12 (length (chords chordset))))))))) + +(defgeneric constant-prior-likelihoods (anchored-period music chordset)) +(defmethod constant-prior-likelihoods ((anchored-period anchored-period) + music chordset) + ;; returns a flat distribution totalling 1 + (loop for chord in (chords chordset) + nconc (loop for i from 0 to 11 + collect (cons (list i chord) + (/ 1 (* 12 (length + (chords chordset)))))))) + +(defgeneric scaled-prior-likelihoods (anchored-period music chordset &key prior-alist)) +(defmethod scaled-prior-likelihoods ((anchored-period anchored-period) music chordset + &key (prior-alist *chord-proportions*)) + ;; returns a distribution based on the relative likelihood of chord types + (loop for chord in (chords chordset) + nconc (loop for i from 0 to 11 + collect (cons (list i chord) + (/ (cdr (assoc chord prior-alist)) + 12))))) + +(defgeneric naive-bass-prior-likelihoods (anchored-period music chordset)) +(defmethod naive-bass-prior-likelihoods ((anchored-period anchored-period) music chordset) + (let ((pc (bass-note anchored-period music))) + (loop for chord in (chords chordset) + nconc (loop for i from 0 to 11 + collect (cons (list i chord) + (/ (aref (bass-likelihoods chord) + (mod (+ i pc) 12)) + (length (chords chordset)))))))) + +(defgeneric 3ple-gamma-likelihoods (anchored-period music chordset)) +(defmethod 3ple-gamma-likelihoods ((anchored-period anchored-period) music chordset) + ;; Ask Christophe about what this one does - this function just + ;; provides data to his dirichlet likelihood functions. Currently + ;; limited to triads, this has two distributions for relative + ;; strengths of chord notes and for the relation between chord and + ;; non-chord notes. + (let ((pitch-classes (normalised-pitch-class-distribution anchored-period music)) + (metrical-level (metrical-level-for-likelihood anchored-period music)) + (likelihoods)) + (dolist (chord (chords chordset) likelihoods) + (let ((chord-likelihoods (subseq (min-distribution chord) 0 3)) + (non-chord (aref (min-distribution chord) 3))) + (loop for offset from 0 to 11 + do (setf likelihoods + (set-likelihood + likelihoods chord offset + (3ple-likelihood (chromatic-rotate pitch-classes (- offset)) + chord-likelihoods + non-chord + (main-notes chord) + metrical-level 1 + (get-alphas chord metrical-level :version :learned) + (get-betas chord metrical-level :version :learned))))))))) + +#+nil +(defun get-alphas (chord metrical-level &key (version :map)) + ;; MP values, map commented + (cond + ((or (eq *major-chord* chord) + (eq *minor-chord* chord)) + (cond + ((< metrical-level 1) + (case version + (:map #(3.7812 2.4955 2.1525)) + (:ml #(4.0398 2.6624 2.2942)) + (:learned #(2.0475 1.365 1.1374999)))) + (t + (case version + (:map #(3.6626 1.5234 2.3395)) + (:ml #(3.9119 1.6193 2.4955)) + (:learned #(2.0475 1.365 1.1374999)))))) + (t + (case version + (:map #(3.5110 2.0252 1.2963)) + (:ml #(4.0822 2.3459 1.4874)) + (:learned #(2.0475 1.365 1.1374999)))))) + +;; New, corrected ground truth +(defun get-alphas (chord metrical-level &key (version :map)) + ;; MP values, map commented + (cond + ((or (eq *major-chord* chord) + (eq *minor-chord* chord)) + (cond + ((< metrical-level 1) + (case version + (:map #(3.7397 2.4923 2.0187)) + (:ml #(3.9434 2.6253 2.1239)) + (:learned #(2.0475 1.365 1.1374999)))) + (t + (case version + (:map #(3.2620 1.3882 2.2542)) + (:ml #(3.5200 1.4889 2.4293)) + (:learned #(2.0475 1.365 1.1374999)))))) + (t + (case version + (:map #(3.1963 1.8187 1.3340)) + (:ml #(3.6371 2.0621 1.2799)) + (:learned #(2.0475 1.365 1.1374999)))))) + +#+nil +(defun get-betas (chord metrical-level &key (version :map)) + (cond + ((eq version :learned) + (cond + ((> metrical-level 1/2) + #(0.97 12)) + ((= metrical-level 1/2) + #(0.97 6)) + (t #(0.97 4)))) + ((or (eq *major-chord* chord) + (eq *minor-chord* chord)) + (if (< metrical-level 1) + (if (eq version :map) + #(0.6987 3.1724) + #(0.7164 3.2640)) + (if (eq version :map) + #(1.3677 5.9215) + #(1.4454 6.2843)))) + (t + (if (eq version :map) + #(0.9358 5.2212) + #(1.0431 5.8530))))) + +;; With new, corrected ground truth +(defun get-betas (chord metrical-level &key (version :map)) + (cond + ((eq version :learned) + (cond + ((> metrical-level 1/2) + #(0.97 12)) + ((= metrical-level 1/2) + #(0.97 6)) + (t #(0.97 4)))) + ((or (eq *major-chord* chord) + (eq *minor-chord* chord)) + (if (< metrical-level 1) + (if (eq version :map) + #(0.7041 3.3448) + #(0.7190 3.4260)) + (if (eq version :map) + #(1.3838 6.4581) + #(1.4872 6.9785)))) + (t + (if (eq version :map) + #(0.9558 5.0847) + #(1.0551 5.6740))))) + + +(defun chromatic-rotate (vector offset) + ;; transpose an n-member (chromatic) vector by an integral number of + ;; steps (semitones) + (let* ((size (length vector)) + (result (make-array size))) + (dotimes (i size result) + (setf (aref result i) (aref vector (mod (- i offset) size)))))) + +(defgeneric metrical-level-for-likelihood (anchored-period music)) +(defmethod metrical-level-for-likelihood (anchored-period (music composition)) + ;; metrical level is a function of time signature and window size + ;; and is used to modify the gamma function. + (let ((time-sigs (get-applicable-time-signatures anchored-period music))) + (cond + ((= (length time-sigs) 1) + (/ (duration anchored-period) + (crotchets-in-a-bar (first time-sigs)))) + ((null time-sigs) + ;; If, for some reason, we have no time-signature, midi specs + ;; say assume 4/4. + (/ (duration anchored-period) 4)) + (t + (loop for sig in time-sigs + sum (/ (duration (period-intersection sig + anchored-period)) + (crotchets-in-a-bar sig))))))) + +;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Hypothesis comparison / level navigation +;; + +(defun chord-labels (anchored-period music + &key (chordset *full-set*) + (models *default-models*)) + (let ((harmonic-analysis (best-level anchored-period music :chordset chordset :models models)) + (best-likelihood) (chord-labels)) + (do ((path (first harmonic-analysis) (cdr path)) + (likelihoods (second harmonic-analysis) (cdr likelihoods))) + ((null path) (reverse chord-labels)) + (dolist (likelihood (car likelihoods)) + (when (or (null best-likelihood) + (> (likelihood-likelihood likelihood) + (likelihood-likelihood best-likelihood))) + (setf best-likelihood likelihood))) + (push (cons (first path) (likelihood-chord best-likelihood)) chord-labels) + (setf best-likelihood nil)))) + +(defun best-level (anchored-period music + &key (chordset *full-set*) + (models *default-models*)) + ;; Takes a period for the largest time-unit being considered and + ;; returns the highest probability subdivision, its likelihood + ;; values (and the probability of that subdivision, but that's a bit + ;; of a coincidence and may want not to happen) + (best-level-hypothesis (make-metrical-divisions anchored-period music) + music :chordset chordset :models models)) + +(defgeneric make-metrical-divisions (anchored-period music)) +(defmethod make-metrical-divisions ((anchored-period anchored-period) + (music composition)) + ;; Prepares a set of divisions of the period based on time-sig and a + ;; pre-set list of options for each possible time-sig numerator. + (let ((time-sigs (get-applicable-time-signatures anchored-period music))) + (if + (< (length time-sigs) 2) + (let ((candidates)) + ;; get an appropriate set of divisions. Not sure this is right + ;; - it relies on bar position being irrelevant. Is this true? + ;; This isn't really clear from this code, but if there are no + ;; time-signatures, make-divisions-with-timesigs has a test for + ;; it and will pretend it's 4/4. + (dolist (divisions (make-divisions-with-time-signature anchored-period (car time-sigs)) + candidates) + (do ((time (onset anchored-period) (cut-off (car candidate-set))) + (divisions divisions (cdr divisions)) + (candidate-set)) + ((null divisions) (push (reverse candidate-set) candidates)) + (push (make-anchored-period (timepoint time) (first divisions)) + candidate-set)))) + ;; otherwise, there are lots. Run this function once for each + ;; time-signature. + (loop for time-sig in time-sigs + nconc (make-metrical-divisions (period-intersection anchored-period time-sig) + music))))) + +(defgeneric make-divisions-with-time-signature (period time-signature)) +(defmethod make-divisions-with-time-signature ((period period-designator) + (time-signature basic-time-signature)) + (let* ((numerator (time-signature-numerator time-signature)) + (denominator (time-signature-denominator time-signature)) + (path-options (cdr (assoc numerator *path-options*)))) + (loop for divisions in path-options + collect (period-fill period divisions denominator)))) + +(defmethod make-divisions-with-time-signature ((period period-designator) + time-signature) + ;; not a known time-signature type. Assume 4/4 + (let ((path-options (cdr (assoc 4 *path-options*)))) + (loop for divisions in path-options + collect (period-fill period divisions 4)))) + +(defun period-fill (period path-options denominator) + ;; take a division of the ?bar and then repeat it until the period + ;; is filled. + ;; + ;; Perhaps this and surrounding function need to make more use of + ;; time interface? + (let ((duration-list) + ;; Multiply path-options by unit of meter. + (path-options (map 'list + #'(lambda (x) (* x (/ 4 denominator))) + path-options))) + (do* ((circular-path path-options (or (cdr circular-path) + path-options)) + (current-duration (car circular-path) (car circular-path)) + (prev-remaining (duration period) remaining) + (remaining (- (duration period) current-duration) (- remaining current-duration))) + ((<= remaining 0) (reverse (cons prev-remaining duration-list))) + (push current-duration duration-list)))) + +(defun best-level-hypothesis (division-hypotheses music + &key (chordset *full-set*) + (models *default-models*)) + ;; Rather messy wrapper for level-hypothesis-likelihoods. Should + ;; probably make this a structure or something, but use looks like + ;; being quite limited. might revisit. + (first (sort (level-hypothesis-likelihoods division-hypotheses + music + :chordset chordset + :models models) + #'> :key #'third))) + +(defun level-hypothesis-likelihoods (division-hypotheses music + &key (chordset *full-set*) + (models *default-models*)) + ;; This function takes the candidate windows being considered (as + ;; lists of anchored periods) and, for each, works out likelihoods + ;; and the most probable hypothesis. This should come from taking + ;; the likelihoods and dividing by the product of the internal sums + ;; (don't ask!) + (let ((hypothesis-likelihoods)) + (dolist (hypothesis division-hypotheses hypothesis-likelihoods) + (let ((likelihoods (map 'list + #'(lambda (x) + (get-chord-likelihoods x music models chordset)) + hypothesis))) + (push (list hypothesis likelihoods (combined-likelihoods-sum likelihoods)) + hypothesis-likelihoods))))) + +(defun get-chord-likelihoods (anchored-period music models chordset) + (let ((model-likelihoods + (loop for model in models + collect (get-chord-likelihoods-for-model anchored-period + music + :model model + :chordset chordset)))) + (combine-multimodel-likelihoods model-likelihoods))) + +(defun combine-multimodel-likelihoods (likelihoods-list) + (cond + ((= (length likelihoods-list) 1) + (car likelihoods-list)) + (t + (let ((combined-likelihoods)) + (dolist (reference-likelihood (car likelihoods-list) combined-likelihoods) + (setf combined-likelihoods + (set-likelihood combined-likelihoods + (likelihood-chordtype reference-likelihood) + (likelihood-pitch-class reference-likelihood) + (apply #'* (loop for model-likelihoods in likelihoods-list + collect (likelihood-likelihood + (assoc (car reference-likelihood) + model-likelihoods + :test #'equal))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Likelihood (structure) manipulation and access methods +;; + +(defgeneric set-likelihood (likelihoods offset chord likelihood)) +(defmethod set-likelihood ((likelihoods list) chord offset likelihood) + (acons (list offset chord) likelihood likelihoods)) + +(defgeneric get-likelihood (likelihoods offset chord)) +(defmethod get-likelihood ((likelihoods list) offset chord) + (assoc (list offset chord) likelihoods :test #'equal)) + +(defgeneric best-n-likelihoods (n likelihoods)) +(defmethod best-n-likelihoods (n (likelihoods list)) + (let ((ranked (ordered-likelihoods likelihoods))) + (subseq ranked 0 n))) + +(defgeneric ordered-likelihoods (likelihoods)) +(defmethod ordered-likelihoods ((likelihoods list)) + (sort (copy-seq likelihoods) #'> :key #'cdr)) + +(defgeneric pretty-display-likelihoods (likelihoods)) +(defmethod pretty-display-likelihoods ((likelihoods list)) + (dolist (p likelihoods) + (format *standard-output* "~%~A~C~A~C~A" + (likelihood-key p) #\Tab + (chord-label (likelihood-chordtype p)) #\Tab + (likelihood-likelihood p)))) + +(defgeneric likelihood-key (likelihood)) +(defmethod likelihood-key ((likelihood list)) + (aref *keys* (first (first likelihood)))) + +(defgeneric likelihood-pitch-class (likelihood)) +(defmethod likelihood-pitch-class ((likelihood list)) + (first (first likelihood))) + +(defgeneric likelihood-chordtype (likelihood)) +(defmethod likelihood-chordtype ((likelihood list)) + (second (first likelihood))) + +(defgeneric likelihood-chord (likelihood)) +(defmethod likelihood-chord ((likelihood list)) + (first likelihood)) + +(defgeneric likelihood-likelihood (likelihood)) +(defmethod likelihood-likelihood ((likelihood list)) + (cdr likelihood)) + +(defgeneric likelihoods-sum (likelihoods)) +(defmethod likelihoods-sum ((likelihoods list)) + (loop for likelihood in likelihoods + sum (likelihood-likelihood likelihood))) + +(defgeneric combined-likelihoods-sum (combined-likelihoods)) +(defmethod combined-likelihoods-sum ((combined-likelihoods list)) + ;; Will be needed for hypothesis comparison - sums the likelihoods + ;; for all chords within a window for multiple likelihood + ;; calculations + (apply #'* (map 'list #'(lambda (window) + (loop for likelihood in window + sum (likelihood-likelihood likelihood))) + combined-likelihoods))) + +(defgeneric normalise-likelihoods (likelihoods)) +(defmethod normalise-likelihoods ((likelihoods list)) + (let ((p-sum (sum-likelihoods likelihoods))) + (if (= p-sum 1) + likelihoods + (scale-likelihoods likelihoods (/ 1 p-sum))))) + +(defgeneric scale-likelihoods (likelihoods scale-factor)) +(defmethod scale-likelihoods ((likelihoods list) (scale-factor number)) + (map 'list #'(lambda (x) + (cons (first x) + (* (cdr x) scale-factor))) + likelihoods)) + +(defgeneric sum-likelihoods (likelihoods)) +(defmethod sum-likelihoods ((likelihoods list)) + (apply #'+ (map 'list #'cdr likelihoods))) + +;; Probably useless vestigial stuff from here + +(defun vector-list-apply (predicate vector-list &optional other-args) + (let ((result-list)) + (dolist (vector vector-list (reverse result-list)) + (push (make-array (array-dimensions vector)) result-list) + (loop for i from 0 to (1- (length vector)) + do (setf (aref (first result-list) i) + (apply predicate (cons (aref vector i) other-args))))))) + +(defun vector-sum (vector) + (loop for i from 0 to (1- (length vector)) + sum (aref vector i))) + +(defun make-flat-result (chordset) + (map 'list #'(lambda (x) + (make-array (length (distribution x)) + :initial-element 0)) + (chords chordset))) + +(defun key-name (pitch-class) + (if pitch-class + (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "G#" "A" "Bb" "B") (mod pitch-class 12)) + nil)) \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/harmony/classes.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,57 @@ +(in-package #:amuse-harmony) + +;; This file contains classes for use in the harmony module. There are +;; two sets of classes here: those used in the chord-labelling itself, +;; and those used for label-evaluation and comparison with ground +;; truth. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; CHORD LABELLING +;; +;; Chord objects are the fundamental object for identifying and naming +;; chord types they also give info about pitch classes and +;; distribution. + +(defclass chord () + ((label :accessor chord-label + :initarg :label) + (main-notes :accessor main-notes + :initarg :notes) + (bass-likelihoods :accessor bass-likelihoods + :initarg :bass-likelihoods) + (min-distribution :accessor min-distribution + :initarg :min-distribution) + (distribution :accessor distribution + :initarg :distribution) + (normalised-distribution :initarg :normalised-distribution + :initform nil))) + +;; A chordset is a gathering of chords for experiment. There are slots +;; for priors, but I'm not using them at the moment (see below for +;; current, not very good, method). + +(defclass chordset () + ((chords :accessor chords + :initarg :chords + :initform nil) + (priors :accessor priors + :initarg :priors + :initform nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; EVALUATION +;; + +(defclass labelled-chord-period (anchored-period) + ((root-pitch-class :writer %labelled-chord-root + :reader labelled-chord-root + :initarg :root) + (chord-type :writer %labelled-chord-type + :reader labelled-chord-type + :initarg :chord-type) + (bass :writer %labelled-chord-bass + :reader labelled-chord-bass + :initarg :bass))) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/harmony/evaluation.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,882 @@ +;; Stuff to compare: path (per model); correct window (per model); correct window|bass; correct window|bass + +(in-package #:amuse-harmony) + +(defparameter *test-pieces* '()) +(defparameter *test-set* '()) +(defparameter *dm-note-names* '("c" "c+" "d" "e-" "e" "f" "f+" "g" "g+" "a" "b-" "b")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Ground-truth data types and functions +;; + +(clsql:def-view-class truth-chord () + ((cat_id + :type integer + :accessor cat_id) + (onset_bar + :type integer + :accessor start-bar) + (onset_beat + :type integer + :accessor start-beat) + (root + :type string) + (bass + :type string) + (chord-type + :type string + :accessor chord-type) + (file + :accessor harmony-file + :db-kind :join + :db-info (:join-class file + :home-key cat_id + :foreign-key cat_id + :set nil))) + (:base-table geerdes_harmony)) + +(defun all-chords () + #.(clsql:locally-enable-sql-reader-syntax) + (map 'list #'car (clsql:select 'truth-chord :where 1)) + #.(clsql:restore-sql-reader-syntax-state)) + +(defun list-harmonised-pieces () + (remove-if #'(lambda (x) (member x '(886 5205 10586 3473 6993))) + (remove-duplicates (map 'list + #'cat_id + (all-chords))))) + +(defun harmonised-bars (id) + ;; List bars which have harmonies from piece with cat_id=id + (let* ((piece-chords (piece-chord-list id))) + (when piece-chords + (let* ((chord-starts (map 'list #'start-bar piece-chords)) + (bar-max (1+ (apply #'max chord-starts))) + (bar-min (apply #'min chord-starts)) + (bar-numbers)) + (setf piece-chords (sort piece-chords #'chord-time->)) + (do ((bar bar-min (1+ bar))) + ((= bar bar-max) bar-numbers + #+nil (make-array (length bar-numbers) + :initial-contents (reverse bar-numbers))) + (let ((harmony (get-applicable-chord (* 4 bar) piece-chords))) + (when (and harmony + (> (length (chord-type harmony)) 0)) + (push bar bar-numbers)))))))) + +(defun get-applicable-chord (beats chords &key (pre-sorted t)) + ;; Return the chord that would be sounding at a given point in + ;; time. If this is being applied many times, it makes sense to sort + ;; the data before providing it, hence the &key argument. + (unless pre-sorted + (setf chords (sort chords #'chord-time->))) + (find-if #'(lambda (x) (or (< (start-bar x) + (floor beats 4)) + (and (= (start-bar x) + (floor beats 4)) + (<= (start-beat x) + (1+ (mod beats 4)))))) + chords)) + +(defun chord-time-> (chord1 chord2) + (or (> (start-bar chord1) + (start-bar chord2)) + (and (= (start-bar chord1) + (start-bar chord2)) + (> (start-beat chord1) + (start-beat chord2))))) + +(defun chord-time-< (chord1 chord2) + (or (< (start-bar chord1) + (start-bar chord2)) + (and (= (start-bar chord1) + (start-bar chord2)) + (< (start-beat chord1) + (start-beat chord2))))) + +(defun harmonised-pieces-bars-alist () + (let ((harmonised)) + (dolist (piece (list-harmonised-pieces) harmonised) + (setf harmonised (acons piece (harmonised-bars piece) harmonised))))) + +(defun all-bars () + (let ((harmonised)) + (dolist (piece (list-harmonised-pieces) harmonised) + (dolist (bar (harmonised-bars piece)) + (push (cons piece bar) harmonised))))) + +(defun random-bars (target) + (let* ((selection) (pieces-bars (make-array 1 :adjustable T :fill-pointer T))) + (dolist (piece (list-harmonised-pieces)) + (loop for bar in (harmonised-bars piece) + do (vector-push-extend (cons piece bar) pieces-bars))) + (loop for i from 0 to (1- target) + do (progn + (rotatef (aref pieces-bars i) + (aref pieces-bars + (+ i (random (- (1- (length pieces-bars)) + i))))) + (push (aref pieces-bars i) selection))) + selection)) + +(defun write-piece-bars (list filename) + (with-open-file (stream filename :direction :output :if-exists :supersede) + (dolist (bar list) + (format stream "~A~C~A~%" (car bar) #\Tab (cdr bar))))) + +(defun read-piece-bars (filename) + (let ((bars)) + (with-open-file (stream filename) + (do ((line (read-line stream nil nil) (read-line stream nil nil))) + ((null line) bars) + (let* ((s (make-string-input-stream line)) + (piece (read s)) + (bar (read s))) + (push (cons piece bar) bars)))))) + +(defun get-window-sizes (piece bar &optional (odd-divisions nil)) + (let ((bar-chords (sort (remove-if #'(lambda (x) (or (not (= (cat_id x) piece)) + (not (= (start-bar x) bar)))) + (all-chords)) + #'chord-time-<))) + (if odd-divisions + (get-window-sizes-2 bar-chords) + (get-window-sizes-1 bar-chords)))) + +(defun get-window-sizes-2 (bar-chords) + (let ((path) (prev-chord)) + (dolist (beat-chord bar-chords) + (cond + (prev-chord + (push (- (start-beat beat-chord) + (start-beat prev-chord)) + path)) + ((and (not prev-chord) + (> (start-beat beat-chord) 1)) + (push (- (start-beat beat-chord) 1) + path))) + (setf prev-chord beat-chord)) + (if prev-chord + (push (- 5 (start-beat prev-chord)) + path) + (setf path '(4))) + (reverse path))) + +(defun get-window-sizes-1 (bar-chords) + (let ((path) (prev-chord)) + (dolist (beat-chord bar-chords) + (cond + ((and (not prev-chord) + (= (start-beat beat-chord) 4)) + ;; Three beats of preceding chord or no chord + (return-from get-window-sizes-1 '(2 1 1))) + ((and (not prev-chord) + (> (start-beat beat-chord) 1)) + ;; not the first chord of bar - just the first to sound + (push (1- (start-beat beat-chord)) path)) + ((and (= (start-beat beat-chord) 4) + (< (start-beat prev-chord) 3)) + ;; Last chord of bar, but its predecessor spans half-bar + ;; break. + (return-from get-window-sizes-1 (reverse (concatenate 'list + (list 1 1 (- 3 (start-beat prev-chord))) + path)))) + ((= (start-beat beat-chord) 4) + ;; last chord of bar + (return-from get-window-sizes-1 (reverse (concatenate 'list + (list 1 1) + path)))) + (prev-chord + (push (- (start-beat beat-chord) (start-beat prev-chord)) + path))) + (setf prev-chord beat-chord)) + (if prev-chord + (if (= (start-beat prev-chord) 2) + '(1 1 2) + (reverse (cons (- 5 (start-beat prev-chord)) path))) + '(4)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-test-piece (cat-id) + (unless (assoc cat-id *test-pieces*) + (setf *test-pieces* (acons cat-id + (get-composition (make-geerdes-cat-identifier cat-id)) + *test-pieces*))) + (cdr (assoc cat-id *test-pieces*))) + +(in-package "AMUSE-GEERDES") + +(defclass harmonic-evaluation-period (anchored-period) + ((cat-id :accessor %cat-id + :initarg :cat-id) + (file-id :accessor %file-id + :initarg :file-id) + (composition :accessor %composition + :initarg :composition) + (bar-number :accessor %bar-number + :initarg :bar-number) + (composition-bar-number :accessor %c-bar-number + :initarg :comp-bar-number) + (ground-truth-chords :accessor %gt-chords + :initarg :gt-chords + :initform nil) + (derived-windows :accessor %d-windows + :initarg :d-windows + :initform nil) + (derived-chords :accessor %d-chords + :initarg :d-chords + :initform nil) + (derived-likelihoods :accessor %d-likelihoods + :initarg :d-likelihoods + :initform nil))) + +(defun reset-harmonisation (harmonisation) + (setf (%d-chords harmonisation) nil + (%d-windows harmonisation) nil + (%d-likelihoods harmonisation) nil)) + +(defun derived-likelihoods (harmonisation &key (models *default-models*) + (chordset *full-set*)) + (if (%d-likelihoods harmonisation) + (%d-likelihoods harmonisation) + (let* ((possible-window-combinations (make-metrical-divisions harmonisation + (%composition harmonisation))) + (possible-windows (remove-duplicates (apply #'nconc possible-window-combinations) + :test #'period=))) + (setf (%d-likelihoods harmonisation) + (loop for window in possible-windows + collect (cons window + (get-chord-likelihoods window + (%composition harmonisation) + models chordset))))))) +(defun ground-truth-window-sizes (harmonisation) + (let* ((chords (ground-truth-chords harmonisation)) + (bar-number (%bar-number harmonisation)) + (beats (nconc (map 'list #'(lambda (x) + (if (= (start-bar x) + bar-number) + (start-beat x) + 1)) + chords) + (list (1+ (duration harmonisation)))))) + (map 'list #'- (cdr beats) beats))) + + + +(defun ground-truth-chords (harmonisation) + (if (%gt-chords harmonisation) + (%gt-chords harmonisation) + (let ((piece-chords (sort (piece-chord-list (%cat-id harmonisation)) + #'chord-time->)) (gt-chords)) + (setf (%gt-chords harmonisation) + (dolist (pc piece-chords gt-chords) + (cond + ((= (start-bar pc) (%bar-number harmonisation)) + (push pc gt-chords) + (when (= (start-beat pc) 1) + (return gt-chords))) + ((< (start-bar pc) (%bar-number harmonisation)) + (return (cons pc gt-chords))))))))) + +(defun derived-window-sizes (harmonisation &key (chordset *full-set*) models) + (declare (ignore models)) + (unless (%d-windows harmonisation) + (let ((level (best-level harmonisation (%composition harmonisation) + :chordset chordset))) + (setf (%d-chords harmonisation) + (loop for likelihoods in (second level) + collect (likelihood-chord + (car (best-n-likelihoods 1 likelihoods)))) + (%d-windows harmonisation) (first level)))) + (map 'list #'duration (%d-windows harmonisation))) + +(defun derived-windows (harmonisation &key (chordset *full-set*) models) + (declare (ignore models)) + (unless (%d-windows harmonisation) + (let ((level (best-level harmonisation (%composition harmonisation) + :chordset chordset))) + (setf (%d-chords harmonisation) + (loop for likelihoods in (second level) + collect (likelihood-chord + (car (best-n-likelihoods 1 likelihoods)))) + (%d-windows harmonisation) (first level)))) + (%d-windows harmonisation)) + +(defun derived-chords (harmonisation &key (chordset *full-set*) models) + (declare (ignore models)) + (cond + ((%d-chords harmonisation) + (%d-chords harmonisation)) + (t (let ((level (best-level harmonisation (%composition harmonisation) + :chordset chordset))) + (setf (%d-windows harmonisation) (first level) + (%d-chords harmonisation) + (loop for likelihoods in (second level) + collect (likelihood-chord (car (best-n-likelihoods 1 likelihoods))))))))) + +(defparameter *harmonic-evaluation-period-cache* nil) +(defun get-harmonic-evaluation-period (bar-number &key cat-id file-id composition) + (cond + (cat-id (get-harmonic-evaluation-period-by-cat-id bar-number cat-id)) + (file-id (get-harmonic-evaluation-period-by-file-id bar-number file-id)) + (composition (get-harmonic-evaluation-period-by-composition bar-number composition)))) + +(defun get-harmonic-evaluation-period-by-cat-id (bar-number cat-id) + (let ((harmonisation (find-if #'(lambda (x) + (and (= (%cat-id x) + cat-id) + (= (%bar-number x) + bar-number))) + *harmonic-evaluation-period-cache*))) + (unless harmonisation + (setf harmonisation + (make-harmonic-evaluation-period bar-number + (get-test-piece cat-id))) + (push harmonisation *harmonic-evaluation-period-cache*)) + harmonisation)) + +(defun get-harmonic-evaluation-period-by-file-id (bar-number file-id) + (let ((harmonisation (find-if #'(lambda (x) + (and (= (%file-id x) + file-id) + (= (%bar-number x) + bar-number))) + *harmonic-evaluation-period-cache*))) + (unless harmonisation + (let* ((composition (get-composition (make-geerdes-identifier file-id)))) + (setf harmonisation (make-harmonic-evaluation-period bar-number + composition)) + (push harmonisation *harmonic-evaluation-period-cache*))) + harmonisation)) + +(defun get-harmonic-evaluation-period-by-composition (bar-number composition) + (let ((harmonisation (find-if #'(lambda (x) + (and (eq (%composition x) + composition) + (= (%bar-number x) + bar-number))) + *harmonic-evaluation-period-cache*))) + (unless harmonisation + (setf harmonisation (make-harmonic-evaluation-period bar-number + composition)) + (push harmonisation *harmonic-evaluation-period-cache*)) + harmonisation)) + +(defun make-harmonic-evaluation-period (bar-number composition) + (with-slots (cat_id id) + (%db-entry composition) + (let ((harmonisation (make-instance 'harmonic-evaluation-period + :cat-id cat_id + :file-id id + :composition composition + :bar-number bar-number + :comp-bar-number (1+ bar-number))) + (period (whole-bar-period (1+ bar-number) composition))) + (setf (timepoint harmonisation) (timepoint period) + (duration harmonisation) (duration period)) + harmonisation))) + +(defun verify-chord (truth-chord derived-chord) + (let ((gt-root (pitch-class-from-gt (slot-value truth-chord 'root))) + (gt-label (chord-from-gt (chord-type truth-chord))) + (d-root (first derived-chord)) + (d-label (chord-label (second derived-chord)))) + (samechordp gt-root gt-label d-root d-label))) + +(defun get-chord (anchored-period harmonisation) + (likelihood-chord (first (best-n-likelihoods 1 + (cdr (assoc anchored-period + (derived-likelihoods harmonisation) + :test #'period=)))))) + +(defun ground-truth-window-beats (harmonisation) + (let ((beat 1) (beat-list '(1))) + (dolist (size (ground-truth-window-sizes harmonisation) (reverse (cdr beat-list))) + (push (incf beat size) beat-list)))) + +(defun find-matching-period (onset duration period-list) + (find-if #'(lambda (x) (and (= onset (timepoint x)) + (= duration (duration x)))) + period-list)) + +(defun position-matching-period (onset duration period-list) + (position-if #'(lambda (x) (and (= onset (timepoint x)) + (= duration (duration x)))) + period-list)) + +(defun compare-paths (bar piece &key (chordset *full-set*) models controlp mergep) + ;; FIXME: Recreate controlp and mergep + (declare (ignore controlp mergep models)) + (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece)) + (gtw-beats (ground-truth-window-beats harmonisation)) + (gtw-sizes (ground-truth-window-sizes harmonisation)) + (score (loop for i from 0 to (1- (length gtw-beats)) + count (find-matching-period (+ (1- (nth i gtw-beats)) + (timepoint harmonisation)) + (nth i gtw-sizes) + (derived-windows harmonisation + :chordset chordset))))) + (values (= score (length gtw-sizes)) score (length gtw-sizes)))) + +(defun compare-paths-and-harmonies (bar piece &key (chordset *full-set*) models controlp mergep) + ;; FIXME: Recreate controlp and mergep + (declare (ignore controlp mergep models)) + (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece)) + (gtw-beats (ground-truth-window-beats harmonisation)) + (gtw-sizes (ground-truth-window-sizes harmonisation)) + (g-chords (ground-truth-chords harmonisation)) + (d-chords (derived-chords harmonisation)) + (d-windows (derived-windows harmonisation :chordset chordset)) + (score (loop for i from 0 to (1- (length gtw-beats)) + count (let ((matchesp (position-matching-period (+ (1- (nth i gtw-beats)) + (timepoint harmonisation)) + (nth i gtw-sizes) + d-windows))) + (and matchesp + (verify-chord (nth i g-chords) + (nth matchesp d-chords))))))) + (values (= score (length gtw-sizes)) score (length gtw-sizes)))) + +(defun compare-harmonies-with-gt-windows (bar piece &key (chordset *full-set*) models) + (declare (ignore chordset models)) + (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece)) + (ground-truth (ground-truth-chords harmonisation)) + (score 0)) + (do ((gt-chords ground-truth (cdr gt-chords))) + ((null gt-chords) (values (= score (length ground-truth)) + score + (length ground-truth))) + (when (verify-chord (first gt-chords) + (get-chord (make-anchored-period (+ (timepoint harmonisation) + (1- (start-beat (first gt-chords)))) + (- (if (second gt-chords) + (start-beat (second gt-chords)) + (duration harmonisation)) + (1- (start-beat (first gt-chords))))) + harmonisation)) + (incf score))))) + +(defun compare-harmonies-by-beat (bar piece &key (chordset *full-set*) models) + (declare (ignore chordset models)) + (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece)) + (score (loop for i from 1 to (duration harmonisation) + count (verify-chord (get-gt-chord-by-beat i harmonisation) + (get-derived-chord-by-beat i harmonisation))))) + (values (= score (duration harmonisation)) score (duration harmonisation)))) + +(defun get-gt-chord-by-beat (beat harmonisation) + (let ((chords (ground-truth-chords harmonisation))) + (do ((gt (reverse chords) (cdr gt))) + ((null gt) (car chords)) + (when (<= (start-beat (car gt)) beat) + (return-from get-gt-chord-by-beat + (car gt)))))) + +(defun get-derived-chord-by-beat (beat harmonisation) + (let ((total-beat (+ (1- beat) + (timepoint harmonisation))) + (chords (derived-chords harmonisation)) + (windows (derived-windows harmonisation))) + (nth (position-if #'(lambda (x) (and (>= total-beat + (timepoint x)) + (< total-beat + (timepoint (cut-off x))))) + windows) + chords))) + +(defparameter *param-estimation-numbers* + (list (cons :major (make-array '(4 21))) + (cons :minor (make-array '(4 21))) + (cons :dim (make-array '(4 21))) + (cons :aug (make-array '(4 21))) + (cons :sus4 (make-array '(4 21))) + (cons :sus9 (make-array '(4 21))))) + +(defun incf-stats (size type offset piece bar distribution) + (let* ((param (cdr (assoc type *param-estimation-numbers*))) + (chord-notes (main-notes (find type (chords *full-set*) :key #'chord-label))) + (full-total (reduce #'+ distribution)) + (chord-sum (loop for scale-deg in chord-notes + sum (aref distribution (mod (+ offset scale-deg) 12))))) + (when (= full-total 0) + (return-from incf-stats)) + (when (> chord-sum full-total) + (format *standard-output* + "~%Piece ~D, Bar ~D, distribution ~D, ~D ~D~%" + piece bar distribution offset type) + (error "BRRRRROKEN!")) + (when (<= chord-sum 1/4) + (format *standard-output* + "~%Piece ~D, Bar ~D, distribution ~D, ~D ~D~%" + piece bar distribution offset type) + (return-from incf-stats)) + #+nil (when (<= (aref distribution (mod (+ offset (nth 1 chord-notes)) 12)) 1/40) + (format *standard-output* "~%******Piece ~D, Bar ~D. distribution ~D, ~D ~D" + piece bar distribution offset type) + (return-from incf-stats)) + (when (<= (aref distribution offset) 1/10) + (format *standard-output* "~%Piece ~D, Bar ~D. distribution ~D, ~D ~D" + piece bar distribution offset type) + (return-from incf-stats)) + (let* ((chord-ratio (/ chord-sum full-total)) + (chord-squared (* chord-ratio chord-ratio)) + (chord-logged (log chord-ratio)) + (non-chord (- 1 chord-ratio)) + (non-chord-squared (* non-chord non-chord)) + (non-chord-logged (log non-chord)) + (d1 (/ (aref distribution (mod (+ offset (nth 0 chord-notes)) 12)) + chord-sum)) + (d1-squared (* d1 d1)) + (d1-logged (log d1)) + (d3 (/ (aref distribution (mod (+ offset (nth 1 chord-notes)) 12)) + chord-sum)) + (d3-squared (* d3 d3)) + (d3-logged (log d3)) + (d5 (/ (aref distribution (mod (+ offset (nth 2 chord-notes)) 12)) + chord-sum)) + (d5-squared (* d5 d5)) + (d5-logged (log d5))) + ;; n + (incf (aref param size 0)) + (incf (aref param size 1) chord-ratio) + (incf (aref param size 2) chord-squared) + (if (= chord-ratio 0) + (incf (aref param size 4)) + (incf (aref param size 3) chord-logged)) + (incf (aref param size 5) non-chord) + (incf (aref param size 6) non-chord-squared) + (if (= non-chord 0) + (incf (aref param size 8)) + (incf (aref param size 7) non-chord-logged)) + (incf (aref param size 9) d1) + (incf (aref param size 10) d1-squared) + (if (= d1 0) + (incf (aref param size 12)) + (incf (aref param size 11) d1-logged)) + (incf (aref param size 13) d3) + (incf (aref param size 14) d3-squared) + (if (= d3 0) + (incf (aref param size 16)) + (incf (aref param size 15) d3-logged)) + (incf (aref param size 17) d5) + (incf (aref param size 18) d5-squared) + (if (= d5 0) + (incf (aref param size 20)) + (incf (aref param size 19) d5-logged))))) + +(defun parameter-estimation-figures (&key (test-set *test-set*)) + (let ((size 0) (beat 0) + (c-type) (offset 0) + (harmonisation) (bar 0) (piece 0)) + (dolist (test test-set) + (setf piece (car test) + bar (cdr test) + harmonisation (get-harmonic-evaluation-period bar :cat-id piece)) + (do ((windows (ground-truth-chords harmonisation) (cdr windows)) + (window-sizes (ground-truth-window-sizes harmonisation) (cdr window-sizes)) + (window-beats (ground-truth-window-beats harmonisation) (cdr window-beats))) + ((not windows)) + (setf size (1- (first window-sizes)) + c-type (chord-from-gt (chord-type (first windows))) + offset (pitch-class-from-gt (slot-value (first windows) 'root)) + beat (+ (1- (first window-beats)) (timepoint harmonisation))) + (incf-stats size c-type offset piece bar + (pitch-class-distribution (make-anchored-period beat (1+ size)) + (%composition harmonisation))))))) + + +(defun write-numbers-to-file (pathname) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (dolist (acns *param-estimation-numbers*) + (let ((c-type (car acns)) (data (cdr acns))) + (dotimes (i 4) + (format s "~D chords, ~D beats: ~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~C~D~%" + c-type (1+ i) + (aref data i 0) #\Tab + (float (aref data i 1)) #\Tab (float (aref data i 2)) #\Tab + (float (aref data i 3)) #\Tab (aref data i 4) #\Tab + (float (aref data i 5)) #\Tab (float (aref data i 6)) #\Tab + (float (aref data i 7)) #\Tab (aref data i 8) #\Tab + (float (aref data i 9)) #\Tab (float (aref data i 10)) #\Tab + (float (aref data i 11)) #\Tab (aref data i 12) #\Tab + (float (aref data i 13)) #\Tab (float (aref data i 14)) #\Tab + (float (aref data i 15)) #\Tab (aref data i 16) #\Tab + (float (aref data i 17)) #\Tab (float (aref data i 18)) #\Tab + (float (aref data i 19)) #\Tab (aref data i 20))))))) + +(defun write-numbers-to-file-2 (pathname) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (dolist (acns *param-estimation-numbers*) + (let ((c-type (car acns)) (data (cdr acns))) + (dotimes (i 4) + (format s ";; ~D chords - ~D beats ~%((~D ~D) (~D ~D) (~D ~D) (~D ~D) ~D)~%((~D ~D ~D) (~D ~D ~D) (~D ~D ~D) (~D ~D ~D) ~D)~%" + c-type (1+ i) + ;; chord / non-chord (x, x^2, log(x), left out, n) + (float (aref data i 1)) (float (aref data i 5)) + (float (aref data i 2)) (float (aref data i 6)) + (float (aref data i 3)) (float (aref data i 7)) + (aref data i 4) (aref data i 8) + (aref data i 0) + ;; 1 / 3 / 5 (x, x^2, log(x), left out, n) + (float (aref data i 9)) (float (aref data i 13)) (float (aref data i 17)) + (float (aref data i 10)) (float (aref data i 14)) (float (aref data i 18)) + (float (aref data i 11)) (float (aref data i 15)) (float (aref data i 19)) + (aref data i 12) (aref data i 16) (aref data i 20) + (aref data i 0))))))) + +(defun test-paths (&key (test-set *test-set*)) + (let ((bars 0) (grand-score 0) (grand-total 0)) + (loop for test in test-set + do (when (goodness-test (cdr test) (car test)) + (multiple-value-bind (match score total) + (compare-paths (cdr test) (car test)) + (when match (incf bars)) + (incf grand-score score) + (incf grand-total total)))) + (values bars grand-score grand-total))) + +(defparameter *ignored* nil) +(defun goodness-test (bar piece) + ;; exclusions bin + (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece)) + (sounding-sum (reduce #'+ (pitch-class-distribution harmonisation (%composition harmonisation)))) + (pcd)) + ;; Too little sounding + (unless (> sounding-sum 1/4) + (push (list bar piece) *ignored*) + (return-from goodness-test nil)) + ;; per gt window tests + (do ((window-beats (ground-truth-window-beats harmonisation) (cdr window-beats)) + (window-sizes (ground-truth-window-sizes harmonisation) (cdr window-sizes)) + (gt-chords (ground-truth-chords harmonisation) (cdr gt-chords))) + ((null window-beats) t) + (setf pcd (pitch-class-distribution (make-anchored-period (+ (timepoint harmonisation) + (1- (first window-beats))) + (first window-sizes)) + (%composition harmonisation))) + (unless (and (> (reduce #'+ pcd) 1) + (> (aref pcd (pitch-class-from-gt (slot-value (first gt-chords) 'root))) + 1/16)) + (push (list bar piece) *ignored*) + (return-from goodness-test nil))))) + +(defun test-harmonies (&key (test-set *test-set*)) + ;; FIXME: whole bars only at the mo! + (loop for test in test-set + count (when (goodness-test (cdr test) (car test)) + (compare-harmonies-with-gt-windows (cdr test) (car test))))) + +(defun test-paths-and-chords (&key (test-set *test-set*)) + (let ((bars 0) (grand-score 0) (grand-total 0)) + (loop for test in test-set + do (when (goodness-test (cdr test) (car test)) + (multiple-value-bind (match score total) + (compare-paths-and-harmonies (cdr test) (car test)) + (when match (incf bars)) + (incf grand-score score) + (incf grand-total total)))) + (values bars grand-score grand-total))) + +(defun test-harmonies-by-window (&key (test-set *test-set*)) + (let ((bars 0) (grand-score 0) (grand-total 0)) + (loop for test in test-set + do (when (goodness-test (cdr test) (car test)) + (multiple-value-bind (match score total) + (compare-harmonies-with-gt-windows (cdr test) (car test)) + (when match (incf bars)) + (incf grand-score score) + (incf grand-total total)))) + (values bars grand-score grand-total))) + +(defun test-harmonies-by-beat (&key (test-set *test-set*)) + (let ((bars 0) (grand-score 0) (grand-total 0)) + (loop for test in test-set + do (when (goodness-test (cdr test) (car test)) + (multiple-value-bind (match score total) + (compare-harmonies-by-beat (cdr test) (car test)) + (when match (incf bars)) + (incf grand-score score) + (incf grand-total total)))) + (values bars grand-score grand-total))) + +(defgeneric whole-bar-period (bar-number composition)) +(defmethod whole-bar-period (bar-number (composition geerdes-midi-composition)) + (multiple-value-bind (beat-no timesig) + (bar-number-to-beats bar-number composition) + (make-anchored-period (timepoint beat-no) (crotchets-in-a-bar timesig)))) + +(defgeneric bar-number-to-beats (bar-number composition)) +(defmethod bar-number-to-beats (bar-number (composition geerdes-midi-composition)) + (do* ((time-sig-list (time-signatures composition) (cdr time-sig-list)) + (current-sig (car time-sig-list) (car time-sig-list)) + (beats-per-bar (make-floating-period (crotchets-in-a-bar current-sig)) + (make-floating-period (crotchets-in-a-bar current-sig))) + (bars-left bar-number)) + ((time>= (cut-off current-sig) + (time+ (onset current-sig) + (duration* beats-per-bar bars-left))) + (values (time+ (onset current-sig) + (duration* beats-per-bar bars-left)) + current-sig)) + (decf bars-left (duration/ current-sig beats-per-bar)))) + +(defun samechordp (root1 label1 root2 label2) + (or (and (= root1 root2) + (eq label1 label2)) + (and (eq label1 :sus4) + (eq label2 :sus9) + (= root2 (mod (+ root1 5) 12))) + (and (eq label2 :sus4) + (eq label1 :sus9) + (= root1 (mod (+ root2 5) 12))))) + +(defun chord-from-gt (string) + (cdr (assoc string '(("maj" . :major) ("min" . :minor) + ("dim" . :dim) ("aug" . :aug) + ("sus4" . :sus4) ("sus9" . :sus9)) + :test #'equal))) + +(defun pitch-class-from-gt (string) + (position-if #'(lambda (x) (string-equal x string)) + *dm-note-names*)) + +(defun piece-chord-list (id) + (remove-if #'(lambda (x) + (not (= (cat_id x) id))) + (all-chords))) + +(defun get-gt-bar-chords (piece bar) + (let ((bar-beats (* 4 bar)) + (chord-list (sort (piece-chord-list piece) + #'chord-time->))) + (loop for i from bar-beats to (+ 3 bar-beats) + collect (gt-chord-to-list (get-applicable-chord i chord-list))))) + +(defun gt-chord-to-list (chord) + (list (pitch-class-from-gt (slot-value chord 'root)) + (chord-from-gt (chord-type chord)))) + +(defun explore-parameters (&key (alpha-scale '(0.4 3)) (beta '(4 14))) + (let* ((original-alpha *alpha*) + (original-betas *betas*) + (results (loop for i from (first alpha-scale) to (second alpha-scale) by 0.3 + collect (progn + (setf *alpha* (map 'vector + #'(lambda (x) + (* x i)) + original-alpha)) + (print *alpha*) + (list i (explore-betas beta)))))) + (setf *alpha* original-alpha + *betas* original-betas) + results)) + +(defun explore-betas (beta) + (let* ((b1 (first beta)) + (bn (second beta)) + (n (- bn b1))) + (assert (equal (array-dimensions *results*) + (list n n n n 4))) + (loop for semi from 0 to (1- n) by 2 + do (progn + (format t "|~D |" (+ semi b1)) + (loop for dotted-minim from 0 to (1- n) by 2 + do (loop for minim from 0 to (1- n) by 2 + do (loop for crotchet from 0 to (1- n) by 2 + do (progn + (setf *harmonic-evaluation-period-cache* nil + *betas* (list (cons 1 (+ b1 semi)) + (cons 3/4 (+ b1 dotted-minim)) + (cons 1/2 (+ b1 minim)) + (cons 1/4 (+ b1 crotchet)))) + (unless (> (aref *results* semi dotted-minim minim crotchet 0) + 0) + (multiple-value-bind (dull score total) + (test-paths) + (declare (ignore dull)) + (setf (aref *results* semi dotted-minim minim crotchet 0) + (/ score total)))) + (unless (> (aref *results* semi dotted-minim minim crotchet 1) + 0) + (multiple-value-bind (dull score total) + (test-paths-and-chords) + (declare (ignore dull)) + (setf (aref *results* semi dotted-minim minim crotchet 1) + (/ score total)))) + (unless (> (aref *results* semi dotted-minim minim crotchet 2) + 0) + (multiple-value-bind (dull score total) + (test-harmonies-by-window) + (declare (ignore dull)) + (setf (aref *results* semi dotted-minim minim crotchet 2) + (/ score total)))) + (unless (> (aref *results* semi dotted-minim minim crotchet 3) + 0) + (multiple-value-bind (dull score total) + (test-harmonies-by-beat) + (declare (ignore dull)) + (setf (aref *results* semi dotted-minim minim crotchet 3) + (/ score total)))))))))) + *results*)) + +(defparameter *results* (make-array '(10 10 10 10 4) :element-type 'ratio)) + +(defun explore-parameters-to-file (pathname &key (alpha-scale '(0.4 3)) (beta '(4 14))) + (with-open-file (stream pathname :direction :output :if-exists :supersede) + (let* ((original-alpha *alpha*) + (original-betas *betas*)) + (loop for i from (first alpha-scale) to (second alpha-scale) by 0.3 + do (progn + (setf *alpha* (map 'vector + #'(lambda (x) + (* x i)) + original-alpha)) + (print *alpha*) + (explore-betas-to-stream beta stream))) + (setf *alpha* original-alpha + *betas* original-betas)))) + +(defun explore-betas-to-stream (beta stream) + (let* ((b1 (first beta)) + (bn (second beta)) + (n (- bn b1)) (tb #\tab)) + (loop for semi from 0 to (1- n) by 2 + do (progn + (format *standard-output* "|~D |" (+ semi b1)) + (finish-output) + (loop for dotted-minim from 0 to (1- n) by 2 + do (loop for minim from 0 to (1- n) by 2 + do (loop for crotchet from 0 to (1- n) by 2 + do (progn + (format stream "~D~C~D~C~D~C~D~C~D~C" + (aref *alpha* 0) tb + (+ b1 semi) tb + (+ b1 dotted-minim) tb + (+ b1 minim) tb + (+ b1 crotchet) tb) + (setf *harmonic-evaluation-period-cache* nil + *betas* (list (cons 1 (+ b1 semi)) + (cons 3/4 (+ b1 dotted-minim)) + (cons 1/2 (+ b1 minim)) + (cons 1/4 (+ b1 crotchet)))) + (multiple-value-bind (dull score total) + (test-paths) + (declare (ignore dull)) + (format stream "~D~C" (/ score total) tb)) + (multiple-value-bind (dull score total) + (test-paths-and-chords) + (declare (ignore dull)) + (format stream "~D~C" (/ score total) tb)) + (multiple-value-bind (dull score total) + (test-harmonies-by-window) + (declare (ignore dull)) + (format stream "~D~C" (/ score total) tb)) + (multiple-value-bind (dull score total) + (test-harmonies-by-beat) + (declare (ignore dull)) + (format stream "~D~C~%" (/ score total) tb)) + (finish-output stream))))))))) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/harmony/gamma.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,233 @@ +;; CSR's gamma functions. I don't really know what's happening here, +;; but it seems to work... Called from within harmonic_analysis.lisp + +(in-package #:amuse-harmony) + +(let ((p (make-array + 9 :element-type 'double-float + :initial-contents ; cf. Lanczos' Approximation on Wikipedia. + '(0.99999999999980993d0 676.5203681218851d0 -1259.1392167224028d0 + 771.32342877765313d0 -176.61502916214059d0 12.507343278686905d0 + -0.13857109526572012d0 9.9843695780195716d-6 + 1.5056327351493116d-7))) + (c (make-array 8 :element-type 'double-float + :initial-contents + (mapcar (lambda (x) (float x 1d0)) + '(1/12 -1/360 1/1260 -1/1680 1/1188 -691/360360 + 1/156 -3617/122400))))) + (defun gamma/posreal (x) + (declare (type (double-float (0d0)) x)) + (locally + (declare (optimize speed)) + (labels ((corr (x) + (declare (type double-float x)) + (let ((y (/ 1.0 (* x x)))) + (do* ((i 7 (1- i)) + (r (aref c i) (+ (* r y) (aref c i)))) + ((<= i 0) (the (double-float (0d0)) (exp (/ r x)))) + (declare (type double-float r))))) + (lngamma/lanczos (x) + (declare (type (double-float 0.5d0) x)) + (let ((x (1- x))) + (do* ((i 0 (1+ i)) + (ag (aref p 0) (+ ag (/ (aref p i) (+ x i))))) + ((>= i 8) + (let ((term1 (* (+ x 0.5d0) (log (/ (+ x 7.5d0) #.(exp 1d0))))) + (term2 (+ #.(log (sqrt (* 2 pi))) (log ag)))) + (+ term1 (- term2 7.0d0)))) + (declare (type (double-float (0d0)) ag))))) + (gamma/xgthalf (x) + (declare (type (double-float 0.5d0) x)) + (cond + ((= x 0.5d0) 1.77245385090551602729817d0) + ((< x 5d0) (exp (lngamma/lanczos x))) + ;; the GNU scientific library suggests a third branch + ;; for x < 10, but in fact for our purposes the + ;; errors are under control. + (t + (let* ((p (expt x (* x 0.5))) + (e (exp (- x))) + (q (* (* p e) p)) + (pre (* #.(sqrt 2) #.(sqrt pi) q (/ (sqrt x))))) + (* pre (corr x))))))) + (if (> x 0.5d0) + (gamma/xgthalf x) + (let ((g (gamma/xgthalf (- 1d0 x)))) + (declare (type double-float g)) + (/ pi g (sin (* pi x))))))))) + +(defun beta (alpha) + (let ((sum 0) + (product 1)) + (dotimes (i (length alpha) (/ product (gamma/posreal (float sum 1d0)))) + (let ((alpha_i (aref alpha i))) + (setq product (* product (gamma/posreal (float alpha_i 1d0)))) + (incf sum alpha_i))))) + +;; this is p(d|c_i), where the chord model is represented as a +;; Dirichlet distribution with parameters alpha_i +#+nil +(defun likelihood (observations alpha) + ;; observations is a 12d vector summing to 1, alpha summing to 3 + (assert (< (abs (1- (loop for d across observations sum d))) + (* single-float-epsilon 12))) + (let ((pairs (loop for alpha_i across alpha + for d_i across observations + if (zerop alpha_i) + do (unless (zerop d_i) + (return-from likelihood 0.0d0)) + else + collect (cons alpha_i d_i)))) + ;; now all the CARs of pairs have strictly positive alpha_i + ;; values, and the d_i are the corresponding observations. + (let ((alpha_prime (map 'simple-vector #'car pairs))) + (* (/ (beta alpha_prime)) + (reduce #'* pairs :key (lambda (pair) + (expt (cdr pair) (1- (car pair))))))))) + + +(defun likelihood (observations alpha &optional (power 1)) + (assert (< (abs (1- (loop for d across observations sum d))) + (* single-float-epsilon 12))) + (let* ((alpha_0 (loop for a across alpha sum a)) + (alpha_0+1 (1+ alpha_0)) + (alpha_00+1 (* alpha_0+1 power)) + (alpha_00 (- alpha_00+1 1)) + (alpha (map 'simple-vector + (lambda (x) (* x (/ alpha_00 alpha_0))) + alpha)) + (quantum (expt 0.0005 power))) ; sake of argument + (let ((pairs + (loop for d_i across observations + for alpha_i across alpha + if (zerop alpha_i) + do (unless (zerop d_i) + (return-from likelihood 0.0d0)) + else collect (cons d_i alpha_i)))) + (assert (= (length pairs) 12)) + (let ((alpha_prime (map 'simple-vector #'cdr pairs))) + (* (/ (beta alpha_prime)) (/ quantum) + (reduce #'* pairs :key + (lambda (pair) + (if (zerop (car pair)) + (* (/ (cdr pair)) (expt quantum (cdr pair))) + (* quantum (expt (car pair) (1- (cdr + pair)))))))))))) + +(defun 4ple-likelihood (pitch-classes chord-probabilities intervals level sum) + (let ((observations)) + (dolist (interval intervals) + (push (aref pitch-classes interval) observations) + (decf sum (aref pitch-classes interval))) + (push sum observations) + (likelihood/fourwise (make-array (length observations) :initial-contents (reverse observations)) + chord-probabilities level))) + +(let ((alpha_0s '((1 . 12) (1/2 . 9) (1/4 . 30)))) + (defun likelihood/fourwise (observations alpha &optional (power 1)) + (assert (< (abs (1- (loop for d across observations sum d))) + (* single-float-epsilon 4))) + (let* ((alpha_0 (loop for a across alpha sum a)) + (alpha (map 'simple-vector + (lambda (x) (* x (/ (cdr (assoc power alpha_0s)) + alpha_0))) + alpha)) + (quantum (expt 0.0005 power))) ; sake of argument + (let ((pairs + (loop for d_i across observations + for alpha_i across alpha + if (zerop alpha_i) + do (unless (zerop d_i) + (return-from likelihood/fourwise 0.0d0)) + else collect (cons d_i alpha_i)))) + (assert (= (length pairs) 4)) + (let ((alpha_prime (map 'simple-vector #'cdr pairs))) + (* (/ (beta alpha_prime)) (/ quantum) + (reduce #'* pairs :key + (lambda (pair) + (if (zerop (car pair)) + (* (/ (cdr pair)) (expt quantum (cdr pair))) + (* quantum (expt (car pair) (1- (cdr pair))))))))))))) + +(defparameter *alpha-scale* 1) +(defparameter *beta-scale* 1) +(defparameter *alpha* #(2.925 1.95 1.625)) +(defparameter *beta* #(0.87 4.46)) +(defparameter *minimal-betas* '((1 . 8.75) (1/2 . 3) (1/4 . 2.5))) +(defparameter *full-betas-1* '((1 . 14) (1/2 . 6) (1/4 . 8))) ;; gets 144|51 +(defparameter *full-betas* '((1 . 14) (3/4 . 6) (1/2 . 6) (1/4 . 8))) ;; guess... +(defparameter *betas* *full-betas*) + +(defun 3ple-likelihood (pitch-classes chord-probabilities non-chord intervals level sum + &optional (alpha *alpha*) (beta *beta*)) + (declare (ignore chord-probabilities non-chord)) + (let ((observations)) + (dolist (interval intervals) + (push (aref pitch-classes interval) observations) + (decf sum (aref pitch-classes interval))) + (push sum observations) + (when (= sum 1) ;; So there are no chord notes at all... ?? move to likelihood function + (return-from 3ple-likelihood 0)) + (likelihood/threeplusonewise (make-array (length observations) :initial-contents (reverse observations)) + alpha beta + level) + #+nil (likelihood/threeplusonewise (make-array (length observations) :initial-contents (reverse observations)) + (map 'vector #'(lambda (x) (* x *alpha-scale*)) + #(2.925 1.95 1.625)) + #+nil (map 'vector #'(lambda (x) (* x *beta-scale*)) + #(0.87 4.46)) + (make-array 2 :initial-contents (list 0.87 *beta-scale*)) + level))) + +;; #(0.87 4.46) worked + +;;; observations is a non-relativistic four-vector of proportions: +;;; #(tonic mediant dominant other). +;;; +;;; alpha is a three-vector of Dirichlet parameters for proportions of +;;; tonic, mediant, dominant of the total chord notes. +;;; +;;; beta is a two-vector of Dirichlet parameters for proportions of +;;; non-chord vs chord notes. +;;; +;;; suggested values: +;;; alpha: #(2.925 1.95 1.625) ; (tonic, mediant, dominant) +;;; beta: #(0.44 1.76) ; (non-chord, chord) +;;; +;;; model: +;;; p(tmdo|c) = p(o|c)p(tmd|oc) +;;; where +;;; p(o|c) ~ Beta(0.44,1.76) (i.e. p({o,o'}|c) ~ Dir({0.44,1.76}) +;;; and +;;; p(tmd|oc) ~ (1-o) Dir({2.925,1.95,1.625}) +(defun likelihood/threeplusonewise + (observations alpha beta &optional (power 1)) + (assert (< (abs (1- (loop for d across observations sum d))) + (* single-float-epsilon 4))) + (let* ((quantum (expt 0.00000005 power))) ; sake of argument + (let* ((o (aref observations 3)) + (pairs + (loop repeat 3 + for d_i across observations + for alpha_i across alpha + if (zerop alpha_i) + do (unless (zerop d_i) + (return-from likelihood/threeplusonewise 0.0d0)) + else collect (cons (/ d_i (- 1 o)) alpha_i)))) + (assert (= (length pairs) 3)) + (assert (< (abs (1- (loop for (d) in pairs sum d))) (* + single-float-epsilon 3))) + (flet ((key (pair) + (if (zerop (car pair)) + (* (/ (cdr pair)) (expt quantum (cdr pair))) + (* quantum (expt (car pair) (1- (cdr pair))))))) + (let ((alpha_prime (map 'simple-vector #'cdr pairs))) + (* + ;; p(o|c) + (/ (beta beta)) (/ quantum) + (reduce #'* (list (cons o (aref beta 0)) + (cons (- 1 o) (aref beta 1))) + :key #'key) + ;; p(tmd|oc) + (/ (beta alpha_prime)) (/ quantum) + (reduce #'* pairs :key #'key)))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/harmony/methods.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,8 @@ +(in-package #:amuse-harmony) + +(defgeneric get-ground-truth-periods (anchored-period composition) + (:method (ap c) (declare (ignore ap c)) nil)) + +(defgeneric get-ground-truth-chord (ground-truth-period composition) + (:method (gtp c) (declare (ignore gtp c)) nil)) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/harmony/package.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,10 @@ +(cl:defpackage #:amuse-harmony + (:use #:common-lisp #:amuse #:amuse-utils) + (:export #:chord + #:chordset + #:likelihood + #:get-chord-likelihoods-for-model + #:chromatic-rotate + #:chord-labels + #:best-level + ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/utils/midi-output.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -0,0 +1,155 @@ +;; Make midifiles from basic amuse objects methods here can be +;; overridden for more specific types +;; + +;; FIXME: Need to push some structures from geerdes to make this work. + +(in-package #:amuse-utils) + +(defgeneric play (music) + (:method (m) (play-midifile (make-midi m)))) +(defmethod play ((music composition)) + (play-midifile (make-midi music))) + +(defun play-midifile (midifile) + ;; coremidi is easy as an alternative, but we'll probably want midi + ;; file export anyway, so it makes some sense to focus our efforts + ;; on this first. That said, is there a CoreAudio midi file player + ;; routine? + (midi:write-midi-file midifile "tmp.mid") + #+darwin + (when (sb-impl::find-executable-in-search-path "open") + (asdf:run-shell-command "open tmp.mid") + (return-from play-midifile T)) + (when (sb-impl::find-executable-in-search-path "timidity") + (asdf:run-shell-command "timidity tmp.mid") + (return-from play-midifile T))) + +(defgeneric make-midi (sequence)) +(defmethod make-midi ((sequence sequence)) + ;; Make a midifile object. Collects global midi messages (that + ;; require a sequence) and event-based messages (that don't). + ;; FIXME: Something about this strikes me as very stupid. Must + ;; revisit + ;; FIXME: Only making type 0. Is this a problem? + (let* ((events (event-sequence-messages sequence)) + (globals (global-messages sequence)) + (patches (patch-messages sequence))) + (make-midifile-from-messages (nconc events globals patches) + :type 0))) + +(defun make-midifile-from-messages (events &key (type 0)) + ;; FIXME: clearly broken if type 1 + ;; First have to get rid of all fractional times and choose a + ;; timebase + (let* ((timebase (apply #'lcm (mapcar #'(lambda (x) + (denominator + (midi:message-time x))) + events)))) + (when (< timebase 4) + (setf timebase (* 4 timebase))) + (loop for e in events + do (setf (midi:message-time e) (* timebase + (midi:message-time e)))) + (make-instance 'midi:midifile + :format type + :division timebase + :tracks (list (sort-midi-messages-for-output events))))) + +(defun sort-midi-messages-for-output (messages) + (sort messages #'(lambda (x y) (or (< (midi:message-time x) + (midi:message-time y)) + (and (= (midi:message-time x) + (midi:message-time y)) + (> (midi::message-status x) + (midi::message-status y))))))) + +(defun event-sequence-messages (sequence) + (let ((midinotes)) + (sequence:dosequence (event sequence midinotes) + (let ((messages (event-messages event))) + (dolist (message messages) + (push message midinotes)))))) + +(defun patch-messages (sequence) + (let ((patches (make-array 16 :initial-element nil)) + (patch-list) + (channel 0) + (patch 0)) + (sequence:dosequence (event sequence patch-list) + (setf channel (get-channel-for-midi event) + patch (get-patch-for-midi event)) + (when (or (not (aref patches channel)) + (not (= (aref patches channel) + patch))) + (push (make-instance 'midi:program-change-message + :program patch + :time (timepoint event) + :status (+ channel 192)) + patch-list) + (setf (aref patches channel) patch))))) + + +(defgeneric global-messages (sequence) + (:method (s) (declare (ignore s)) nil)) +(defmethod global-messages ((sequence composition)) + ;; FIXME: missing plenty of other messages + ;; FIXME: messy + (let ((tempi (tempi sequence)) + (temp) + (time-sigs (time-signatures sequence)) + (events)) + (dolist (tempo tempi) + (setf temp (tempo-message tempo)) + (when temp + (push temp events))) + (dolist (time-sig time-sigs events) + (setf temp (time-sig-message time-sig)) + (when temp + (push temp events))))) + +(defgeneric tempo-message (tempo) + (:method (tp) + (progn + (let ((speed (make-instance 'midi:tempo-message + :time (timepoint tp) + :status 255))) + (setf (slot-value speed 'midi::tempo) (microseconds-per-crotchet tp)) + speed)))) + +(defgeneric time-sig-message (time-sig) + (:method (ts) (declare (ignore ts)) nil)) + +(defgeneric event-messages (event) + (:method (e) (declare (ignore e)) nil)) +(defmethod event-messages ((event pitched-event)) + (list (make-instance 'midi:note-on-message + :status (+ (get-channel-for-midi event) 144) + :key (midi-pitch-number event) + :velocity (get-velocity-for-midi event) + :time (timepoint event)) + (make-instance 'midi:note-off-message + :status (+ (get-channel-for-midi event) 128) + :key (midi-pitch-number event) + :velocity (get-velocity-for-midi event) + :time (timepoint (cut-off event))))) + +(defmethod event-messages ((event percussive-event)) + (list (make-instance 'midi:note-on-message + :status 153 + :key (get-pitch-for-midi event) + :velocity (get-velocity-for-midi event) + :time (timepoint event)) + (make-instance 'midi:note-off-message + :status 137 + :key (get-pitch-for-midi event) + :velocity (get-velocity-for-midi event) + :time (timepoint (cut-off event))))) + +(defgeneric get-pitch-for-midi (event)) +(defgeneric get-velocity-for-midi (event) + (:method (e) (declare (ignore e)) 100)) +(defgeneric get-patch-for-midi (event) + (:method (e) (declare (ignore e)) 0)) +(defgeneric get-channel-for-midi (event) + (:method (e) (declare (ignore e)) 0))
--- a/utils/package.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/utils/package.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -1,3 +1,23 @@ (cl:defpackage #:amuse-utils - (:use #:common-lisp) - (:export)) + (:use #:common-lisp #:amuse #:midi) + (:export #:pitchedp + #:unpitchedp + #:midi-pitch-distribution + #:pitch-class-distribution + #:normalised-midi-pitch-distribution + #:normalised-pitch-class-distribution + #:normalise-vector + #:bar-number + #:bass-note + #:crotchets-in-a-bar + #:sounding-events + #:play + #:make-midi + #:global-messages + #:tempo-message + #:event-messages + #:get-patch-for-midi + #:get-channel-for-midi + #:get-pitch-for-midi + #:get-velocity-for-midi + ))
--- a/utils/utils.lisp Mon Dec 18 13:23:31 2006 +0000 +++ b/utils/utils.lisp Fri Apr 13 11:09:09 2007 +0100 @@ -2,3 +2,79 @@ (cl:in-package #:amuse-utils) +;; Booleans (for filters) +(defgeneric pitchedp (event) + (:method (e) (declare (ignore e)) nil)) +(defmethod pitchedp ((event amuse:pitched-event)) + T) +(defgeneric unpitchedp (event) + (:method (e) (not (pitchedp e)))) + +;; Rhythm methods +(defgeneric crotchets-in-a-bar (time-signature)) +(defmethod crotchets-in-a-bar ((time-signature basic-time-signature)) + (let ((num (time-signature-numerator time-signature)) + (den (time-signature-denominator time-signature))) + (* num (/ 4 den)))) + +;; Pitch methods + +(defgeneric sounding-events (anchored-period sequence)) +(defmethod sounding-events ((anchored-period anchored-period) + (sequence composition)) + (let ((sounding)) + (sequence:dosequence (event sequence (reverse sounding)) + (cond + ((time>= event (cut-off anchored-period)) + (return-from sounding-events (reverse sounding))) + ((period-intersection anchored-period event) + (push event sounding)))))) + +(defgeneric midi-pitch-distribution (anchored-period composition)) +(defmethod midi-pitch-distribution ((anchored-period anchored-period) + composition) + (let ((pitches (make-array 128 :initial-element 0))) + (dolist (event (remove-if #'unpitchedp (sounding-events anchored-period composition)) pitches) + (let ((overlap (period-intersection anchored-period event))) + (if overlap + (incf (aref pitches (midi-pitch-number event)) + (duration overlap)) + (if (= (duration event) 0) + (format t "~%Note ~D beats in has no duration" (timepoint event)) + (error "This function has gone wrong - looking for overlaps that don't exist"))))))) + +(defgeneric pitch-class-distribution (anchored-period composition)) +(defmethod pitch-class-distribution ((anchored-period anchored-period) + composition) + (let ((pitches (make-array 12 :initial-element 0))) + (dolist (event (remove-if #'unpitchedp (sounding-events anchored-period composition)) pitches) + (let ((overlap (period-intersection anchored-period event))) + (if overlap + (incf (aref pitches (pitch-class event)) + (duration overlap)) + (if (= (duration event) 0) + (format t "~%Note ~D beats in has no duration" (timepoint event)) + (error "This function has gone wrong - looking for overlaps that don't exist"))))))) + +(defun normalised-midi-pitch-distribution (object1 object2) + (normalise-vector (midi-pitch-distribution object1 object2))) +(defun normalised-pitch-class-distribution (object1 object2) + (normalise-vector (pitch-class-distribution object1 object2))) +(defun normalise-vector (vector &optional (target-sum 1)) + (let ((total (loop for i from 0 to (1- (length vector)) + sum (aref vector i)))) + (cond + ((= total target-sum) + vector) + ((= total 0) + (make-array (length vector) + :initial-element (/ target-sum (length vector)))) + (t + (map 'vector #'(lambda (x) (* x (/ target-sum total))) vector))))) + +;; Not as simple as it seems - have to take into account numbering +;; practices and leading silences in representations where bar number +;; isn't part of the explicit structure. +(defgeneric bar-number (moment composition)) + +(defgeneric bass-note (anchored-period composition)) \ No newline at end of file