d@33: ;; Stuff to compare: path (per model); correct window (per model); correct window|bass; correct window|bass
d@33: 
d@33: (in-package #:amuse-harmony)
d@33: 
d@33: (defparameter *test-pieces* '())
d@33: (defparameter *test-set* '())
d@33: (defparameter *dm-note-names* '("c" "c+" "d" "e-" "e" "f" "f+" "g" "g+" "a" "b-" "b"))
d@33: 
d@33: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
d@33: ;;
d@33: ;; Ground-truth data types and functions
d@33: ;;
d@33: 
d@33: (clsql:def-view-class truth-chord ()
d@33:   ((cat_id
d@33:     :type integer
d@33:     :accessor cat_id)
d@33:    (onset_bar
d@33:     :type integer
d@33:     :accessor start-bar)
d@33:    (onset_beat
d@33:     :type integer
d@33:     :accessor start-beat)
d@33:    (root
d@33:     :type string)
d@33:    (bass
d@33:     :type string)
d@33:    (chord-type
d@33:     :type string
d@33:     :accessor chord-type)
d@33:    (file
d@33:     :accessor harmony-file
d@33:     :db-kind :join
d@33:     :db-info (:join-class file
d@33: 			  :home-key cat_id
d@33: 			  :foreign-key cat_id
d@33: 			  :set nil)))
d@33:   (:base-table geerdes_harmony))
d@33:    
d@33: (defun all-chords ()
d@33:   #.(clsql:locally-enable-sql-reader-syntax)
d@33:   (map 'list #'car (clsql:select 'truth-chord :where 1))
d@33:   #.(clsql:restore-sql-reader-syntax-state))
d@33: 
d@33: (defun list-harmonised-pieces ()
d@33:   (remove-if #'(lambda (x) (member x '(886 5205 10586 3473 6993))) 
d@33: 	     (remove-duplicates (map 'list
d@33: 				     #'cat_id
d@33: 				     (all-chords)))))
d@33: 
d@33: (defun harmonised-bars (id)
d@33:   ;; List bars which have harmonies from piece with cat_id=id
d@33:   (let* ((piece-chords (piece-chord-list id)))
d@33:     (when piece-chords
d@33:       (let* ((chord-starts (map 'list #'start-bar piece-chords))
d@33: 	     (bar-max (1+ (apply #'max chord-starts)))
d@33: 	     (bar-min (apply #'min chord-starts))
d@33: 	     (bar-numbers))
d@33: 	(setf piece-chords (sort piece-chords #'chord-time->))
d@33: 	(do ((bar bar-min (1+ bar)))
d@33: 	    ((= bar bar-max) bar-numbers
d@33: 	     #+nil (make-array (length bar-numbers)
d@33: 			       :initial-contents (reverse bar-numbers)))
d@33: 	  (let ((harmony (get-applicable-chord (* 4 bar) piece-chords)))
d@33: 	    (when (and harmony
d@33: 		       (> (length (chord-type harmony)) 0))
d@33: 	      (push bar bar-numbers))))))))
d@33:   
d@33: (defun get-applicable-chord (beats chords &key (pre-sorted t))
d@33:   ;; Return the chord that would be sounding at a given point in
d@33:   ;; time. If this is being applied many times, it makes sense to sort
d@33:   ;; the data before providing it, hence the &key argument.
d@33:   (unless pre-sorted
d@33:     (setf chords (sort chords #'chord-time->)))
d@33:   (find-if #'(lambda (x) (or (< (start-bar x)
d@33: 				(floor beats 4))
d@33: 			     (and (= (start-bar x)
d@33: 				     (floor beats 4))
d@33: 				  (<= (start-beat x)
d@33: 				      (1+ (mod beats 4))))))
d@33: 	   chords))
d@33: 
d@33: (defun chord-time-> (chord1 chord2)
d@33:   (or (> (start-bar chord1)
d@33: 	 (start-bar chord2))
d@33:       (and (= (start-bar chord1)
d@33: 	      (start-bar chord2))
d@33: 	   (> (start-beat chord1)
d@33: 	      (start-beat chord2)))))
d@33: 
d@33: (defun chord-time-< (chord1 chord2)
d@33:   (or (< (start-bar chord1)
d@33: 	 (start-bar chord2))
d@33:       (and (= (start-bar chord1)
d@33: 	      (start-bar chord2))
d@33: 	   (< (start-beat chord1)
d@33: 	      (start-beat chord2)))))
d@33: 
d@33: (defun harmonised-pieces-bars-alist ()
d@33:   (let ((harmonised))
d@33:     (dolist (piece (list-harmonised-pieces) harmonised)
d@33:       (setf harmonised (acons piece (harmonised-bars piece) harmonised)))))
d@33: 
d@33: (defun all-bars ()
d@33:   (let ((harmonised))
d@33:     (dolist (piece (list-harmonised-pieces) harmonised)
d@33:       (dolist (bar (harmonised-bars piece))
d@33: 	(push (cons piece bar) harmonised)))))
d@33: 
d@33: (defun random-bars (target)
d@33:   (let* ((selection) (pieces-bars (make-array 1 :adjustable T :fill-pointer T)))
d@33:     (dolist (piece (list-harmonised-pieces))
d@33:       (loop for bar in (harmonised-bars piece)
d@33: 	 do (vector-push-extend (cons piece bar) pieces-bars)))
d@33:     (loop for i from 0 to (1- target)
d@33:        do (progn
d@33: 	    (rotatef (aref pieces-bars i)
d@33: 		     (aref pieces-bars
d@33: 			   (+ i (random (- (1- (length pieces-bars))
d@33: 					   i)))))
d@33: 	    (push (aref pieces-bars i) selection)))
d@33:     selection))
d@33: 
d@33: (defun write-piece-bars (list filename)
d@33:   (with-open-file (stream filename :direction :output :if-exists :supersede)
d@33:     (dolist (bar list)
d@33:       (format stream "~A~C~A~%" (car bar) #\Tab (cdr bar)))))
d@33: 
d@33: (defun read-piece-bars (filename)
d@33:   (let ((bars))
d@33:     (with-open-file (stream filename)
d@33:       (do ((line (read-line stream nil nil) (read-line stream nil nil)))
d@33: 	  ((null line) bars)
d@33: 	(let* ((s (make-string-input-stream line))
d@33: 	       (piece (read s))
d@33: 	       (bar (read s)))
d@33: 	  (push (cons piece bar) bars))))))
d@33: 
d@33: (defun get-window-sizes (piece bar &optional (odd-divisions nil))
d@33:   (let ((bar-chords (sort (remove-if #'(lambda (x) (or (not (= (cat_id x) piece))
d@33: 						       (not (= (start-bar x) bar))))
d@33: 				     (all-chords))
d@33: 			  #'chord-time-<)))
d@33:     (if odd-divisions
d@33: 	(get-window-sizes-2 bar-chords)
d@33: 	(get-window-sizes-1 bar-chords))))
d@33: 
d@33: (defun get-window-sizes-2 (bar-chords)
d@33:   (let ((path) (prev-chord))
d@33:     (dolist (beat-chord bar-chords)
d@33:       (cond
d@33: 	(prev-chord
d@33: 	 (push (- (start-beat beat-chord)
d@33: 		  (start-beat prev-chord))
d@33: 	       path))
d@33: 	((and (not prev-chord)
d@33: 	      (> (start-beat beat-chord) 1))
d@33: 	 (push (- (start-beat beat-chord) 1)
d@33: 	       path)))
d@33:       (setf prev-chord beat-chord))
d@33:     (if prev-chord
d@33: 	(push (- 5 (start-beat prev-chord))
d@33: 	      path)
d@33: 	(setf path '(4)))
d@33:     (reverse path)))
d@33: 
d@33: (defun get-window-sizes-1 (bar-chords)
d@33:   (let ((path) (prev-chord))
d@33:     (dolist (beat-chord bar-chords)
d@33:       (cond
d@33: 	((and (not prev-chord)
d@33: 	      (= (start-beat beat-chord) 4))
d@33: 	 ;; Three beats of preceding chord or no chord
d@33: 	 (return-from get-window-sizes-1 '(2 1 1)))
d@33: 	((and (not prev-chord)
d@33: 	      (> (start-beat beat-chord) 1))
d@33: 	 ;; not the first chord of bar - just the first to sound
d@33: 	 (push (1- (start-beat beat-chord)) path))
d@33: 	((and (= (start-beat beat-chord) 4)
d@33: 	      (< (start-beat prev-chord) 3))
d@33: 	 ;; Last chord of bar, but its predecessor spans half-bar
d@33: 	 ;; break.
d@33: 	 (return-from get-window-sizes-1 (reverse (concatenate 'list
d@33: 							     (list 1 1 (- 3 (start-beat prev-chord)))
d@33: 							     path))))
d@33: 	((= (start-beat beat-chord) 4)
d@33: 	 ;; last chord of bar
d@33: 	 (return-from get-window-sizes-1 (reverse (concatenate 'list
d@33: 							     (list 1 1)
d@33: 							     path))))
d@33: 	(prev-chord
d@33: 	 (push (- (start-beat beat-chord) (start-beat prev-chord))
d@33: 	       path)))
d@33:       (setf prev-chord beat-chord))
d@33:     (if prev-chord
d@33: 	(if (= (start-beat prev-chord) 2)
d@33: 	    '(1 1 2)
d@33: 	    (reverse (cons (- 5 (start-beat prev-chord)) path)))
d@33: 	'(4))))
d@33: 
d@33: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
d@33: 
d@33: (defun get-test-piece (cat-id)
d@33:   (unless (assoc cat-id *test-pieces*)
d@33:     (setf *test-pieces* (acons cat-id
d@33: 			       (get-composition (make-geerdes-cat-identifier cat-id))
d@33: 			       *test-pieces*)))
d@33:   (cdr (assoc cat-id *test-pieces*)))
d@33: 
d@33: (in-package "AMUSE-GEERDES")
d@33: 
d@33: (defclass harmonic-evaluation-period (anchored-period)
d@33:   ((cat-id :accessor %cat-id
d@33: 	   :initarg :cat-id)
d@33:    (file-id :accessor %file-id
d@33: 	    :initarg :file-id)
d@33:    (composition :accessor %composition
d@33: 		:initarg :composition)
d@33:    (bar-number :accessor %bar-number
d@33: 	       :initarg :bar-number)
d@33:    (composition-bar-number :accessor %c-bar-number
d@33: 			   :initarg :comp-bar-number)
d@33:    (ground-truth-chords :accessor %gt-chords
d@33: 			:initarg :gt-chords
d@33: 			:initform nil)
d@33:    (derived-windows :accessor %d-windows
d@33: 		    :initarg :d-windows
d@33: 		    :initform nil)
d@33:    (derived-chords :accessor %d-chords
d@33: 		   :initarg :d-chords
d@33: 		   :initform nil)
d@33:    (derived-likelihoods :accessor %d-likelihoods
d@33: 			:initarg :d-likelihoods
d@33: 			:initform nil)))
d@33: 
d@33: (defun reset-harmonisation (harmonisation)
d@33:   (setf (%d-chords harmonisation) nil
d@33: 	(%d-windows harmonisation) nil
d@33: 	(%d-likelihoods harmonisation) nil))
d@33: 
d@33: (defun derived-likelihoods (harmonisation &key (models *default-models*)
d@33: 			    (chordset *full-set*))
d@33:   (if (%d-likelihoods harmonisation)
d@33:       (%d-likelihoods harmonisation)
d@33:       (let* ((possible-window-combinations (make-metrical-divisions harmonisation
d@33: 								     (%composition harmonisation)))
d@33: 	     (possible-windows (remove-duplicates (apply #'nconc possible-window-combinations)
d@33: 						  :test #'period=)))
d@33: 	(setf (%d-likelihoods harmonisation)
d@33: 	      (loop for window in possible-windows
d@33: 		 collect (cons window
d@33: 			       (get-chord-likelihoods window
d@33: 						      (%composition harmonisation)
d@33: 						      models chordset)))))))
d@33: (defun ground-truth-window-sizes (harmonisation)
d@33:   (let* ((chords (ground-truth-chords harmonisation))
d@33: 	 (bar-number (%bar-number harmonisation))
d@33: 	 (beats (nconc (map 'list #'(lambda (x)
d@33: 				      (if (= (start-bar x)
d@33: 					     bar-number)
d@33: 					  (start-beat x)
d@33: 					  1))
d@33: 			    chords)
d@33: 		       (list (1+ (duration harmonisation))))))
d@33:     (map 'list #'- (cdr beats) beats)))
d@33: 
d@33: 
d@33: 
d@33: (defun ground-truth-chords (harmonisation)
d@33:   (if (%gt-chords harmonisation)
d@33:       (%gt-chords harmonisation)
d@33:       (let ((piece-chords (sort (piece-chord-list (%cat-id harmonisation))
d@33: 				#'chord-time->)) (gt-chords))
d@33: 	(setf (%gt-chords harmonisation)
d@33: 	      (dolist (pc piece-chords gt-chords)
d@33: 		(cond
d@33: 		  ((= (start-bar pc) (%bar-number harmonisation))
d@33: 		   (push pc gt-chords)
d@33: 		   (when (= (start-beat pc) 1)
d@33: 		     (return gt-chords)))
d@33: 		  ((< (start-bar pc) (%bar-number harmonisation))
d@33: 		   (return (cons pc gt-chords)))))))))
d@33: 
d@33: (defun derived-window-sizes (harmonisation &key (chordset *full-set*) models)
d@33:   (declare (ignore models))
d@33:   (unless (%d-windows harmonisation)
d@33:     (let ((level (best-level harmonisation (%composition harmonisation)
d@33: 				:chordset chordset)))
d@33: 	 (setf (%d-chords harmonisation)
d@33: 	       (loop for likelihoods in (second level)
d@33: 		  collect (likelihood-chord
d@33: 			   (car (best-n-likelihoods 1 likelihoods))))
d@33: 	       (%d-windows harmonisation) (first level))))
d@33:   (map 'list #'duration (%d-windows harmonisation)))
d@33: 
d@33: (defun derived-windows (harmonisation &key (chordset *full-set*) models)
d@33:   (declare (ignore models))
d@33:   (unless (%d-windows harmonisation)
d@33:     (let ((level (best-level harmonisation (%composition harmonisation)
d@33: 				:chordset chordset)))
d@33: 	 (setf (%d-chords harmonisation)
d@33: 	       (loop for likelihoods in (second level)
d@33: 		  collect (likelihood-chord
d@33: 			   (car (best-n-likelihoods 1 likelihoods))))
d@33: 	       (%d-windows harmonisation) (first level))))
d@33:   (%d-windows harmonisation))
d@33: 
d@33: (defun derived-chords (harmonisation &key (chordset *full-set*) models)
d@33:   (declare (ignore models))
d@33:   (cond
d@33:     ((%d-chords harmonisation)
d@33:      (%d-chords harmonisation))
d@33:     (t (let ((level (best-level harmonisation (%composition harmonisation)
d@33: 				:chordset chordset)))
d@33: 	 (setf (%d-windows harmonisation) (first level)
d@33: 	       (%d-chords harmonisation)
d@33: 	       (loop for likelihoods in (second level)
d@33: 		  collect (likelihood-chord (car (best-n-likelihoods 1 likelihoods)))))))))
d@33: 
d@33: (defparameter *harmonic-evaluation-period-cache* nil)		 
d@33: (defun get-harmonic-evaluation-period (bar-number &key cat-id file-id composition)
d@33:   (cond
d@33:     (cat-id (get-harmonic-evaluation-period-by-cat-id bar-number cat-id))
d@33:     (file-id (get-harmonic-evaluation-period-by-file-id bar-number file-id))
d@33:     (composition (get-harmonic-evaluation-period-by-composition bar-number composition))))
d@33: 
d@33: (defun get-harmonic-evaluation-period-by-cat-id (bar-number cat-id)
d@33:   (let ((harmonisation (find-if #'(lambda (x)
d@33: 				    (and (= (%cat-id x)
d@33: 					    cat-id)
d@33: 					 (= (%bar-number x)
d@33: 					    bar-number)))
d@33: 				*harmonic-evaluation-period-cache*)))
d@33:     (unless harmonisation
d@33: 	(setf harmonisation
d@33: 	      (make-harmonic-evaluation-period bar-number
d@33: 					       (get-test-piece cat-id)))
d@33: 	(push harmonisation *harmonic-evaluation-period-cache*))
d@33:     harmonisation))
d@33: 
d@33: (defun get-harmonic-evaluation-period-by-file-id (bar-number file-id)
d@33:   (let ((harmonisation (find-if #'(lambda (x)
d@33: 				    (and (= (%file-id x)
d@33: 					    file-id)
d@33: 					 (= (%bar-number x)
d@33: 					    bar-number)))
d@33: 				*harmonic-evaluation-period-cache*)))
d@33:     (unless harmonisation
d@33:       (let* ((composition (get-composition (make-geerdes-identifier file-id))))
d@33: 	(setf harmonisation (make-harmonic-evaluation-period bar-number
d@33: 							     composition))
d@33: 	(push harmonisation *harmonic-evaluation-period-cache*)))
d@33:     harmonisation))
d@33: 
d@33: (defun get-harmonic-evaluation-period-by-composition (bar-number composition)
d@33:   (let ((harmonisation (find-if #'(lambda (x)
d@33: 				    (and (eq (%composition x)
d@33: 					     composition)
d@33: 					 (= (%bar-number x)
d@33: 					    bar-number)))
d@33: 				*harmonic-evaluation-period-cache*)))
d@33:     (unless harmonisation
d@33:       (setf harmonisation (make-harmonic-evaluation-period bar-number
d@33: 							   composition))
d@33:       (push harmonisation *harmonic-evaluation-period-cache*))
d@33:     harmonisation))
d@33: 
d@33: (defun make-harmonic-evaluation-period (bar-number composition)
d@33:   (with-slots (cat_id id)
d@33:       (%db-entry composition)
d@33:     (let ((harmonisation (make-instance 'harmonic-evaluation-period
d@33: 					:cat-id cat_id
d@33: 					:file-id id
d@33: 					:composition composition
d@33: 					:bar-number bar-number
d@33: 					:comp-bar-number (1+ bar-number)))
d@33: 	  (period (whole-bar-period (1+ bar-number) composition)))
d@33:       (setf (timepoint harmonisation) (timepoint period)
d@33: 	    (duration harmonisation) (duration period))
d@33:       harmonisation)))
d@33: 
d@33: (defun verify-chord (truth-chord derived-chord)
d@33:   (let ((gt-root (pitch-class-from-gt (slot-value truth-chord 'root)))
d@33: 	(gt-label (chord-from-gt (chord-type truth-chord)))
d@33: 	(d-root (first derived-chord))
d@33: 	(d-label (chord-label (second derived-chord))))
d@33:     (samechordp gt-root gt-label d-root d-label)))
d@33: 
d@33: (defun get-chord (anchored-period harmonisation)
d@33:   (likelihood-chord (first (best-n-likelihoods 1
d@33: 					       (cdr (assoc anchored-period
d@33: 							   (derived-likelihoods harmonisation)
d@33: 							   :test #'period=))))))
d@33: 
d@33: (defun ground-truth-window-beats (harmonisation)
d@33:   (let ((beat 1) (beat-list '(1)))
d@33:     (dolist (size (ground-truth-window-sizes harmonisation) (reverse (cdr beat-list)))
d@33:        (push (incf beat size) beat-list))))
d@33: 
d@33: (defun find-matching-period (onset duration period-list)
d@33:   (find-if #'(lambda (x) (and (= onset (timepoint x))
d@33: 			      (= duration (duration x))))
d@33: 	   period-list))
d@33: 
d@33: (defun position-matching-period (onset duration period-list)
d@33:   (position-if #'(lambda (x) (and (= onset (timepoint x))
d@33: 				  (= duration (duration x))))
d@33: 	       period-list))
d@33: 
d@33: (defun compare-paths (bar piece &key (chordset *full-set*) models controlp mergep)
d@33:   ;; FIXME: Recreate controlp and mergep
d@33:   (declare (ignore controlp mergep models))
d@33:   (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
d@33: 	 (gtw-beats (ground-truth-window-beats harmonisation))
d@33: 	 (gtw-sizes (ground-truth-window-sizes harmonisation))
d@33: 	 (score (loop for i from 0 to (1- (length gtw-beats))
d@33: 		   count (find-matching-period (+ (1- (nth i gtw-beats))
d@33: 						  (timepoint harmonisation))
d@33: 					       (nth i gtw-sizes)
d@33: 					       (derived-windows harmonisation
d@33: 								:chordset chordset)))))
d@33:     (values (= score (length gtw-sizes)) score (length gtw-sizes))))
d@33: 
d@33: (defun compare-paths-and-harmonies (bar piece &key (chordset *full-set*) models controlp mergep)
d@33:   ;; FIXME: Recreate controlp and mergep
d@33:   (declare (ignore controlp mergep models))
d@33:   (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
d@33: 	 (gtw-beats (ground-truth-window-beats harmonisation))
d@33: 	 (gtw-sizes (ground-truth-window-sizes harmonisation))
d@33: 	 (g-chords (ground-truth-chords harmonisation))
d@33: 	 (d-chords (derived-chords harmonisation))
d@33: 	 (d-windows (derived-windows harmonisation :chordset chordset))
d@33: 	 (score (loop for i from 0 to (1- (length gtw-beats))
d@33: 		   count (let ((matchesp (position-matching-period (+ (1- (nth i gtw-beats))
d@33: 								      (timepoint harmonisation))
d@33: 								   (nth i gtw-sizes)
d@33: 								   d-windows)))
d@33: 			   (and matchesp
d@33: 				(verify-chord (nth i g-chords)
d@33: 					      (nth matchesp d-chords)))))))
d@33:     (values (= score (length gtw-sizes)) score (length gtw-sizes))))
d@33: 
d@33: (defun compare-harmonies-with-gt-windows (bar piece &key (chordset *full-set*) models)
d@33:   (declare (ignore chordset models))
d@33:   (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
d@33: 	 (ground-truth (ground-truth-chords harmonisation))
d@33: 	 (score 0))
d@33:     (do ((gt-chords ground-truth (cdr gt-chords)))
d@33: 	((null gt-chords) (values (= score (length ground-truth))
d@33: 				  score
d@33: 				  (length ground-truth)))
d@33:       (when (verify-chord (first gt-chords)
d@33: 			  (get-chord (make-anchored-period (+ (timepoint harmonisation)
d@33: 					 		      (1- (start-beat (first gt-chords))))
d@33: 							   (- (if (second gt-chords)
d@33: 								  (start-beat (second gt-chords))
d@33: 								  (duration harmonisation))
d@33: 							      (1- (start-beat (first gt-chords)))))
d@33: 				     harmonisation))
d@33: 	(incf score)))))
d@33: 
d@33: (defun compare-harmonies-by-beat (bar piece &key (chordset *full-set*) models)
d@33:   (declare (ignore chordset models))
d@33:   (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
d@33: 	 (score (loop for i from 1 to (duration harmonisation)
d@33: 		   count (verify-chord (get-gt-chord-by-beat i harmonisation)
d@33: 				       (get-derived-chord-by-beat i harmonisation)))))
d@33:     (values (= score (duration harmonisation)) score (duration harmonisation))))
d@33: 
d@33: (defun get-gt-chord-by-beat (beat harmonisation)
d@33:   (let ((chords (ground-truth-chords harmonisation)))
d@33:     (do ((gt (reverse chords) (cdr gt)))
d@33: 	((null gt) (car chords))
d@33:       (when (<= (start-beat (car gt)) beat)
d@33: 	(return-from get-gt-chord-by-beat
d@33: 	  (car gt))))))
d@33: 
d@33: (defun get-derived-chord-by-beat (beat harmonisation)
d@33:   (let ((total-beat (+ (1- beat)
d@33: 		       (timepoint harmonisation)))
d@33: 	(chords (derived-chords harmonisation))
d@33: 	(windows (derived-windows harmonisation)))
d@33:     (nth (position-if #'(lambda (x) (and (>= total-beat
d@33: 					     (timepoint x))
d@33: 					 (< total-beat
d@33: 					    (timepoint (cut-off x)))))
d@33: 		      windows)
d@33: 	 chords)))
d@33: 
d@33: (defparameter *param-estimation-numbers*
d@33:   (list (cons :major (make-array '(4 21)))
d@33: 	(cons :minor (make-array '(4 21)))
d@33: 	(cons :dim (make-array '(4 21)))
d@33: 	(cons :aug (make-array '(4 21)))
d@33: 	(cons :sus4 (make-array '(4 21)))
d@33: 	(cons :sus9 (make-array '(4 21)))))
d@33: 
d@33: (defun incf-stats (size type offset piece bar distribution)
d@33:   (let* ((param (cdr (assoc type *param-estimation-numbers*)))
d@33: 	 (chord-notes (main-notes (find type (chords *full-set*) :key #'chord-label)))
d@33: 	 (full-total (reduce #'+ distribution))
d@33: 	 (chord-sum (loop for scale-deg in chord-notes
d@33: 		       sum (aref distribution (mod (+ offset scale-deg) 12)))))
d@33:     (when (= full-total 0)
d@33:       (return-from incf-stats))
d@33:     (when (> chord-sum full-total)
d@33:       (format *standard-output*
d@33: 	      "~%Piece ~D, Bar ~D, distribution ~D, ~D ~D~%"
d@33: 	      piece bar distribution offset type)
d@33:       (error "BRRRRROKEN!"))
d@33:     (when (<= chord-sum 1/4)
d@33:       (format *standard-output*
d@33: 	      "~%Piece ~D, Bar ~D, distribution ~D, ~D ~D~%"
d@33: 	      piece bar distribution offset type)
d@33:       (return-from incf-stats))
d@33:     #+nil (when (<= (aref distribution (mod (+ offset (nth 1 chord-notes)) 12)) 1/40)
d@33: 	    (format *standard-output* "~%******Piece ~D, Bar ~D. distribution ~D, ~D ~D"
d@33: 		    piece bar distribution offset type)
d@33: 	    (return-from incf-stats))
d@33:     (when (<= (aref distribution offset) 1/10)
d@33:       (format *standard-output* "~%Piece ~D, Bar ~D. distribution ~D, ~D ~D"
d@33: 	      piece bar distribution offset type)
d@33:       (return-from incf-stats))
d@33:     (let* ((chord-ratio (/ chord-sum full-total))
d@33: 	   (chord-squared (* chord-ratio chord-ratio))
d@33: 	   (chord-logged (log chord-ratio))
d@33: 	   (non-chord (- 1 chord-ratio))
d@33: 	   (non-chord-squared (* non-chord non-chord))
d@33: 	   (non-chord-logged (log non-chord))
d@33: 	   (d1 (/ (aref distribution (mod (+ offset (nth 0 chord-notes)) 12))
d@33: 		  chord-sum))
d@33: 	   (d1-squared (* d1 d1))
d@33: 	   (d1-logged (log d1))
d@33: 	   (d3 (/ (aref distribution (mod (+ offset (nth 1 chord-notes)) 12))
d@33: 		  chord-sum))
d@33: 	   (d3-squared (* d3 d3))
d@33: 	   (d3-logged (log d3))
d@33: 	   (d5 (/ (aref distribution (mod (+ offset (nth 2 chord-notes)) 12))
d@33: 		  chord-sum))
d@33: 	   (d5-squared (* d5 d5))
d@33: 	   (d5-logged (log d5)))
d@33:       ;; n
d@33:       (incf (aref param size 0))
d@33:       (incf (aref param size 1) chord-ratio)
d@33:       (incf (aref param size 2) chord-squared)
d@33:       (if (= chord-ratio 0)
d@33: 	  (incf (aref param size 4))
d@33: 	  (incf (aref param size 3) chord-logged))
d@33:       (incf (aref param size 5) non-chord)
d@33:       (incf (aref param size 6) non-chord-squared)
d@33:       (if (= non-chord 0)
d@33: 	  (incf (aref param size 8))
d@33: 	  (incf (aref param size 7) non-chord-logged))
d@33:       (incf (aref param size 9) d1)
d@33:       (incf (aref param size 10) d1-squared)
d@33:       (if (= d1 0)
d@33: 	  (incf (aref param size 12))
d@33: 	  (incf (aref param size 11) d1-logged))
d@33:       (incf (aref param size 13) d3)
d@33:       (incf (aref param size 14) d3-squared)
d@33:       (if (= d3 0)
d@33: 	  (incf (aref param size 16))
d@33: 	  (incf (aref param size 15) d3-logged))
d@33:       (incf (aref param size 17) d5)
d@33:       (incf (aref param size 18) d5-squared)
d@33:       (if (= d5 0)
d@33: 	  (incf (aref param size 20))
d@33: 	  (incf (aref param size 19) d5-logged)))))
d@33: 
d@33: (defun parameter-estimation-figures (&key (test-set *test-set*))
d@33:   (let ((size 0) (beat 0)
d@33: 	(c-type) (offset 0)
d@33: 	(harmonisation) (bar 0) (piece 0))
d@33:     (dolist (test test-set)
d@33:       (setf piece (car test)
d@33: 	    bar (cdr test)
d@33: 	    harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
d@33:       (do ((windows (ground-truth-chords harmonisation) (cdr windows))
d@33: 	   (window-sizes (ground-truth-window-sizes harmonisation) (cdr window-sizes))
d@33: 	   (window-beats (ground-truth-window-beats harmonisation) (cdr window-beats)))
d@33: 	  ((not windows))
d@33: 	(setf size (1- (first window-sizes))
d@33: 	      c-type (chord-from-gt (chord-type (first windows)))
d@33: 	      offset (pitch-class-from-gt (slot-value (first windows) 'root))
d@33: 	      beat (+ (1- (first window-beats)) (timepoint harmonisation)))
d@33: 	(incf-stats size c-type offset piece bar
d@33: 		    (pitch-class-distribution (make-anchored-period beat (1+ size))
d@33: 					      (%composition harmonisation)))))))
d@33: 
d@33: 
d@33: (defun write-numbers-to-file (pathname)
d@33:   (with-open-file (s pathname :direction :output :if-exists :supersede)
d@33:     (dolist (acns *param-estimation-numbers*)
d@33:       (let ((c-type (car acns)) (data (cdr acns)))
d@33: 	(dotimes (i 4)
d@33: 	  (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~%"
d@33: 		  c-type (1+ i)
d@33: 		  (aref data i 0) #\Tab
d@33: 		  (float (aref data i 1)) #\Tab (float (aref data i 2)) #\Tab
d@33: 		  (float (aref data i 3)) #\Tab (aref data i 4) #\Tab
d@33: 		  (float (aref data i 5)) #\Tab (float (aref data i 6)) #\Tab
d@33: 		  (float (aref data i 7)) #\Tab (aref data i 8) #\Tab
d@33: 		  (float (aref data i 9)) #\Tab (float (aref data i 10)) #\Tab
d@33: 		  (float (aref data i 11)) #\Tab (aref data i 12) #\Tab
d@33: 		  (float (aref data i 13)) #\Tab (float (aref data i 14)) #\Tab
d@33: 		  (float (aref data i 15)) #\Tab (aref data i 16) #\Tab
d@33: 		  (float (aref data i 17)) #\Tab (float (aref data i 18)) #\Tab
d@33: 		  (float (aref data i 19)) #\Tab (aref data i 20)))))))
d@33: 
d@33: (defun write-numbers-to-file-2 (pathname)
d@33:   (with-open-file (s pathname :direction :output :if-exists :supersede)
d@33:     (dolist (acns *param-estimation-numbers*)
d@33:       (let ((c-type (car acns)) (data (cdr acns)))
d@33: 	(dotimes (i 4)
d@33: 	  (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)~%"
d@33: 		  c-type (1+ i)
d@33: 		  ;; chord / non-chord (x, x^2, log(x), left out, n)
d@33: 		  (float (aref data i 1)) (float (aref data i 5))
d@33: 		  (float (aref data i 2)) (float (aref data i 6))
d@33: 		  (float (aref data i 3)) (float (aref data i 7))
d@33: 		  (aref data i 4) (aref data i 8)	       
d@33: 		  (aref data i 0)
d@33: 		  ;; 1 / 3 / 5 (x, x^2, log(x), left out, n)
d@33: 		  (float (aref data i 9)) (float (aref data i 13)) (float (aref data i 17))
d@33: 		  (float (aref data i 10)) (float (aref data i 14)) (float (aref data i 18))
d@33: 		  (float (aref data i 11)) (float (aref data i 15)) (float (aref data i 19))
d@33: 		  (aref data i 12) (aref data i 16) (aref data i 20)
d@33: 		  (aref data i 0)))))))
d@33:   
d@33: (defun test-paths (&key (test-set *test-set*))
d@33:   (let ((bars 0) (grand-score 0) (grand-total 0))
d@33:     (loop for test in test-set
d@33:        do (when (goodness-test (cdr test) (car test))
d@33: 	    (multiple-value-bind (match score total)
d@33: 		(compare-paths (cdr test) (car test))	   
d@33: 	      (when match (incf bars))
d@33: 	      (incf grand-score score)
d@33: 	      (incf grand-total total))))
d@33:     (values bars grand-score grand-total)))
d@33: 
d@33: (defparameter *ignored* nil)
d@33: (defun goodness-test (bar piece)
d@33:   ;; exclusions bin
d@33:   (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
d@33: 	 (sounding-sum (reduce #'+ (pitch-class-distribution harmonisation (%composition harmonisation))))
d@33: 	 (pcd))
d@33:     ;; Too little sounding
d@33:     (unless (> sounding-sum 1/4)
d@33:       (push (list bar piece) *ignored*)
d@33:       (return-from goodness-test nil))
d@33:     ;; per gt window tests
d@33:     (do ((window-beats (ground-truth-window-beats harmonisation) (cdr window-beats))
d@33: 	 (window-sizes (ground-truth-window-sizes harmonisation) (cdr window-sizes))
d@33: 	 (gt-chords (ground-truth-chords harmonisation) (cdr gt-chords)))
d@33: 	((null window-beats) t)
d@33:       (setf pcd (pitch-class-distribution (make-anchored-period (+ (timepoint harmonisation)
d@33: 								   (1- (first window-beats)))
d@33: 								(first window-sizes))
d@33: 					  (%composition harmonisation)))
d@33:       (unless (and (> (reduce #'+ pcd) 1)
d@33: 		   (> (aref pcd (pitch-class-from-gt (slot-value (first gt-chords) 'root)))
d@33: 		      1/16))
d@33: 	(push (list bar piece) *ignored*)
d@33: 	(return-from goodness-test nil)))))
d@33: 
d@33: (defun test-harmonies (&key (test-set *test-set*))
d@33:   ;; FIXME: whole bars only at the mo!
d@33:   (loop for test in test-set
d@33:      count (when (goodness-test (cdr test) (car test))
d@33: 	     (compare-harmonies-with-gt-windows (cdr test) (car test)))))
d@33: 
d@33: (defun test-paths-and-chords (&key (test-set *test-set*))
d@33:   (let ((bars 0) (grand-score 0) (grand-total 0))
d@33:     (loop for test in test-set
d@33:        do (when (goodness-test (cdr test) (car test))
d@33: 	    (multiple-value-bind (match score total)
d@33: 		(compare-paths-and-harmonies (cdr test) (car test))
d@33: 	      (when match (incf bars))
d@33: 	      (incf grand-score score)
d@33: 	      (incf grand-total total))))
d@33:     (values bars grand-score grand-total)))
d@33: 
d@33: (defun test-harmonies-by-window (&key (test-set *test-set*))
d@33:   (let ((bars 0) (grand-score 0) (grand-total 0))
d@33:     (loop for test in test-set
d@33:        do (when (goodness-test (cdr test) (car test))
d@33: 	    (multiple-value-bind (match score total)
d@33: 		(compare-harmonies-with-gt-windows (cdr test) (car test))
d@33: 	      (when match (incf bars))
d@33: 	      (incf grand-score score)
d@33: 	      (incf grand-total total))))
d@33:     (values bars grand-score grand-total)))
d@33: 
d@33: (defun test-harmonies-by-beat (&key (test-set *test-set*))
d@33:   (let ((bars 0) (grand-score 0) (grand-total 0))
d@33:     (loop for test in test-set
d@33:        do (when (goodness-test (cdr test) (car test))
d@33: 	    (multiple-value-bind (match score total)
d@33: 		(compare-harmonies-by-beat (cdr test) (car test))
d@33: 	      (when match (incf bars))
d@33: 	      (incf grand-score score)
d@33: 	      (incf grand-total total))))
d@33:     (values bars grand-score grand-total)))
d@33: 
d@33: (defgeneric whole-bar-period (bar-number composition))
d@33: (defmethod whole-bar-period (bar-number (composition geerdes-midi-composition))
d@33:   (multiple-value-bind (beat-no timesig)
d@33:       (bar-number-to-beats bar-number composition)
d@33:     (make-anchored-period (timepoint beat-no) (crotchets-in-a-bar timesig))))
d@33: 
d@33: (defgeneric bar-number-to-beats (bar-number composition))
d@33: (defmethod bar-number-to-beats (bar-number (composition geerdes-midi-composition))
d@33:   (do* ((time-sig-list (time-signatures composition) (cdr time-sig-list))
d@33: 	(current-sig (car time-sig-list) (car time-sig-list))
d@33: 	(beats-per-bar (make-floating-period (crotchets-in-a-bar current-sig))
d@33: 		       (make-floating-period (crotchets-in-a-bar current-sig)))
d@33: 	(bars-left bar-number))
d@33:        ((time>= (cut-off current-sig)
d@33: 		(time+ (onset current-sig)
d@33: 		       (duration* beats-per-bar bars-left)))
d@33: 	(values (time+ (onset current-sig)
d@33: 		       (duration* beats-per-bar bars-left))
d@33: 		current-sig))
d@33:     (decf bars-left (duration/ current-sig beats-per-bar))))
d@33: 
d@33: (defun samechordp (root1 label1 root2 label2)
d@33:   (or (and (= root1 root2)
d@33: 	   (eq label1 label2))
d@33:       (and (eq label1 :sus4)
d@33: 	   (eq label2 :sus9)
d@33: 	   (= root2 (mod (+ root1 5) 12)))
d@33:       (and (eq label2 :sus4)
d@33: 	   (eq label1 :sus9)
d@33: 	   (= root1 (mod (+ root2 5) 12)))))
d@33: 
d@33: (defun chord-from-gt (string)
d@33:   (cdr (assoc string '(("maj" . :major) ("min" . :minor)
d@33: 		       ("dim" . :dim) ("aug" . :aug)
d@33: 		       ("sus4" . :sus4) ("sus9" . :sus9))
d@33: 	      :test #'equal)))
d@33: 
d@33: (defun pitch-class-from-gt (string)
d@33:   (position-if #'(lambda (x) (string-equal x string))
d@33: 	       *dm-note-names*))
d@33: 
d@33: (defun piece-chord-list (id)
d@33:   (remove-if #'(lambda (x)
d@33: 		 (not (= (cat_id x) id)))
d@33: 	     (all-chords)))
d@33: 
d@33: (defun get-gt-bar-chords (piece bar)
d@33:   (let ((bar-beats (* 4 bar))
d@33: 	(chord-list (sort (piece-chord-list piece)
d@33: 			  #'chord-time->)))
d@33:     (loop for i from bar-beats to (+ 3 bar-beats)
d@33:        collect (gt-chord-to-list (get-applicable-chord i chord-list)))))
d@33: 		 
d@33: (defun gt-chord-to-list (chord)
d@33:   (list (pitch-class-from-gt (slot-value chord 'root))
d@33: 	(chord-from-gt (chord-type chord))))
d@33: 
d@33: (defun explore-parameters (&key (alpha-scale '(0.4 3)) (beta '(4 14)))
d@33:   (let* ((original-alpha *alpha*)
d@33: 	 (original-betas *betas*)
d@33: 	 (results (loop for i from (first alpha-scale) to (second alpha-scale) by 0.3
d@33: 		     collect (progn
d@33: 			       (setf *alpha* (map 'vector
d@33: 						  #'(lambda (x)
d@33: 						      (* x i))
d@33: 						  original-alpha))
d@33: 			       (print *alpha*)
d@33: 			       (list i (explore-betas beta))))))
d@33:     (setf *alpha* original-alpha
d@33: 	  *betas* original-betas)
d@33:     results))
d@33: 
d@33: (defun explore-betas (beta)
d@33:   (let* ((b1 (first beta))
d@33: 	 (bn (second beta))
d@33: 	 (n (- bn b1)))
d@33:     (assert (equal (array-dimensions *results*)
d@33: 		   (list n n n n 4)))
d@33:     (loop for semi from 0 to (1- n) by 2
d@33:        do (progn
d@33: 	    (format t "|~D |" (+ semi b1))
d@33: 	    (loop for dotted-minim from 0 to (1- n) by 2
d@33: 	     do (loop for minim from 0 to (1- n) by 2
d@33: 		   do (loop for crotchet from 0 to (1- n) by 2
d@33: 			 do (progn
d@33: 			      (setf *harmonic-evaluation-period-cache* nil
d@33: 				    *betas* (list (cons 1 (+ b1 semi))
d@33: 						  (cons 3/4 (+ b1 dotted-minim))
d@33: 						  (cons 1/2 (+ b1 minim))
d@33: 						  (cons 1/4 (+ b1 crotchet))))
d@33: 			      (unless (> (aref *results* semi dotted-minim minim crotchet 0)
d@33: 					 0)
d@33: 				(multiple-value-bind (dull score total)
d@33: 				    (test-paths)
d@33: 				  (declare (ignore dull))
d@33: 				  (setf (aref *results* semi dotted-minim minim crotchet 0)
d@33: 					(/ score total))))
d@33: 			      (unless (> (aref *results* semi dotted-minim minim crotchet 1)
d@33: 					 0)
d@33: 				(multiple-value-bind (dull score total)
d@33: 				    (test-paths-and-chords)
d@33: 				  (declare (ignore dull))
d@33: 				  (setf (aref *results* semi dotted-minim minim crotchet 1)
d@33: 					(/ score total))))
d@33: 			      (unless (> (aref *results* semi dotted-minim minim crotchet 2)
d@33: 					 0)
d@33: 				(multiple-value-bind (dull score total)
d@33: 				    (test-harmonies-by-window)
d@33: 				  (declare (ignore dull))
d@33: 				  (setf (aref *results* semi dotted-minim minim crotchet 2)
d@33: 					(/ score total))))
d@33: 			      (unless (> (aref *results* semi dotted-minim minim crotchet 3)
d@33: 					 0)
d@33: 				(multiple-value-bind (dull score total)
d@33: 				    (test-harmonies-by-beat)
d@33: 				  (declare (ignore dull))
d@33: 				  (setf (aref *results* semi dotted-minim minim crotchet 3)
d@33: 					(/ score total))))))))))
d@33:     *results*))
d@33: 
d@33: (defparameter *results* (make-array '(10 10 10 10 4) :element-type 'ratio))
d@33: 
d@33: (defun explore-parameters-to-file (pathname &key (alpha-scale '(0.4 3)) (beta '(4 14)))
d@33:   (with-open-file (stream pathname :direction :output :if-exists :supersede)
d@33:     (let* ((original-alpha *alpha*)
d@33: 	   (original-betas *betas*))
d@33:       (loop for i from (first alpha-scale) to (second alpha-scale) by 0.3
d@33: 	 do (progn
d@33: 	      (setf *alpha* (map 'vector
d@33: 				 #'(lambda (x)
d@33: 				     (* x i))
d@33: 				 original-alpha))
d@33: 	      (print *alpha*)
d@33: 	      (explore-betas-to-stream beta stream)))
d@33:       (setf *alpha* original-alpha
d@33: 	    *betas* original-betas))))
d@33: 
d@33: (defun explore-betas-to-stream (beta stream)
d@33:   (let* ((b1 (first beta))
d@33: 	 (bn (second beta))
d@33: 	 (n (- bn b1)) (tb #\tab))
d@33:     (loop for semi from 0 to (1- n) by 2
d@33:        do (progn
d@33: 	    (format *standard-output* "|~D |" (+ semi b1))
d@33: 	    (finish-output)
d@33: 	    (loop for dotted-minim from 0 to (1- n) by 2
d@33: 	     do (loop for minim from 0 to (1- n) by 2
d@33: 		   do (loop for crotchet from 0 to (1- n) by 2
d@33: 			 do (progn
d@33: 			      (format stream "~D~C~D~C~D~C~D~C~D~C"
d@33: 				      (aref *alpha* 0) tb
d@33: 				      (+ b1 semi) tb
d@33: 				      (+ b1 dotted-minim) tb
d@33: 				      (+ b1 minim) tb
d@33: 				      (+ b1 crotchet) tb)
d@33: 			      (setf *harmonic-evaluation-period-cache* nil
d@33: 				    *betas* (list (cons 1 (+ b1 semi))
d@33: 						  (cons 3/4 (+ b1 dotted-minim))
d@33: 						  (cons 1/2 (+ b1 minim))
d@33: 						  (cons 1/4 (+ b1 crotchet))))
d@33: 			      (multiple-value-bind (dull score total)
d@33: 				  (test-paths)
d@33: 				(declare (ignore dull))
d@33: 				(format stream "~D~C" (/ score total) tb))
d@33: 			      (multiple-value-bind (dull score total)
d@33: 				  (test-paths-and-chords)
d@33: 				(declare (ignore dull))
d@33: 				(format stream "~D~C" (/ score total) tb))
d@33: 			      (multiple-value-bind (dull score total)
d@33: 				  (test-harmonies-by-window)
d@33: 				(declare (ignore dull))
d@33: 				(format stream "~D~C" (/ score total) tb))
d@33: 			      (multiple-value-bind (dull score total)
d@33: 				  (test-harmonies-by-beat)
d@33: 				(declare (ignore dull))
d@33: 				(format stream "~D~C~%" (/ score total) tb))
d@33: 			      (finish-output stream)))))))))
d@33: