Mercurial > hg > amuse
changeset 63:32314fefc706
Moved amuse-harmony to new package
darcs-hash:20070628135353-f76cc-be6cba65bf7ba97bae481ab6630880d5707e8c7a.gz
| author | David Lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Thu, 28 Jun 2007 14:53:53 +0100 |
| parents | 9cdd79c34442 |
| children | c8f1b0ab0007 |
| files | amuse.asd 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/package.lisp utils/utils.lisp |
| diffstat | 9 files changed, 1 insertions(+), 2013 deletions(-) [+] |
line wrap: on
line diff
--- a/amuse.asd Thu Jun 28 08:04:20 2007 +0100 +++ b/amuse.asd Thu Jun 28 14:53:53 2007 +0100 @@ -18,15 +18,7 @@ ((:file "package") (:file "utils" :depends-on ("package")) (:file "n-grams" :depends-on ("package")) - (:file "midi-output" :depends-on ("package" "utils")) - (:module harmony - :depends-on ("utils") - :components - ((:file "package") - (:file "classes" :depends-on ("package")) - (:file "gamma" :depends-on ("package")) - (:file "chord-labelling" - :depends-on ("gamma" "package" "classes")))))) + (:file "midi-output" :depends-on ("package" "utils")))) (:module implementations :components ((:module midi
--- a/utils/harmony/chord-labelling.lisp Thu Jun 28 08:04:20 2007 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,684 +0,0 @@ -(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 :ab :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 -;; -;; FIXME: Explain this?? Is it ((pc :type) . p(chord))? - -(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
--- a/utils/harmony/classes.lisp Thu Jun 28 08:04:20 2007 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -(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))) -
--- a/utils/harmony/evaluation.lisp Thu Jun 28 08:04:20 2007 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,882 +0,0 @@ -;; 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))))))))) -
--- a/utils/harmony/gamma.lisp Thu Jun 28 08:04:20 2007 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,233 +0,0 @@ -;; 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)))))))
--- a/utils/harmony/methods.lisp Thu Jun 28 08:04:20 2007 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -(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)) -
--- a/utils/harmony/package.lisp Thu Jun 28 08:04:20 2007 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -(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 - ))
--- a/utils/package.lisp Thu Jun 28 08:04:20 2007 +0100 +++ b/utils/package.lisp Thu Jun 28 14:53:53 2007 +0100 @@ -2,11 +2,6 @@ (: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 #:bar-onset #:bass-note @@ -21,8 +16,6 @@ #:get-channel-for-midi #:get-pitch-for-midi #:get-velocity-for-midi - #:vector-correlation - #:krumhansl-key-finder #:levenshtein-distance #:beats-to-seconds #:get-n-grams
--- a/utils/utils.lisp Thu Jun 28 08:04:20 2007 +0100 +++ b/utils/utils.lisp Thu Jun 28 14:53:53 2007 +0100 @@ -31,62 +31,6 @@ (timepoint object1)) object2)) - -;; 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. @@ -95,73 +39,6 @@ (defgeneric bass-note (anchored-period composition)) -(defun vector-correlation (vector1 vector2) - ;; useful for Krumhansl-Schmukler-like calculations - (assert (= (length vector1) (length vector2))) - (let* ((n (length vector1)) - (sum-x (loop for i from 0 to (1- n) - sum (aref vector1 i))) - (sum-y (loop for i from 0 to (1- n) - sum (aref vector2 i))) - (equation-bl (sqrt (- (* n - (loop for i from 0 to (1- n) - sum (expt (aref vector1 i) 2))) - (expt sum-x 2)))) - (equation-br (sqrt (- (* n - (loop for i from 0 to (1- n) - sum (expt (aref vector2 i) 2))) - (expt sum-y 2)))) - (equation-b (* equation-br equation-bl)) - (equation-tr (* sum-x sum-y)) - (equation-t 0) - (results-array (make-array n))) - (if (= equation-b 0) - (make-array 12 :initial-element 0) - (do ((i 0 (1+ i))) - ((= i n) results-array) - (setf equation-t (- (* n (loop for j from 0 to (1- n) - sum (* (aref vector1 (mod (+ i j) n)) - (aref vector2 j)))) - equation-tr) - (aref results-array i) (/ equation-t equation-b)))))) - - -(defparameter *krumhansl-schmuckler-minor-key* - (make-array 12 :initial-contents '(6.33 2.68 3.52 5.38 2.6 3.53 2.54 4.75 3.98 2.69 3.34 3.17))) - -(defparameter *krumhansl-schmuckler-major-key* - (make-array 12 :initial-contents '(6.35 2.23 3.48 2.33 4.38 4.09 2.52 5.19 2.39 3.66 2.29 2.88))) - -(defun krumhansl-key-finder (anchored-period composition - &key (major *krumhansl-schmuckler-major-key*) - (minor *krumhansl-schmuckler-minor-key*)) - (let* ((key) (best-score -1) - (pitches (pitch-class-distribution anchored-period composition)) - (majors (vector-correlation pitches major)) - (minors (vector-correlation pitches minor))) - (loop for i from 0 to 11 - do (when (> (aref majors i) best-score) - (setf key (list i :major) - best-score (aref majors i)))) - (loop for i from 0 to 11 - do (when (> (aref minors i) best-score) - (setf key (list i :minor) - best-score (aref minors i)))) - (values key (key->midi-key-signature key anchored-period)))) - -(defvar *line-of-fifths* (list 1 8 3 10 5 0 7 2 9 4 11 6)) - -(defun key->midi-key-signature (key anchored-period) - (let* ((tonic (car key)) - (mode (cadr key)) - (sharps (- (ecase mode - (:major (position tonic *line-of-fifths*)) - (:minor (position (mod (- tonic 9) 12) *line-of-fifths*))) - 5)) - (mode (ecase mode (:major 0) (:minor 9)))) - (amuse:make-midi-key-signature sharps mode - (timepoint anchored-period) - (duration anchored-period)))) (defun levenshtein-distance (s1 s2 &key (insertion-cost 1) (insertion-function) (deletion-cost 1)