annotate utils/harmony/chord-labelling.lisp @ 41:90abdf9adb60

monodising and some n-gram utilities

darcs-hash:20070614140028-f76cc-9bdeba6db4097e425b1fee4f58a3327eeb486685.gz

(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))