view utils/harmony/evaluation.lisp @ 39:262aa7a3d500

Fix (?) for vector-correlation

darcs-hash:20070525165241-40ec0-3fccec4b7b3b87ed31c3ea29a872ae6b63c2cf15.gz

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