d@33: (in-package #:amuse-harmony)
d@33: 
d@33: ;; This file contains functions for performing harmonic analysis and
d@33: ;; chord labelling. At the moment it's quite crude.
d@33: ;; 
d@33: ;; Probability can be estimated based on a function that must take a
d@33: ;; window on the music (i.e. an anchored period and a composition (?
d@33: ;; or perhaps a 'constituent' in future?). The functionality below is
d@33: ;; a cut-down version of its predecessors and only models one pitch
d@33: ;; model, derived by combining dirichlet distributions on the local
d@33: ;; distribution of pitch-class durations in terms of
d@33: ;; chord-note:non-chord-note ratios and relative weighting of chord
d@33: ;; notes.
d@33: ;;
d@33: ;; * Chord objects contain details of chord types including the
d@33: ;; intervals of their constituents and any putative distributional
d@33: ;; information or note profiles or templates.
d@33: ;;
d@33: ;; * Chordset objects gather chord-types together for a given
d@33: ;; experiment. They have a slot for priors for historical reasons, but
d@33: ;; at the moment this is unused - I'm using other structures for this.
d@33: ;;
d@33: ;; * likelihoods are currently alists with a host of methods. (FIXME:
d@33: ;;   this doesn't seem very clever)
d@33: ;;
d@33: 
d@33: ;; FIXME: this is in the wrong place
d@34: (defparameter *keys* (make-array 12 :initial-contents '(:c :c# :d :eb :e :f :f# :g :ab :a :bb :b)))
d@33: 
d@33: (defparameter *path-options*
d@33:   ;; Each of these is a set of division-of-the-bar options for each
d@33:   ;; metrical type.
d@33:   ;;
d@33:   ;; FIXME: behaviour if the time-signature numerator is absent from
d@33:   ;; the alist is undefined.
d@33:   '((4 (1 1 1 1) (1 1 2) (1 2 1) (1 3)
d@33:      (2 1 1) (2 2) (3 1) (4))
d@33:     ;; (4 (1 1 1 1) (1 1 2) (2 1 1) (2 2) (4))
d@33:     (2 (1 1) (2))
d@33:     (3 (1 1 1) (1 2) (2 1) (3))
d@33:     (6 (3 3) (6))
d@33:     (5 (1 1 1 1 1) (1 1 1 2) (1 1 2 1) (1 1 3)
d@33:      (1 2 1 1) (1 2 2) (1 3 1) (1 4)
d@33:      (2 1 1 1) (2 1 2) (2 2 1) (2 3)
d@33:      (3 1 1) (3 2) (4 1) (5))
d@33:     (9 (3 3 3) (3 6) (6 3) (9))
d@33:     (12 (3 3 3 3) (3 3 6) (3 6 3) (3 9)
d@33:      (6 3 3) (6 6) (9 3) (12))))
d@33: 
d@33: #+nil
d@33: (defparameter *default-models* '(:constant-prior :gamma))
d@33: #+nil
d@33: (defparameter *default-models* '(:scaled-prior :gamma :naive-bass))
d@33: ;; #+nil
d@33: (defparameter *default-models* '(:scaled-prior :gamma))
d@33: #+nil
d@33: (defparameter *default-models* '(:scaled-prior :gamma :metrical-prior))
d@33: 
d@33: ;;; ACCESSORS
d@33: ;; Nearly empty now. And not much point in what's left
d@33: (defgeneric normalised-distribution (chord &optional total))
d@33: (defmethod normalised-distribution ((chord chord) &optional (total 1))
d@33:   ;; normalised distributions will be reused, so it makes sense to
d@33:   ;; store them.
d@33:   ;; FIXME: Are these ever going to be useful again?
d@33:   (unless (assoc total (slot-value chord 'normalised-distribution))
d@33:     (setf (slot-value chord 'normalised-distribution)
d@33: 	  (acons total (normalise-vector (slot-value chord 'distribution) total)
d@33: 		 (slot-value chord 'normalised-distribution))))
d@33:   (cdr (assoc total (slot-value chord 'normalised-distribution))))
d@33: 
d@33: ;;; Object definitions
d@33: 
d@33: #+nil
d@33: (defparameter *major-ratios* (mapcar (lambda (x) (/ x 217))
d@33: 				     '(180 1 1 1 20 1 1 8 1 1 1 1)))
d@33: #+nil
d@33: (defparameter *major-ratios* (mapcar (lambda (x) (/ x 20))
d@33: 				     '(5 1 2 1 3 1 1 2 1 1 1 1)))
d@33: (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))
d@33: #+nil
d@33: (defparameter *minor-ratios* (mapcar (lambda (x) (/ x 302))
d@33: 				     '(280 1 1 4 1 1 1 9 1 1 1 1)))
d@33: (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))
d@33: #+nil
d@33: (defparameter *minor-ratios* (mapcar (lambda (x) (/ x 20))
d@33: 				     '(7 1 2 2 1 1 1 1 1 1 1 1)))
d@33: #+nil
d@33: (defparameter *sus-ratios* (mapcar (lambda (x) (/ x 21))
d@33: 				     '(10 1 1 1 1 1 1 1 1 1 1 1)))
d@33: (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))
d@33: 
d@33: (defparameter *dim-ratios* (copy-seq *sus-ratios*))
d@33: (defparameter *aug-ratios* (copy-seq *sus-ratios*))
d@33: 
d@33: ;; Chords
d@33: (defparameter *major-chord*
d@33:   (make-instance 'chord
d@33: 		 :label :major
d@33: 		 :notes '(0 4 7)
d@33: 		 :bass-likelihoods (make-array 12
d@33: 					   :initial-contents *major-ratios*)
d@33: 		 :min-distribution (make-array 4 :initial-contents '(35 25 20 20))
d@33: 		 :distribution (make-array 12
d@33: 					   :initial-contents '(6 1 2 1 5 2 1 5 1 2 2 2))))
d@33: 
d@33: (defparameter *minor-chord*
d@33:   (make-instance 'chord :label :minor :notes '(0 3 7)
d@33: 		 :min-distribution (make-array 4 :initial-contents '(35 25 20 20))
d@33: 		 :bass-likelihoods (make-array 12
d@33: 					   :initial-contents *minor-ratios*)
d@33: 		 :distribution (make-array 12
d@33: 					   :initial-contents '(6 1 2 5 1 2 1 5 2 1 2 1))))
d@33: 
d@33: (defparameter *diminished-chord*
d@33:   (make-instance 'chord :label :dim :notes '(0 3 6)
d@33: 		 :min-distribution (make-array 4 :initial-contents '(35 25 20 20))
d@33: 		 :bass-likelihoods (make-array 12
d@33: 					   :initial-contents *dim-ratios*)
d@33: 		 :distribution (make-array 12
d@33: 					   :initial-contents '(6 1 1 5 1 1 5 1 1 4 1 1))))
d@33: 
d@33: (defparameter *diminished-chord-short*
d@33:   (make-instance 'chord :label :dim :notes '(0 3 6 9)
d@33: 		 :min-distribution (make-array 4 :initial-contents '(35 25 20 20))
d@33: 		 :distribution (make-array 3
d@33: 					   :initial-contents '(6 1 1))))
d@33: 
d@33: (defparameter *augmented-chord*
d@33:   (make-instance 'chord :label :aug :notes '(0 4 8) :min-distribution #(35 25 20 20)
d@33: 		 :bass-likelihoods (make-array 12
d@33: 					   :initial-contents *aug-ratios*)
d@33: 		 :distribution (make-array 12
d@33: 					   :initial-contents '(6 1 1 1 5 1 1 1 5 1 1 1))))
d@33: 
d@33: (defparameter *augmented-chord-short*
d@33:   (make-instance 'chord :label :aug :notes '(0 4 8)
d@33: 		 :distribution (make-array 4
d@33: 					   :initial-contents '(6 1 1 1))))
d@33: 
d@33: (defparameter *suspended4th-chord*
d@33:   (make-instance 'chord :label :sus4 :notes '(0 5 7)
d@33: 		 :min-distribution (make-array 4 :initial-contents '(35 25 20 20))
d@33: 		 :bass-likelihoods (make-array 12
d@33: 					   :initial-contents *sus-ratios*)
d@33: 		 :distribution (make-array 12
d@33: 					   :initial-contents '(6 1 2 3 3 5 1 5 1 1 2 2))))
d@33: 
d@33: (defparameter *suspended9th-chord*
d@33:   (make-instance 'chord :label :sus9 :notes '(0 2 7)
d@33: 		 :min-distribution (make-array 4 :initial-contents '(35 25 20 20))
d@33: 		 :bass-likelihoods (make-array 12
d@33: 					   :initial-contents *sus-ratios*)
d@33: 		 :distribution (make-array 12
d@33: 					   :initial-contents '(6 1 5 2 2 2 1 5 1 2 2 1))))
d@33: 
d@33: ;; CHORDSETS
d@33: (defparameter *full-set*
d@33:   (make-instance 'chordset :chords (list *major-chord* *minor-chord*
d@33: 				     *diminished-chord* *augmented-chord*
d@33: 				     *suspended4th-chord* *suspended9th-chord*)))
d@33: 
d@33: (defparameter *full-set-variable-length*
d@33:   (make-instance 'chordset :chords (list *major-chord* *minor-chord*
d@33: 					 *diminished-chord-short* *augmented-chord-short*
d@33: 					 *suspended4th-chord* *suspended9th-chord*)))
d@33: 
d@33: (defparameter *partial-set*
d@33:   (make-instance 'chordset :chords (list *major-chord* *minor-chord*
d@33: 				     *diminished-chord* *augmented-chord*)))
d@33: 
d@33: (defparameter *partial-set-variable-length*
d@33:   (make-instance 'chordset
d@33: 		 :chords (list *major-chord* *minor-chord*
d@33: 			       *diminished-chord-short*
d@33: 			       *augmented-chord-short*)))
d@33: 
d@33: (defparameter *minimal-set*
d@33:   (make-instance 'chordset :chords (list *major-chord* *minor-chord*)))
d@33: 
d@33: #+nil
d@33: (defparameter *chord-proportions* ;; guess
d@33:   (list (cons *major-chord* 17/30) (cons *minor-chord* 10/30)
d@33: 	(cons *diminished-chord* 1/60) (cons *augmented-chord* 1/60)
d@33: 	(cons *suspended4th-chord* 1/30) (cons *suspended9th-chord* 1/30)))
d@33: 
d@33: #+nil
d@33: (defparameter *chord-proportions* ;; another guess
d@33:   (list (cons *major-chord* 1/3) (cons *minor-chord* 1/3)
d@33: 	(cons *diminished-chord* 1/30) (cons *augmented-chord* 1/60)
d@33: 	(cons *suspended4th-chord* 1/5) (cons *suspended9th-chord* 1/12)))
d@33: #+nil
d@33: (defparameter *chord-proportions* ;; flat
d@33:   (list (cons *major-chord* 1/6) (cons *minor-chord* 1/6)
d@33: 	(cons *diminished-chord* 1/6) (cons *augmented-chord* 1/6)
d@33: 	(cons *suspended4th-chord* 1/6) (cons *suspended9th-chord* 1/6)))
d@33: 
d@33: (defparameter *chord-proportions*
d@33:   ;; observed
d@33:   ;; FIXME: This seriously impairs dim and aug. Do they ever get
d@33:   ;; diagnosed now?
d@33:   (list (cons *major-chord* 546/917) (cons *minor-chord* 312/917)
d@33: 	(cons *diminished-chord* 2/917) (cons *augmented-chord* 1/917)
d@33: 	(cons *suspended4th-chord* 44/917) (cons *suspended9th-chord* 12/917)))
d@33: 
d@33: 
d@33: ;; First steps to chord labelling
d@33: (defun get-chord-likelihoods-for-model (anchored-period music
d@33: 					&key (model :gamma)
d@33: 					(chordset *full-set*))
d@33:   ;; Currently expects and returns an alist of (identifier
d@33:   ;; . likelihood) (unnormalised, but can use normalise-likelihoods)
d@33:   (ecase model
d@33:     (:constant-prior 
d@33:      ;; results are divided by number of chords in chordset (times 12)
d@33:      (constant-prior-likelihoods anchored-period
d@33: 				 music
d@33: 				 chordset))
d@33:     (:scaled-prior
d@33:      ;; results are divided by preset chord weightings (times 12)
d@33:      (scaled-prior-likelihoods anchored-period
d@33: 			       music
d@33: 			       chordset))
d@33:     (:naive-bass
d@33:      (naive-bass-prior-likelihoods anchored-period
d@33: 				   music
d@33: 				   chordset))
d@33:     (:metrical-prior
d@33:      (metrical-prior-likelihoods anchored-period
d@33: 				 music
d@33: 				 chordset))
d@33:     (:gamma
d@33:      ;; dirichlet-based likelihood calculation
d@33:      (3ple-gamma-likelihoods anchored-period
d@33: 			     music
d@33: 			     chordset))))
d@33: 
d@33: ;; LIKELIHOOD-CALCULATION FUNCTIONS
d@33: (defgeneric metrical-prior-likelihoods  (anchored-period music chordset))
d@33: (defmethod metrical-prior-likelihoods ((anchored-period anchored-period)
d@33: 				       music chordset)
d@33:   (let* ((metrical-level (metrical-level-for-likelihood anchored-period music))
d@33: 	 (p (if (= metrical-level 1)
d@33: 		0.51
d@33: 		0.07)))
d@33:     (loop for chord in (chords chordset)
d@33:        nconc (loop for i from 0 to 11
d@33: 		  collect (cons (list i chord)
d@33: 				(/ p (* 12 (length (chords chordset)))))))))
d@33: 
d@33: (defgeneric constant-prior-likelihoods  (anchored-period music chordset))
d@33: (defmethod constant-prior-likelihoods ((anchored-period anchored-period)
d@33: 				       music chordset)
d@33:   ;; returns a flat distribution totalling 1
d@33:   (loop for chord in (chords chordset)
d@33:      nconc (loop for i from 0 to 11
d@33: 	      collect (cons (list i chord)
d@33: 			    (/ 1 (* 12 (length
d@33: 					(chords chordset))))))))
d@33: 
d@33: (defgeneric scaled-prior-likelihoods (anchored-period music chordset &key prior-alist))
d@33: (defmethod scaled-prior-likelihoods ((anchored-period anchored-period) music chordset
d@33: 				     &key (prior-alist *chord-proportions*))
d@33:   ;; returns a distribution based on the relative likelihood of chord types
d@33:   (loop for chord in (chords chordset)
d@33:      nconc (loop for i from 0 to 11
d@33: 	      collect (cons (list i chord)
d@33: 			    (/ (cdr (assoc chord prior-alist))
d@33: 			       12)))))
d@33: 
d@33: (defgeneric naive-bass-prior-likelihoods (anchored-period music chordset))
d@33: (defmethod naive-bass-prior-likelihoods ((anchored-period anchored-period) music chordset)
d@33:   (let ((pc (bass-note anchored-period music)))
d@33:     (loop for chord in (chords chordset)
d@33:        nconc (loop for i from 0 to 11
d@33: 		collect (cons (list i chord)
d@33: 			      (/ (aref (bass-likelihoods chord)
d@33: 				       (mod (+ i pc) 12))
d@33: 				 (length (chords chordset))))))))
d@33: 
d@33: (defgeneric 3ple-gamma-likelihoods (anchored-period music chordset))
d@33: (defmethod 3ple-gamma-likelihoods ((anchored-period anchored-period) music chordset)
d@33:   ;; Ask Christophe about what this one does - this function just
d@33:   ;; provides data to his dirichlet likelihood functions. Currently
d@33:   ;; limited to triads, this has two distributions for relative
d@33:   ;; strengths of chord notes and for the relation between chord and
d@33:   ;; non-chord notes.
d@33:   (let ((pitch-classes (normalised-pitch-class-distribution anchored-period music))
d@33: 	(metrical-level (metrical-level-for-likelihood anchored-period music))
d@33: 	(likelihoods))
d@33:     (dolist (chord (chords chordset) likelihoods)
d@33:       (let ((chord-likelihoods (subseq (min-distribution chord) 0 3))
d@33: 	    (non-chord (aref (min-distribution chord) 3)))
d@33: 	(loop for offset from 0 to 11
d@33: 	   do (setf likelihoods
d@33: 		    (set-likelihood
d@33: 		     likelihoods chord offset
d@33: 		     (3ple-likelihood (chromatic-rotate pitch-classes (- offset))
d@33: 				      chord-likelihoods
d@33: 				      non-chord
d@33: 				      (main-notes chord)
d@33: 				      metrical-level 1
d@33: 				      (get-alphas chord metrical-level :version :learned)
d@33: 				      (get-betas chord metrical-level :version :learned)))))))))
d@33: 
d@33: #+nil
d@33: (defun get-alphas (chord metrical-level &key (version :map))
d@33:   ;; MP values, map commented
d@33:   (cond 
d@33:     ((or (eq *major-chord* chord)
d@33: 	 (eq *minor-chord* chord))
d@33:      (cond 
d@33:        ((< metrical-level 1)
d@33: 	(case version
d@33: 	  (:map #(3.7812 2.4955 2.1525))
d@33: 	  (:ml #(4.0398 2.6624 2.2942))
d@33: 	  (:learned #(2.0475 1.365 1.1374999))))
d@33:        (t
d@33: 	(case version
d@33: 	  (:map #(3.6626 1.5234 2.3395))
d@33: 	  (:ml #(3.9119 1.6193 2.4955))
d@33: 	  (:learned #(2.0475 1.365 1.1374999))))))
d@33:     (t 
d@33:      (case version
d@33:        (:map #(3.5110 2.0252 1.2963))
d@33:        (:ml #(4.0822 2.3459 1.4874))
d@33:        (:learned #(2.0475 1.365 1.1374999))))))
d@33: 
d@33: ;; New, corrected ground truth
d@33: (defun get-alphas (chord metrical-level &key (version :map))
d@33:   ;; MP values, map commented
d@33:   (cond 
d@33:     ((or (eq *major-chord* chord)
d@33: 	 (eq *minor-chord* chord))
d@33:      (cond 
d@33:        ((< metrical-level 1)
d@33: 	(case version
d@33: 	  (:map #(3.7397 2.4923 2.0187))
d@33: 	  (:ml #(3.9434 2.6253 2.1239))
d@33: 	  (:learned #(2.0475 1.365 1.1374999))))
d@33:        (t
d@33: 	(case version
d@33: 	  (:map #(3.2620 1.3882 2.2542))
d@33: 	  (:ml #(3.5200 1.4889 2.4293))
d@33: 	  (:learned #(2.0475 1.365 1.1374999))))))
d@33:     (t 
d@33:      (case version
d@33:        (:map #(3.1963 1.8187 1.3340))
d@33:        (:ml #(3.6371 2.0621 1.2799))
d@33:        (:learned #(2.0475 1.365 1.1374999))))))
d@33: 
d@33: #+nil
d@33: (defun get-betas (chord metrical-level &key (version :map))
d@33:   (cond 
d@33:     ((eq version :learned)
d@33:      (cond
d@33:        ((> metrical-level 1/2)
d@33: 	#(0.97 12))
d@33:        ((= metrical-level 1/2)
d@33: 	#(0.97 6))
d@33:        (t #(0.97 4))))
d@33:     ((or (eq *major-chord* chord)
d@33: 	 (eq *minor-chord* chord))
d@33:      (if (< metrical-level 1)
d@33: 	 (if (eq version :map)
d@33: 	     #(0.6987 3.1724)
d@33: 	     #(0.7164 3.2640))
d@33: 	 (if (eq version :map)
d@33: 	     #(1.3677 5.9215)
d@33: 	     #(1.4454 6.2843))))
d@33:     (t 
d@33:      (if (eq version :map)
d@33: 	 #(0.9358 5.2212)
d@33: 	 #(1.0431 5.8530)))))
d@33: 
d@33: ;; With new, corrected ground truth
d@33: (defun get-betas (chord metrical-level &key (version :map))
d@33:   (cond 
d@33:     ((eq version :learned)
d@33:      (cond
d@33:        ((> metrical-level 1/2)
d@33: 	#(0.97 12))
d@33:        ((= metrical-level 1/2)
d@33: 	#(0.97 6))
d@33:        (t #(0.97 4))))
d@33:     ((or (eq *major-chord* chord)
d@33: 	 (eq *minor-chord* chord))
d@33:      (if (< metrical-level 1)
d@33: 	 (if (eq version :map)
d@33: 	     #(0.7041 3.3448)
d@33: 	     #(0.7190 3.4260))
d@33: 	 (if (eq version :map)
d@33: 	     #(1.3838 6.4581)
d@33: 	     #(1.4872 6.9785))))
d@33:     (t 
d@33:      (if (eq version :map)
d@33: 	 #(0.9558 5.0847)
d@33: 	 #(1.0551 5.6740)))))
d@33: 
d@33: 
d@33: (defun chromatic-rotate (vector offset)
d@33:   ;; transpose an n-member (chromatic) vector by an integral number of
d@33:   ;; steps (semitones)
d@33:   (let* ((size (length vector))
d@33: 	 (result (make-array size)))
d@33:     (dotimes (i size result)
d@33:       (setf (aref result i) (aref vector (mod (- i offset) size))))))
d@33: 
d@33: (defgeneric metrical-level-for-likelihood (anchored-period music))
d@33: (defmethod metrical-level-for-likelihood (anchored-period (music composition))
d@33:   ;; metrical level is a function of time signature and window size
d@33:   ;; and is used to modify the gamma function.
d@33:   (let ((time-sigs (get-applicable-time-signatures anchored-period music)))
d@33:     (cond
d@33:       ((= (length time-sigs) 1)
d@33:        (/ (duration anchored-period)
d@33: 	  (crotchets-in-a-bar (first time-sigs))))
d@33:       ((null time-sigs)
d@33:        ;; If, for some reason, we have no time-signature, midi specs
d@33:        ;; say assume 4/4.
d@33:        (/ (duration anchored-period) 4))
d@33:       (t
d@33:        (loop for sig in time-sigs
d@33: 	  sum (/ (duration (period-intersection sig
d@33: 						anchored-period))
d@33: 		 (crotchets-in-a-bar sig)))))))
d@33: 
d@33: ;;;;;;;;;;;;;;;;;;;;;;;;
d@33: ;;
d@33: ;; Hypothesis comparison / level navigation
d@33: ;;
d@33: 
d@33: (defun chord-labels (anchored-period music
d@33: 		     &key (chordset *full-set*)
d@33: 		     (models *default-models*))
d@33:   (let ((harmonic-analysis (best-level anchored-period music :chordset chordset :models models))
d@33: 	(best-likelihood) (chord-labels))
d@33:     (do ((path (first harmonic-analysis) (cdr path))
d@33: 	 (likelihoods (second harmonic-analysis) (cdr likelihoods)))
d@33: 	((null path) (reverse chord-labels))
d@33:       (dolist (likelihood (car likelihoods))
d@33: 	(when (or (null best-likelihood)
d@33: 		  (> (likelihood-likelihood likelihood)
d@33: 		     (likelihood-likelihood best-likelihood)))
d@33: 	  (setf best-likelihood likelihood)))
d@33:       (push (cons (first path) (likelihood-chord best-likelihood)) chord-labels)
d@33:       (setf best-likelihood nil))))
d@33: 
d@33: (defun best-level (anchored-period music
d@33: 		   &key (chordset *full-set*)
d@33: 		   (models *default-models*))
d@33:   ;; Takes a period for the largest time-unit being considered and
d@33:   ;; returns the highest probability subdivision, its likelihood
d@33:   ;; values (and the probability of that subdivision, but that's a bit
d@33:   ;; of a coincidence and may want not to happen)
d@33:   (best-level-hypothesis (make-metrical-divisions anchored-period music)
d@33: 			 music :chordset chordset :models models))
d@33: 
d@33: (defgeneric make-metrical-divisions (anchored-period music))
d@33: (defmethod make-metrical-divisions ((anchored-period anchored-period)
d@33: 				    (music composition))
d@33:   ;; Prepares a set of divisions of the period based on time-sig and a
d@33:   ;; pre-set list of options for each possible time-sig numerator.
d@33:   (let ((time-sigs (get-applicable-time-signatures anchored-period music)))
d@33:     (if
d@33:      (< (length time-sigs) 2)
d@33:      (let ((candidates))
d@33:        ;; get an appropriate set of divisions. Not sure this is right
d@33:        ;; - it relies on bar position being irrelevant. Is this true?
d@33:        ;; This isn't really clear from this code, but if there are no
d@33:        ;; time-signatures, make-divisions-with-timesigs has a test for
d@33:        ;; it and will pretend it's 4/4.
d@33:        (dolist (divisions (make-divisions-with-time-signature anchored-period (car time-sigs))
d@33: 		candidates)
d@33: 	 (do ((time (onset anchored-period) (cut-off (car candidate-set)))
d@33: 	      (divisions divisions (cdr divisions))
d@33: 	      (candidate-set))
d@33: 	     ((null divisions) (push (reverse candidate-set) candidates))
d@33: 	   (push (make-anchored-period (timepoint time) (first divisions))
d@33: 		 candidate-set))))
d@33:      ;; otherwise, there are lots. Run this function once for each
d@33:      ;; time-signature.
d@33:      (loop for time-sig in time-sigs
d@33: 	  nconc (make-metrical-divisions (period-intersection anchored-period time-sig)
d@33: 					   music)))))
d@33: 
d@33: (defgeneric make-divisions-with-time-signature (period time-signature))
d@33: (defmethod make-divisions-with-time-signature ((period period-designator)
d@33: 					       (time-signature basic-time-signature))
d@33:   (let* ((numerator (time-signature-numerator time-signature))
d@33: 	 (denominator (time-signature-denominator time-signature))
d@33: 	 (path-options (cdr (assoc numerator *path-options*))))
d@33:     (loop for divisions in path-options
d@33:        collect (period-fill period divisions denominator))))
d@33: 
d@33: (defmethod make-divisions-with-time-signature ((period period-designator)
d@33: 					       time-signature)
d@33:   ;; not a known time-signature type. Assume 4/4
d@33:   (let ((path-options (cdr (assoc 4 *path-options*))))
d@33:     (loop for divisions in path-options
d@33:        collect (period-fill period divisions 4))))
d@33:     
d@33: (defun period-fill (period path-options denominator)
d@33:   ;; take a division of the ?bar and then repeat it until the period
d@33:   ;; is filled.
d@33:   ;;
d@33:   ;; Perhaps this and surrounding function need to make more use of
d@33:   ;; time interface?
d@33:   (let ((duration-list)
d@33: 	;; Multiply path-options by unit of meter.
d@33: 	(path-options (map 'list
d@33: 			   #'(lambda (x) (* x (/ 4 denominator)))
d@33: 			   path-options)))
d@33:     (do* ((circular-path path-options (or (cdr circular-path)
d@33: 					  path-options))
d@33: 	  (current-duration (car circular-path) (car circular-path))
d@33: 	  (prev-remaining (duration period) remaining)
d@33: 	  (remaining (- (duration period) current-duration) (- remaining current-duration)))
d@33: 	 ((<= remaining 0) (reverse (cons prev-remaining duration-list)))
d@33:       (push current-duration duration-list))))
d@33: 
d@33: (defun best-level-hypothesis (division-hypotheses music
d@33: 			      &key (chordset *full-set*)
d@33: 			      (models *default-models*))
d@33:   ;; Rather messy wrapper for level-hypothesis-likelihoods. Should
d@33:   ;; probably make this a structure or something, but use looks like
d@33:   ;; being quite limited. might revisit.
d@33:   (first (sort (level-hypothesis-likelihoods division-hypotheses
d@33: 					     music
d@33: 					     :chordset chordset
d@33: 					     :models models)
d@33: 	       #'> :key #'third)))
d@33: 
d@33: (defun level-hypothesis-likelihoods (division-hypotheses music
d@33: 				     &key (chordset *full-set*)
d@33: 				     (models *default-models*))
d@33:   ;; This function takes the candidate windows being considered (as
d@33:   ;; lists of anchored periods) and, for each, works out likelihoods
d@33:   ;; and the most probable hypothesis. This should come from taking
d@33:   ;; the likelihoods and dividing by the product of the internal sums
d@33:   ;; (don't ask!)
d@33:   (let ((hypothesis-likelihoods))
d@33:     (dolist (hypothesis division-hypotheses hypothesis-likelihoods)
d@33:       (let ((likelihoods (map 'list
d@33: 			      #'(lambda (x)
d@33: 				  (get-chord-likelihoods x music models chordset))
d@33: 			      hypothesis)))
d@33: 	(push (list hypothesis likelihoods (combined-likelihoods-sum likelihoods))
d@33: 	      hypothesis-likelihoods)))))
d@33: 
d@33: (defun get-chord-likelihoods (anchored-period music models chordset)
d@33:   (let ((model-likelihoods
d@33: 	 (loop for model in models
d@33: 	    collect (get-chord-likelihoods-for-model anchored-period
d@33: 						     music
d@33: 						     :model model
d@33: 						     :chordset chordset))))
d@33:     (combine-multimodel-likelihoods model-likelihoods)))
d@33: 
d@33: (defun combine-multimodel-likelihoods (likelihoods-list)
d@33:   (cond
d@33:     ((= (length likelihoods-list) 1)
d@33:      (car likelihoods-list))
d@33:     (t
d@33:      (let ((combined-likelihoods))
d@33:        (dolist (reference-likelihood (car likelihoods-list) combined-likelihoods)
d@33: 	 (setf combined-likelihoods
d@33: 	       (set-likelihood combined-likelihoods
d@33: 			       (likelihood-chordtype reference-likelihood)
d@33: 			       (likelihood-pitch-class reference-likelihood)
d@33: 			       (apply #'* (loop for model-likelihoods in likelihoods-list
d@33: 					     collect (likelihood-likelihood
d@33: 						      (assoc (car reference-likelihood)
d@33: 							     model-likelihoods
d@33: 							     :test #'equal)))))))))))
d@33: 
d@33: ;;;;;;;;;;;;;;;;;;;;;;;;;
d@33: ;;
d@33: ;; Likelihood (structure) manipulation and access methods
d@33: ;;
d@41: ;; FIXME: Explain this?? Is it ((pc :type) . p(chord))?
d@33: 
d@33: (defgeneric set-likelihood (likelihoods offset chord likelihood))
d@33: (defmethod set-likelihood ((likelihoods list) chord offset likelihood)
d@33:   (acons (list offset chord) likelihood likelihoods))
d@33: 
d@33: (defgeneric get-likelihood (likelihoods offset chord))
d@33: (defmethod get-likelihood ((likelihoods list) offset chord)
d@33:   (assoc (list offset chord) likelihoods :test #'equal))
d@33: 
d@33: (defgeneric best-n-likelihoods (n likelihoods))
d@33: (defmethod best-n-likelihoods (n (likelihoods list))
d@33:   (let ((ranked (ordered-likelihoods likelihoods)))
d@33:     (subseq ranked 0 n)))
d@33: 
d@33: (defgeneric ordered-likelihoods (likelihoods))
d@33: (defmethod ordered-likelihoods ((likelihoods list))
d@33:   (sort (copy-seq likelihoods) #'> :key #'cdr))
d@33: 
d@33: (defgeneric pretty-display-likelihoods (likelihoods))
d@33: (defmethod pretty-display-likelihoods ((likelihoods list))
d@33:   (dolist (p likelihoods)
d@33:     (format *standard-output* "~%~A~C~A~C~A"
d@33: 	    (likelihood-key p) #\Tab
d@33: 	    (chord-label (likelihood-chordtype p)) #\Tab
d@33: 	    (likelihood-likelihood p))))
d@33: 
d@33: (defgeneric likelihood-key (likelihood))
d@33: (defmethod likelihood-key ((likelihood list))
d@33:   (aref *keys* (first (first likelihood))))
d@33: 
d@33: (defgeneric likelihood-pitch-class (likelihood))
d@33: (defmethod likelihood-pitch-class ((likelihood list))
d@33:   (first (first likelihood)))
d@33: 
d@33: (defgeneric likelihood-chordtype (likelihood))
d@33: (defmethod likelihood-chordtype ((likelihood list))
d@33:   (second (first likelihood)))
d@33: 
d@33: (defgeneric likelihood-chord (likelihood))
d@33: (defmethod likelihood-chord ((likelihood list))
d@33:   (first likelihood))
d@33: 
d@33: (defgeneric likelihood-likelihood (likelihood))
d@33: (defmethod likelihood-likelihood ((likelihood list))
d@33:   (cdr likelihood))
d@33: 
d@33: (defgeneric likelihoods-sum (likelihoods))
d@33: (defmethod likelihoods-sum ((likelihoods list))
d@33:   (loop for likelihood in likelihoods
d@33:      sum (likelihood-likelihood likelihood)))
d@33: 
d@33: (defgeneric combined-likelihoods-sum (combined-likelihoods))
d@33: (defmethod combined-likelihoods-sum ((combined-likelihoods list))
d@33:   ;; Will be needed for hypothesis comparison - sums the likelihoods
d@33:   ;; for all chords within a window for multiple likelihood
d@33:   ;; calculations
d@33:   (apply #'* (map 'list #'(lambda (window)
d@33: 			    (loop for likelihood in window
d@33: 			       sum (likelihood-likelihood likelihood)))
d@33: 		  combined-likelihoods)))
d@33: 
d@33: (defgeneric normalise-likelihoods (likelihoods))
d@33: (defmethod normalise-likelihoods ((likelihoods list))
d@33:   (let ((p-sum (sum-likelihoods likelihoods)))
d@33:     (if (= p-sum 1) 
d@33: 	likelihoods
d@33: 	(scale-likelihoods likelihoods (/ 1 p-sum)))))
d@33: 
d@33: (defgeneric scale-likelihoods (likelihoods scale-factor))
d@33: (defmethod scale-likelihoods ((likelihoods list) (scale-factor number))
d@33:   (map 'list #'(lambda (x)
d@33: 		 (cons (first x)
d@33: 		       (* (cdr x) scale-factor)))
d@33:        likelihoods))
d@33: 
d@33: (defgeneric sum-likelihoods (likelihoods))
d@33: (defmethod sum-likelihoods ((likelihoods list))
d@33:   (apply #'+ (map 'list #'cdr likelihoods)))
d@33: 
d@33: ;; Probably useless vestigial stuff from here
d@33: 
d@33: (defun vector-list-apply (predicate vector-list &optional other-args)
d@33:   (let ((result-list))
d@33:     (dolist (vector vector-list (reverse result-list))
d@33:       (push (make-array (array-dimensions vector)) result-list)
d@33:       (loop for i from 0 to (1- (length vector))
d@33: 	 do (setf (aref (first result-list) i)
d@33: 		  (apply predicate (cons (aref vector i) other-args)))))))
d@33: 
d@33: (defun vector-sum (vector)
d@33:   (loop for i from 0 to (1- (length vector))
d@33:      sum (aref vector i)))
d@33: 
d@33: (defun make-flat-result (chordset)
d@33:   (map 'list #'(lambda (x)
d@33: 		 (make-array (length (distribution x))
d@33: 			     :initial-element 0))
d@33:        (chords chordset)))
d@33: 
d@33: (defun key-name (pitch-class)
d@33:   (if pitch-class
d@33:       (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "G#" "A" "Bb" "B") (mod pitch-class 12))
d@33:       nil))