|
d@33
|
1 ;; Stuff to compare: path (per model); correct window (per model); correct window|bass; correct window|bass
|
|
d@33
|
2
|
|
d@33
|
3 (in-package #:amuse-harmony)
|
|
d@33
|
4
|
|
d@33
|
5 (defparameter *test-pieces* '())
|
|
d@33
|
6 (defparameter *test-set* '())
|
|
d@33
|
7 (defparameter *dm-note-names* '("c" "c+" "d" "e-" "e" "f" "f+" "g" "g+" "a" "b-" "b"))
|
|
d@33
|
8
|
|
d@33
|
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
d@33
|
10 ;;
|
|
d@33
|
11 ;; Ground-truth data types and functions
|
|
d@33
|
12 ;;
|
|
d@33
|
13
|
|
d@33
|
14 (clsql:def-view-class truth-chord ()
|
|
d@33
|
15 ((cat_id
|
|
d@33
|
16 :type integer
|
|
d@33
|
17 :accessor cat_id)
|
|
d@33
|
18 (onset_bar
|
|
d@33
|
19 :type integer
|
|
d@33
|
20 :accessor start-bar)
|
|
d@33
|
21 (onset_beat
|
|
d@33
|
22 :type integer
|
|
d@33
|
23 :accessor start-beat)
|
|
d@33
|
24 (root
|
|
d@33
|
25 :type string)
|
|
d@33
|
26 (bass
|
|
d@33
|
27 :type string)
|
|
d@33
|
28 (chord-type
|
|
d@33
|
29 :type string
|
|
d@33
|
30 :accessor chord-type)
|
|
d@33
|
31 (file
|
|
d@33
|
32 :accessor harmony-file
|
|
d@33
|
33 :db-kind :join
|
|
d@33
|
34 :db-info (:join-class file
|
|
d@33
|
35 :home-key cat_id
|
|
d@33
|
36 :foreign-key cat_id
|
|
d@33
|
37 :set nil)))
|
|
d@33
|
38 (:base-table geerdes_harmony))
|
|
d@33
|
39
|
|
d@33
|
40 (defun all-chords ()
|
|
d@33
|
41 #.(clsql:locally-enable-sql-reader-syntax)
|
|
d@33
|
42 (map 'list #'car (clsql:select 'truth-chord :where 1))
|
|
d@33
|
43 #.(clsql:restore-sql-reader-syntax-state))
|
|
d@33
|
44
|
|
d@33
|
45 (defun list-harmonised-pieces ()
|
|
d@33
|
46 (remove-if #'(lambda (x) (member x '(886 5205 10586 3473 6993)))
|
|
d@33
|
47 (remove-duplicates (map 'list
|
|
d@33
|
48 #'cat_id
|
|
d@33
|
49 (all-chords)))))
|
|
d@33
|
50
|
|
d@33
|
51 (defun harmonised-bars (id)
|
|
d@33
|
52 ;; List bars which have harmonies from piece with cat_id=id
|
|
d@33
|
53 (let* ((piece-chords (piece-chord-list id)))
|
|
d@33
|
54 (when piece-chords
|
|
d@33
|
55 (let* ((chord-starts (map 'list #'start-bar piece-chords))
|
|
d@33
|
56 (bar-max (1+ (apply #'max chord-starts)))
|
|
d@33
|
57 (bar-min (apply #'min chord-starts))
|
|
d@33
|
58 (bar-numbers))
|
|
d@33
|
59 (setf piece-chords (sort piece-chords #'chord-time->))
|
|
d@33
|
60 (do ((bar bar-min (1+ bar)))
|
|
d@33
|
61 ((= bar bar-max) bar-numbers
|
|
d@33
|
62 #+nil (make-array (length bar-numbers)
|
|
d@33
|
63 :initial-contents (reverse bar-numbers)))
|
|
d@33
|
64 (let ((harmony (get-applicable-chord (* 4 bar) piece-chords)))
|
|
d@33
|
65 (when (and harmony
|
|
d@33
|
66 (> (length (chord-type harmony)) 0))
|
|
d@33
|
67 (push bar bar-numbers))))))))
|
|
d@33
|
68
|
|
d@33
|
69 (defun get-applicable-chord (beats chords &key (pre-sorted t))
|
|
d@33
|
70 ;; Return the chord that would be sounding at a given point in
|
|
d@33
|
71 ;; time. If this is being applied many times, it makes sense to sort
|
|
d@33
|
72 ;; the data before providing it, hence the &key argument.
|
|
d@33
|
73 (unless pre-sorted
|
|
d@33
|
74 (setf chords (sort chords #'chord-time->)))
|
|
d@33
|
75 (find-if #'(lambda (x) (or (< (start-bar x)
|
|
d@33
|
76 (floor beats 4))
|
|
d@33
|
77 (and (= (start-bar x)
|
|
d@33
|
78 (floor beats 4))
|
|
d@33
|
79 (<= (start-beat x)
|
|
d@33
|
80 (1+ (mod beats 4))))))
|
|
d@33
|
81 chords))
|
|
d@33
|
82
|
|
d@33
|
83 (defun chord-time-> (chord1 chord2)
|
|
d@33
|
84 (or (> (start-bar chord1)
|
|
d@33
|
85 (start-bar chord2))
|
|
d@33
|
86 (and (= (start-bar chord1)
|
|
d@33
|
87 (start-bar chord2))
|
|
d@33
|
88 (> (start-beat chord1)
|
|
d@33
|
89 (start-beat chord2)))))
|
|
d@33
|
90
|
|
d@33
|
91 (defun chord-time-< (chord1 chord2)
|
|
d@33
|
92 (or (< (start-bar chord1)
|
|
d@33
|
93 (start-bar chord2))
|
|
d@33
|
94 (and (= (start-bar chord1)
|
|
d@33
|
95 (start-bar chord2))
|
|
d@33
|
96 (< (start-beat chord1)
|
|
d@33
|
97 (start-beat chord2)))))
|
|
d@33
|
98
|
|
d@33
|
99 (defun harmonised-pieces-bars-alist ()
|
|
d@33
|
100 (let ((harmonised))
|
|
d@33
|
101 (dolist (piece (list-harmonised-pieces) harmonised)
|
|
d@33
|
102 (setf harmonised (acons piece (harmonised-bars piece) harmonised)))))
|
|
d@33
|
103
|
|
d@33
|
104 (defun all-bars ()
|
|
d@33
|
105 (let ((harmonised))
|
|
d@33
|
106 (dolist (piece (list-harmonised-pieces) harmonised)
|
|
d@33
|
107 (dolist (bar (harmonised-bars piece))
|
|
d@33
|
108 (push (cons piece bar) harmonised)))))
|
|
d@33
|
109
|
|
d@33
|
110 (defun random-bars (target)
|
|
d@33
|
111 (let* ((selection) (pieces-bars (make-array 1 :adjustable T :fill-pointer T)))
|
|
d@33
|
112 (dolist (piece (list-harmonised-pieces))
|
|
d@33
|
113 (loop for bar in (harmonised-bars piece)
|
|
d@33
|
114 do (vector-push-extend (cons piece bar) pieces-bars)))
|
|
d@33
|
115 (loop for i from 0 to (1- target)
|
|
d@33
|
116 do (progn
|
|
d@33
|
117 (rotatef (aref pieces-bars i)
|
|
d@33
|
118 (aref pieces-bars
|
|
d@33
|
119 (+ i (random (- (1- (length pieces-bars))
|
|
d@33
|
120 i)))))
|
|
d@33
|
121 (push (aref pieces-bars i) selection)))
|
|
d@33
|
122 selection))
|
|
d@33
|
123
|
|
d@33
|
124 (defun write-piece-bars (list filename)
|
|
d@33
|
125 (with-open-file (stream filename :direction :output :if-exists :supersede)
|
|
d@33
|
126 (dolist (bar list)
|
|
d@33
|
127 (format stream "~A~C~A~%" (car bar) #\Tab (cdr bar)))))
|
|
d@33
|
128
|
|
d@33
|
129 (defun read-piece-bars (filename)
|
|
d@33
|
130 (let ((bars))
|
|
d@33
|
131 (with-open-file (stream filename)
|
|
d@33
|
132 (do ((line (read-line stream nil nil) (read-line stream nil nil)))
|
|
d@33
|
133 ((null line) bars)
|
|
d@33
|
134 (let* ((s (make-string-input-stream line))
|
|
d@33
|
135 (piece (read s))
|
|
d@33
|
136 (bar (read s)))
|
|
d@33
|
137 (push (cons piece bar) bars))))))
|
|
d@33
|
138
|
|
d@33
|
139 (defun get-window-sizes (piece bar &optional (odd-divisions nil))
|
|
d@33
|
140 (let ((bar-chords (sort (remove-if #'(lambda (x) (or (not (= (cat_id x) piece))
|
|
d@33
|
141 (not (= (start-bar x) bar))))
|
|
d@33
|
142 (all-chords))
|
|
d@33
|
143 #'chord-time-<)))
|
|
d@33
|
144 (if odd-divisions
|
|
d@33
|
145 (get-window-sizes-2 bar-chords)
|
|
d@33
|
146 (get-window-sizes-1 bar-chords))))
|
|
d@33
|
147
|
|
d@33
|
148 (defun get-window-sizes-2 (bar-chords)
|
|
d@33
|
149 (let ((path) (prev-chord))
|
|
d@33
|
150 (dolist (beat-chord bar-chords)
|
|
d@33
|
151 (cond
|
|
d@33
|
152 (prev-chord
|
|
d@33
|
153 (push (- (start-beat beat-chord)
|
|
d@33
|
154 (start-beat prev-chord))
|
|
d@33
|
155 path))
|
|
d@33
|
156 ((and (not prev-chord)
|
|
d@33
|
157 (> (start-beat beat-chord) 1))
|
|
d@33
|
158 (push (- (start-beat beat-chord) 1)
|
|
d@33
|
159 path)))
|
|
d@33
|
160 (setf prev-chord beat-chord))
|
|
d@33
|
161 (if prev-chord
|
|
d@33
|
162 (push (- 5 (start-beat prev-chord))
|
|
d@33
|
163 path)
|
|
d@33
|
164 (setf path '(4)))
|
|
d@33
|
165 (reverse path)))
|
|
d@33
|
166
|
|
d@33
|
167 (defun get-window-sizes-1 (bar-chords)
|
|
d@33
|
168 (let ((path) (prev-chord))
|
|
d@33
|
169 (dolist (beat-chord bar-chords)
|
|
d@33
|
170 (cond
|
|
d@33
|
171 ((and (not prev-chord)
|
|
d@33
|
172 (= (start-beat beat-chord) 4))
|
|
d@33
|
173 ;; Three beats of preceding chord or no chord
|
|
d@33
|
174 (return-from get-window-sizes-1 '(2 1 1)))
|
|
d@33
|
175 ((and (not prev-chord)
|
|
d@33
|
176 (> (start-beat beat-chord) 1))
|
|
d@33
|
177 ;; not the first chord of bar - just the first to sound
|
|
d@33
|
178 (push (1- (start-beat beat-chord)) path))
|
|
d@33
|
179 ((and (= (start-beat beat-chord) 4)
|
|
d@33
|
180 (< (start-beat prev-chord) 3))
|
|
d@33
|
181 ;; Last chord of bar, but its predecessor spans half-bar
|
|
d@33
|
182 ;; break.
|
|
d@33
|
183 (return-from get-window-sizes-1 (reverse (concatenate 'list
|
|
d@33
|
184 (list 1 1 (- 3 (start-beat prev-chord)))
|
|
d@33
|
185 path))))
|
|
d@33
|
186 ((= (start-beat beat-chord) 4)
|
|
d@33
|
187 ;; last chord of bar
|
|
d@33
|
188 (return-from get-window-sizes-1 (reverse (concatenate 'list
|
|
d@33
|
189 (list 1 1)
|
|
d@33
|
190 path))))
|
|
d@33
|
191 (prev-chord
|
|
d@33
|
192 (push (- (start-beat beat-chord) (start-beat prev-chord))
|
|
d@33
|
193 path)))
|
|
d@33
|
194 (setf prev-chord beat-chord))
|
|
d@33
|
195 (if prev-chord
|
|
d@33
|
196 (if (= (start-beat prev-chord) 2)
|
|
d@33
|
197 '(1 1 2)
|
|
d@33
|
198 (reverse (cons (- 5 (start-beat prev-chord)) path)))
|
|
d@33
|
199 '(4))))
|
|
d@33
|
200
|
|
d@33
|
201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
d@33
|
202
|
|
d@33
|
203 (defun get-test-piece (cat-id)
|
|
d@33
|
204 (unless (assoc cat-id *test-pieces*)
|
|
d@33
|
205 (setf *test-pieces* (acons cat-id
|
|
d@33
|
206 (get-composition (make-geerdes-cat-identifier cat-id))
|
|
d@33
|
207 *test-pieces*)))
|
|
d@33
|
208 (cdr (assoc cat-id *test-pieces*)))
|
|
d@33
|
209
|
|
d@33
|
210 (in-package "AMUSE-GEERDES")
|
|
d@33
|
211
|
|
d@33
|
212 (defclass harmonic-evaluation-period (anchored-period)
|
|
d@33
|
213 ((cat-id :accessor %cat-id
|
|
d@33
|
214 :initarg :cat-id)
|
|
d@33
|
215 (file-id :accessor %file-id
|
|
d@33
|
216 :initarg :file-id)
|
|
d@33
|
217 (composition :accessor %composition
|
|
d@33
|
218 :initarg :composition)
|
|
d@33
|
219 (bar-number :accessor %bar-number
|
|
d@33
|
220 :initarg :bar-number)
|
|
d@33
|
221 (composition-bar-number :accessor %c-bar-number
|
|
d@33
|
222 :initarg :comp-bar-number)
|
|
d@33
|
223 (ground-truth-chords :accessor %gt-chords
|
|
d@33
|
224 :initarg :gt-chords
|
|
d@33
|
225 :initform nil)
|
|
d@33
|
226 (derived-windows :accessor %d-windows
|
|
d@33
|
227 :initarg :d-windows
|
|
d@33
|
228 :initform nil)
|
|
d@33
|
229 (derived-chords :accessor %d-chords
|
|
d@33
|
230 :initarg :d-chords
|
|
d@33
|
231 :initform nil)
|
|
d@33
|
232 (derived-likelihoods :accessor %d-likelihoods
|
|
d@33
|
233 :initarg :d-likelihoods
|
|
d@33
|
234 :initform nil)))
|
|
d@33
|
235
|
|
d@33
|
236 (defun reset-harmonisation (harmonisation)
|
|
d@33
|
237 (setf (%d-chords harmonisation) nil
|
|
d@33
|
238 (%d-windows harmonisation) nil
|
|
d@33
|
239 (%d-likelihoods harmonisation) nil))
|
|
d@33
|
240
|
|
d@33
|
241 (defun derived-likelihoods (harmonisation &key (models *default-models*)
|
|
d@33
|
242 (chordset *full-set*))
|
|
d@33
|
243 (if (%d-likelihoods harmonisation)
|
|
d@33
|
244 (%d-likelihoods harmonisation)
|
|
d@33
|
245 (let* ((possible-window-combinations (make-metrical-divisions harmonisation
|
|
d@33
|
246 (%composition harmonisation)))
|
|
d@33
|
247 (possible-windows (remove-duplicates (apply #'nconc possible-window-combinations)
|
|
d@33
|
248 :test #'period=)))
|
|
d@33
|
249 (setf (%d-likelihoods harmonisation)
|
|
d@33
|
250 (loop for window in possible-windows
|
|
d@33
|
251 collect (cons window
|
|
d@33
|
252 (get-chord-likelihoods window
|
|
d@33
|
253 (%composition harmonisation)
|
|
d@33
|
254 models chordset)))))))
|
|
d@33
|
255 (defun ground-truth-window-sizes (harmonisation)
|
|
d@33
|
256 (let* ((chords (ground-truth-chords harmonisation))
|
|
d@33
|
257 (bar-number (%bar-number harmonisation))
|
|
d@33
|
258 (beats (nconc (map 'list #'(lambda (x)
|
|
d@33
|
259 (if (= (start-bar x)
|
|
d@33
|
260 bar-number)
|
|
d@33
|
261 (start-beat x)
|
|
d@33
|
262 1))
|
|
d@33
|
263 chords)
|
|
d@33
|
264 (list (1+ (duration harmonisation))))))
|
|
d@33
|
265 (map 'list #'- (cdr beats) beats)))
|
|
d@33
|
266
|
|
d@33
|
267
|
|
d@33
|
268
|
|
d@33
|
269 (defun ground-truth-chords (harmonisation)
|
|
d@33
|
270 (if (%gt-chords harmonisation)
|
|
d@33
|
271 (%gt-chords harmonisation)
|
|
d@33
|
272 (let ((piece-chords (sort (piece-chord-list (%cat-id harmonisation))
|
|
d@33
|
273 #'chord-time->)) (gt-chords))
|
|
d@33
|
274 (setf (%gt-chords harmonisation)
|
|
d@33
|
275 (dolist (pc piece-chords gt-chords)
|
|
d@33
|
276 (cond
|
|
d@33
|
277 ((= (start-bar pc) (%bar-number harmonisation))
|
|
d@33
|
278 (push pc gt-chords)
|
|
d@33
|
279 (when (= (start-beat pc) 1)
|
|
d@33
|
280 (return gt-chords)))
|
|
d@33
|
281 ((< (start-bar pc) (%bar-number harmonisation))
|
|
d@33
|
282 (return (cons pc gt-chords)))))))))
|
|
d@33
|
283
|
|
d@33
|
284 (defun derived-window-sizes (harmonisation &key (chordset *full-set*) models)
|
|
d@33
|
285 (declare (ignore models))
|
|
d@33
|
286 (unless (%d-windows harmonisation)
|
|
d@33
|
287 (let ((level (best-level harmonisation (%composition harmonisation)
|
|
d@33
|
288 :chordset chordset)))
|
|
d@33
|
289 (setf (%d-chords harmonisation)
|
|
d@33
|
290 (loop for likelihoods in (second level)
|
|
d@33
|
291 collect (likelihood-chord
|
|
d@33
|
292 (car (best-n-likelihoods 1 likelihoods))))
|
|
d@33
|
293 (%d-windows harmonisation) (first level))))
|
|
d@33
|
294 (map 'list #'duration (%d-windows harmonisation)))
|
|
d@33
|
295
|
|
d@33
|
296 (defun derived-windows (harmonisation &key (chordset *full-set*) models)
|
|
d@33
|
297 (declare (ignore models))
|
|
d@33
|
298 (unless (%d-windows harmonisation)
|
|
d@33
|
299 (let ((level (best-level harmonisation (%composition harmonisation)
|
|
d@33
|
300 :chordset chordset)))
|
|
d@33
|
301 (setf (%d-chords harmonisation)
|
|
d@33
|
302 (loop for likelihoods in (second level)
|
|
d@33
|
303 collect (likelihood-chord
|
|
d@33
|
304 (car (best-n-likelihoods 1 likelihoods))))
|
|
d@33
|
305 (%d-windows harmonisation) (first level))))
|
|
d@33
|
306 (%d-windows harmonisation))
|
|
d@33
|
307
|
|
d@33
|
308 (defun derived-chords (harmonisation &key (chordset *full-set*) models)
|
|
d@33
|
309 (declare (ignore models))
|
|
d@33
|
310 (cond
|
|
d@33
|
311 ((%d-chords harmonisation)
|
|
d@33
|
312 (%d-chords harmonisation))
|
|
d@33
|
313 (t (let ((level (best-level harmonisation (%composition harmonisation)
|
|
d@33
|
314 :chordset chordset)))
|
|
d@33
|
315 (setf (%d-windows harmonisation) (first level)
|
|
d@33
|
316 (%d-chords harmonisation)
|
|
d@33
|
317 (loop for likelihoods in (second level)
|
|
d@33
|
318 collect (likelihood-chord (car (best-n-likelihoods 1 likelihoods)))))))))
|
|
d@33
|
319
|
|
d@33
|
320 (defparameter *harmonic-evaluation-period-cache* nil)
|
|
d@33
|
321 (defun get-harmonic-evaluation-period (bar-number &key cat-id file-id composition)
|
|
d@33
|
322 (cond
|
|
d@33
|
323 (cat-id (get-harmonic-evaluation-period-by-cat-id bar-number cat-id))
|
|
d@33
|
324 (file-id (get-harmonic-evaluation-period-by-file-id bar-number file-id))
|
|
d@33
|
325 (composition (get-harmonic-evaluation-period-by-composition bar-number composition))))
|
|
d@33
|
326
|
|
d@33
|
327 (defun get-harmonic-evaluation-period-by-cat-id (bar-number cat-id)
|
|
d@33
|
328 (let ((harmonisation (find-if #'(lambda (x)
|
|
d@33
|
329 (and (= (%cat-id x)
|
|
d@33
|
330 cat-id)
|
|
d@33
|
331 (= (%bar-number x)
|
|
d@33
|
332 bar-number)))
|
|
d@33
|
333 *harmonic-evaluation-period-cache*)))
|
|
d@33
|
334 (unless harmonisation
|
|
d@33
|
335 (setf harmonisation
|
|
d@33
|
336 (make-harmonic-evaluation-period bar-number
|
|
d@33
|
337 (get-test-piece cat-id)))
|
|
d@33
|
338 (push harmonisation *harmonic-evaluation-period-cache*))
|
|
d@33
|
339 harmonisation))
|
|
d@33
|
340
|
|
d@33
|
341 (defun get-harmonic-evaluation-period-by-file-id (bar-number file-id)
|
|
d@33
|
342 (let ((harmonisation (find-if #'(lambda (x)
|
|
d@33
|
343 (and (= (%file-id x)
|
|
d@33
|
344 file-id)
|
|
d@33
|
345 (= (%bar-number x)
|
|
d@33
|
346 bar-number)))
|
|
d@33
|
347 *harmonic-evaluation-period-cache*)))
|
|
d@33
|
348 (unless harmonisation
|
|
d@33
|
349 (let* ((composition (get-composition (make-geerdes-identifier file-id))))
|
|
d@33
|
350 (setf harmonisation (make-harmonic-evaluation-period bar-number
|
|
d@33
|
351 composition))
|
|
d@33
|
352 (push harmonisation *harmonic-evaluation-period-cache*)))
|
|
d@33
|
353 harmonisation))
|
|
d@33
|
354
|
|
d@33
|
355 (defun get-harmonic-evaluation-period-by-composition (bar-number composition)
|
|
d@33
|
356 (let ((harmonisation (find-if #'(lambda (x)
|
|
d@33
|
357 (and (eq (%composition x)
|
|
d@33
|
358 composition)
|
|
d@33
|
359 (= (%bar-number x)
|
|
d@33
|
360 bar-number)))
|
|
d@33
|
361 *harmonic-evaluation-period-cache*)))
|
|
d@33
|
362 (unless harmonisation
|
|
d@33
|
363 (setf harmonisation (make-harmonic-evaluation-period bar-number
|
|
d@33
|
364 composition))
|
|
d@33
|
365 (push harmonisation *harmonic-evaluation-period-cache*))
|
|
d@33
|
366 harmonisation))
|
|
d@33
|
367
|
|
d@33
|
368 (defun make-harmonic-evaluation-period (bar-number composition)
|
|
d@33
|
369 (with-slots (cat_id id)
|
|
d@33
|
370 (%db-entry composition)
|
|
d@33
|
371 (let ((harmonisation (make-instance 'harmonic-evaluation-period
|
|
d@33
|
372 :cat-id cat_id
|
|
d@33
|
373 :file-id id
|
|
d@33
|
374 :composition composition
|
|
d@33
|
375 :bar-number bar-number
|
|
d@33
|
376 :comp-bar-number (1+ bar-number)))
|
|
d@33
|
377 (period (whole-bar-period (1+ bar-number) composition)))
|
|
d@33
|
378 (setf (timepoint harmonisation) (timepoint period)
|
|
d@33
|
379 (duration harmonisation) (duration period))
|
|
d@33
|
380 harmonisation)))
|
|
d@33
|
381
|
|
d@33
|
382 (defun verify-chord (truth-chord derived-chord)
|
|
d@33
|
383 (let ((gt-root (pitch-class-from-gt (slot-value truth-chord 'root)))
|
|
d@33
|
384 (gt-label (chord-from-gt (chord-type truth-chord)))
|
|
d@33
|
385 (d-root (first derived-chord))
|
|
d@33
|
386 (d-label (chord-label (second derived-chord))))
|
|
d@33
|
387 (samechordp gt-root gt-label d-root d-label)))
|
|
d@33
|
388
|
|
d@33
|
389 (defun get-chord (anchored-period harmonisation)
|
|
d@33
|
390 (likelihood-chord (first (best-n-likelihoods 1
|
|
d@33
|
391 (cdr (assoc anchored-period
|
|
d@33
|
392 (derived-likelihoods harmonisation)
|
|
d@33
|
393 :test #'period=))))))
|
|
d@33
|
394
|
|
d@33
|
395 (defun ground-truth-window-beats (harmonisation)
|
|
d@33
|
396 (let ((beat 1) (beat-list '(1)))
|
|
d@33
|
397 (dolist (size (ground-truth-window-sizes harmonisation) (reverse (cdr beat-list)))
|
|
d@33
|
398 (push (incf beat size) beat-list))))
|
|
d@33
|
399
|
|
d@33
|
400 (defun find-matching-period (onset duration period-list)
|
|
d@33
|
401 (find-if #'(lambda (x) (and (= onset (timepoint x))
|
|
d@33
|
402 (= duration (duration x))))
|
|
d@33
|
403 period-list))
|
|
d@33
|
404
|
|
d@33
|
405 (defun position-matching-period (onset duration period-list)
|
|
d@33
|
406 (position-if #'(lambda (x) (and (= onset (timepoint x))
|
|
d@33
|
407 (= duration (duration x))))
|
|
d@33
|
408 period-list))
|
|
d@33
|
409
|
|
d@33
|
410 (defun compare-paths (bar piece &key (chordset *full-set*) models controlp mergep)
|
|
d@33
|
411 ;; FIXME: Recreate controlp and mergep
|
|
d@33
|
412 (declare (ignore controlp mergep models))
|
|
d@33
|
413 (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
|
|
d@33
|
414 (gtw-beats (ground-truth-window-beats harmonisation))
|
|
d@33
|
415 (gtw-sizes (ground-truth-window-sizes harmonisation))
|
|
d@33
|
416 (score (loop for i from 0 to (1- (length gtw-beats))
|
|
d@33
|
417 count (find-matching-period (+ (1- (nth i gtw-beats))
|
|
d@33
|
418 (timepoint harmonisation))
|
|
d@33
|
419 (nth i gtw-sizes)
|
|
d@33
|
420 (derived-windows harmonisation
|
|
d@33
|
421 :chordset chordset)))))
|
|
d@33
|
422 (values (= score (length gtw-sizes)) score (length gtw-sizes))))
|
|
d@33
|
423
|
|
d@33
|
424 (defun compare-paths-and-harmonies (bar piece &key (chordset *full-set*) models controlp mergep)
|
|
d@33
|
425 ;; FIXME: Recreate controlp and mergep
|
|
d@33
|
426 (declare (ignore controlp mergep models))
|
|
d@33
|
427 (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
|
|
d@33
|
428 (gtw-beats (ground-truth-window-beats harmonisation))
|
|
d@33
|
429 (gtw-sizes (ground-truth-window-sizes harmonisation))
|
|
d@33
|
430 (g-chords (ground-truth-chords harmonisation))
|
|
d@33
|
431 (d-chords (derived-chords harmonisation))
|
|
d@33
|
432 (d-windows (derived-windows harmonisation :chordset chordset))
|
|
d@33
|
433 (score (loop for i from 0 to (1- (length gtw-beats))
|
|
d@33
|
434 count (let ((matchesp (position-matching-period (+ (1- (nth i gtw-beats))
|
|
d@33
|
435 (timepoint harmonisation))
|
|
d@33
|
436 (nth i gtw-sizes)
|
|
d@33
|
437 d-windows)))
|
|
d@33
|
438 (and matchesp
|
|
d@33
|
439 (verify-chord (nth i g-chords)
|
|
d@33
|
440 (nth matchesp d-chords)))))))
|
|
d@33
|
441 (values (= score (length gtw-sizes)) score (length gtw-sizes))))
|
|
d@33
|
442
|
|
d@33
|
443 (defun compare-harmonies-with-gt-windows (bar piece &key (chordset *full-set*) models)
|
|
d@33
|
444 (declare (ignore chordset models))
|
|
d@33
|
445 (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
|
|
d@33
|
446 (ground-truth (ground-truth-chords harmonisation))
|
|
d@33
|
447 (score 0))
|
|
d@33
|
448 (do ((gt-chords ground-truth (cdr gt-chords)))
|
|
d@33
|
449 ((null gt-chords) (values (= score (length ground-truth))
|
|
d@33
|
450 score
|
|
d@33
|
451 (length ground-truth)))
|
|
d@33
|
452 (when (verify-chord (first gt-chords)
|
|
d@33
|
453 (get-chord (make-anchored-period (+ (timepoint harmonisation)
|
|
d@33
|
454 (1- (start-beat (first gt-chords))))
|
|
d@33
|
455 (- (if (second gt-chords)
|
|
d@33
|
456 (start-beat (second gt-chords))
|
|
d@33
|
457 (duration harmonisation))
|
|
d@33
|
458 (1- (start-beat (first gt-chords)))))
|
|
d@33
|
459 harmonisation))
|
|
d@33
|
460 (incf score)))))
|
|
d@33
|
461
|
|
d@33
|
462 (defun compare-harmonies-by-beat (bar piece &key (chordset *full-set*) models)
|
|
d@33
|
463 (declare (ignore chordset models))
|
|
d@33
|
464 (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
|
|
d@33
|
465 (score (loop for i from 1 to (duration harmonisation)
|
|
d@33
|
466 count (verify-chord (get-gt-chord-by-beat i harmonisation)
|
|
d@33
|
467 (get-derived-chord-by-beat i harmonisation)))))
|
|
d@33
|
468 (values (= score (duration harmonisation)) score (duration harmonisation))))
|
|
d@33
|
469
|
|
d@33
|
470 (defun get-gt-chord-by-beat (beat harmonisation)
|
|
d@33
|
471 (let ((chords (ground-truth-chords harmonisation)))
|
|
d@33
|
472 (do ((gt (reverse chords) (cdr gt)))
|
|
d@33
|
473 ((null gt) (car chords))
|
|
d@33
|
474 (when (<= (start-beat (car gt)) beat)
|
|
d@33
|
475 (return-from get-gt-chord-by-beat
|
|
d@33
|
476 (car gt))))))
|
|
d@33
|
477
|
|
d@33
|
478 (defun get-derived-chord-by-beat (beat harmonisation)
|
|
d@33
|
479 (let ((total-beat (+ (1- beat)
|
|
d@33
|
480 (timepoint harmonisation)))
|
|
d@33
|
481 (chords (derived-chords harmonisation))
|
|
d@33
|
482 (windows (derived-windows harmonisation)))
|
|
d@33
|
483 (nth (position-if #'(lambda (x) (and (>= total-beat
|
|
d@33
|
484 (timepoint x))
|
|
d@33
|
485 (< total-beat
|
|
d@33
|
486 (timepoint (cut-off x)))))
|
|
d@33
|
487 windows)
|
|
d@33
|
488 chords)))
|
|
d@33
|
489
|
|
d@33
|
490 (defparameter *param-estimation-numbers*
|
|
d@33
|
491 (list (cons :major (make-array '(4 21)))
|
|
d@33
|
492 (cons :minor (make-array '(4 21)))
|
|
d@33
|
493 (cons :dim (make-array '(4 21)))
|
|
d@33
|
494 (cons :aug (make-array '(4 21)))
|
|
d@33
|
495 (cons :sus4 (make-array '(4 21)))
|
|
d@33
|
496 (cons :sus9 (make-array '(4 21)))))
|
|
d@33
|
497
|
|
d@33
|
498 (defun incf-stats (size type offset piece bar distribution)
|
|
d@33
|
499 (let* ((param (cdr (assoc type *param-estimation-numbers*)))
|
|
d@33
|
500 (chord-notes (main-notes (find type (chords *full-set*) :key #'chord-label)))
|
|
d@33
|
501 (full-total (reduce #'+ distribution))
|
|
d@33
|
502 (chord-sum (loop for scale-deg in chord-notes
|
|
d@33
|
503 sum (aref distribution (mod (+ offset scale-deg) 12)))))
|
|
d@33
|
504 (when (= full-total 0)
|
|
d@33
|
505 (return-from incf-stats))
|
|
d@33
|
506 (when (> chord-sum full-total)
|
|
d@33
|
507 (format *standard-output*
|
|
d@33
|
508 "~%Piece ~D, Bar ~D, distribution ~D, ~D ~D~%"
|
|
d@33
|
509 piece bar distribution offset type)
|
|
d@33
|
510 (error "BRRRRROKEN!"))
|
|
d@33
|
511 (when (<= chord-sum 1/4)
|
|
d@33
|
512 (format *standard-output*
|
|
d@33
|
513 "~%Piece ~D, Bar ~D, distribution ~D, ~D ~D~%"
|
|
d@33
|
514 piece bar distribution offset type)
|
|
d@33
|
515 (return-from incf-stats))
|
|
d@33
|
516 #+nil (when (<= (aref distribution (mod (+ offset (nth 1 chord-notes)) 12)) 1/40)
|
|
d@33
|
517 (format *standard-output* "~%******Piece ~D, Bar ~D. distribution ~D, ~D ~D"
|
|
d@33
|
518 piece bar distribution offset type)
|
|
d@33
|
519 (return-from incf-stats))
|
|
d@33
|
520 (when (<= (aref distribution offset) 1/10)
|
|
d@33
|
521 (format *standard-output* "~%Piece ~D, Bar ~D. distribution ~D, ~D ~D"
|
|
d@33
|
522 piece bar distribution offset type)
|
|
d@33
|
523 (return-from incf-stats))
|
|
d@33
|
524 (let* ((chord-ratio (/ chord-sum full-total))
|
|
d@33
|
525 (chord-squared (* chord-ratio chord-ratio))
|
|
d@33
|
526 (chord-logged (log chord-ratio))
|
|
d@33
|
527 (non-chord (- 1 chord-ratio))
|
|
d@33
|
528 (non-chord-squared (* non-chord non-chord))
|
|
d@33
|
529 (non-chord-logged (log non-chord))
|
|
d@33
|
530 (d1 (/ (aref distribution (mod (+ offset (nth 0 chord-notes)) 12))
|
|
d@33
|
531 chord-sum))
|
|
d@33
|
532 (d1-squared (* d1 d1))
|
|
d@33
|
533 (d1-logged (log d1))
|
|
d@33
|
534 (d3 (/ (aref distribution (mod (+ offset (nth 1 chord-notes)) 12))
|
|
d@33
|
535 chord-sum))
|
|
d@33
|
536 (d3-squared (* d3 d3))
|
|
d@33
|
537 (d3-logged (log d3))
|
|
d@33
|
538 (d5 (/ (aref distribution (mod (+ offset (nth 2 chord-notes)) 12))
|
|
d@33
|
539 chord-sum))
|
|
d@33
|
540 (d5-squared (* d5 d5))
|
|
d@33
|
541 (d5-logged (log d5)))
|
|
d@33
|
542 ;; n
|
|
d@33
|
543 (incf (aref param size 0))
|
|
d@33
|
544 (incf (aref param size 1) chord-ratio)
|
|
d@33
|
545 (incf (aref param size 2) chord-squared)
|
|
d@33
|
546 (if (= chord-ratio 0)
|
|
d@33
|
547 (incf (aref param size 4))
|
|
d@33
|
548 (incf (aref param size 3) chord-logged))
|
|
d@33
|
549 (incf (aref param size 5) non-chord)
|
|
d@33
|
550 (incf (aref param size 6) non-chord-squared)
|
|
d@33
|
551 (if (= non-chord 0)
|
|
d@33
|
552 (incf (aref param size 8))
|
|
d@33
|
553 (incf (aref param size 7) non-chord-logged))
|
|
d@33
|
554 (incf (aref param size 9) d1)
|
|
d@33
|
555 (incf (aref param size 10) d1-squared)
|
|
d@33
|
556 (if (= d1 0)
|
|
d@33
|
557 (incf (aref param size 12))
|
|
d@33
|
558 (incf (aref param size 11) d1-logged))
|
|
d@33
|
559 (incf (aref param size 13) d3)
|
|
d@33
|
560 (incf (aref param size 14) d3-squared)
|
|
d@33
|
561 (if (= d3 0)
|
|
d@33
|
562 (incf (aref param size 16))
|
|
d@33
|
563 (incf (aref param size 15) d3-logged))
|
|
d@33
|
564 (incf (aref param size 17) d5)
|
|
d@33
|
565 (incf (aref param size 18) d5-squared)
|
|
d@33
|
566 (if (= d5 0)
|
|
d@33
|
567 (incf (aref param size 20))
|
|
d@33
|
568 (incf (aref param size 19) d5-logged)))))
|
|
d@33
|
569
|
|
d@33
|
570 (defun parameter-estimation-figures (&key (test-set *test-set*))
|
|
d@33
|
571 (let ((size 0) (beat 0)
|
|
d@33
|
572 (c-type) (offset 0)
|
|
d@33
|
573 (harmonisation) (bar 0) (piece 0))
|
|
d@33
|
574 (dolist (test test-set)
|
|
d@33
|
575 (setf piece (car test)
|
|
d@33
|
576 bar (cdr test)
|
|
d@33
|
577 harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
|
|
d@33
|
578 (do ((windows (ground-truth-chords harmonisation) (cdr windows))
|
|
d@33
|
579 (window-sizes (ground-truth-window-sizes harmonisation) (cdr window-sizes))
|
|
d@33
|
580 (window-beats (ground-truth-window-beats harmonisation) (cdr window-beats)))
|
|
d@33
|
581 ((not windows))
|
|
d@33
|
582 (setf size (1- (first window-sizes))
|
|
d@33
|
583 c-type (chord-from-gt (chord-type (first windows)))
|
|
d@33
|
584 offset (pitch-class-from-gt (slot-value (first windows) 'root))
|
|
d@33
|
585 beat (+ (1- (first window-beats)) (timepoint harmonisation)))
|
|
d@33
|
586 (incf-stats size c-type offset piece bar
|
|
d@33
|
587 (pitch-class-distribution (make-anchored-period beat (1+ size))
|
|
d@33
|
588 (%composition harmonisation)))))))
|
|
d@33
|
589
|
|
d@33
|
590
|
|
d@33
|
591 (defun write-numbers-to-file (pathname)
|
|
d@33
|
592 (with-open-file (s pathname :direction :output :if-exists :supersede)
|
|
d@33
|
593 (dolist (acns *param-estimation-numbers*)
|
|
d@33
|
594 (let ((c-type (car acns)) (data (cdr acns)))
|
|
d@33
|
595 (dotimes (i 4)
|
|
d@33
|
596 (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
|
597 c-type (1+ i)
|
|
d@33
|
598 (aref data i 0) #\Tab
|
|
d@33
|
599 (float (aref data i 1)) #\Tab (float (aref data i 2)) #\Tab
|
|
d@33
|
600 (float (aref data i 3)) #\Tab (aref data i 4) #\Tab
|
|
d@33
|
601 (float (aref data i 5)) #\Tab (float (aref data i 6)) #\Tab
|
|
d@33
|
602 (float (aref data i 7)) #\Tab (aref data i 8) #\Tab
|
|
d@33
|
603 (float (aref data i 9)) #\Tab (float (aref data i 10)) #\Tab
|
|
d@33
|
604 (float (aref data i 11)) #\Tab (aref data i 12) #\Tab
|
|
d@33
|
605 (float (aref data i 13)) #\Tab (float (aref data i 14)) #\Tab
|
|
d@33
|
606 (float (aref data i 15)) #\Tab (aref data i 16) #\Tab
|
|
d@33
|
607 (float (aref data i 17)) #\Tab (float (aref data i 18)) #\Tab
|
|
d@33
|
608 (float (aref data i 19)) #\Tab (aref data i 20)))))))
|
|
d@33
|
609
|
|
d@33
|
610 (defun write-numbers-to-file-2 (pathname)
|
|
d@33
|
611 (with-open-file (s pathname :direction :output :if-exists :supersede)
|
|
d@33
|
612 (dolist (acns *param-estimation-numbers*)
|
|
d@33
|
613 (let ((c-type (car acns)) (data (cdr acns)))
|
|
d@33
|
614 (dotimes (i 4)
|
|
d@33
|
615 (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
|
616 c-type (1+ i)
|
|
d@33
|
617 ;; chord / non-chord (x, x^2, log(x), left out, n)
|
|
d@33
|
618 (float (aref data i 1)) (float (aref data i 5))
|
|
d@33
|
619 (float (aref data i 2)) (float (aref data i 6))
|
|
d@33
|
620 (float (aref data i 3)) (float (aref data i 7))
|
|
d@33
|
621 (aref data i 4) (aref data i 8)
|
|
d@33
|
622 (aref data i 0)
|
|
d@33
|
623 ;; 1 / 3 / 5 (x, x^2, log(x), left out, n)
|
|
d@33
|
624 (float (aref data i 9)) (float (aref data i 13)) (float (aref data i 17))
|
|
d@33
|
625 (float (aref data i 10)) (float (aref data i 14)) (float (aref data i 18))
|
|
d@33
|
626 (float (aref data i 11)) (float (aref data i 15)) (float (aref data i 19))
|
|
d@33
|
627 (aref data i 12) (aref data i 16) (aref data i 20)
|
|
d@33
|
628 (aref data i 0)))))))
|
|
d@33
|
629
|
|
d@33
|
630 (defun test-paths (&key (test-set *test-set*))
|
|
d@33
|
631 (let ((bars 0) (grand-score 0) (grand-total 0))
|
|
d@33
|
632 (loop for test in test-set
|
|
d@33
|
633 do (when (goodness-test (cdr test) (car test))
|
|
d@33
|
634 (multiple-value-bind (match score total)
|
|
d@33
|
635 (compare-paths (cdr test) (car test))
|
|
d@33
|
636 (when match (incf bars))
|
|
d@33
|
637 (incf grand-score score)
|
|
d@33
|
638 (incf grand-total total))))
|
|
d@33
|
639 (values bars grand-score grand-total)))
|
|
d@33
|
640
|
|
d@33
|
641 (defparameter *ignored* nil)
|
|
d@33
|
642 (defun goodness-test (bar piece)
|
|
d@33
|
643 ;; exclusions bin
|
|
d@33
|
644 (let* ((harmonisation (get-harmonic-evaluation-period bar :cat-id piece))
|
|
d@33
|
645 (sounding-sum (reduce #'+ (pitch-class-distribution harmonisation (%composition harmonisation))))
|
|
d@33
|
646 (pcd))
|
|
d@33
|
647 ;; Too little sounding
|
|
d@33
|
648 (unless (> sounding-sum 1/4)
|
|
d@33
|
649 (push (list bar piece) *ignored*)
|
|
d@33
|
650 (return-from goodness-test nil))
|
|
d@33
|
651 ;; per gt window tests
|
|
d@33
|
652 (do ((window-beats (ground-truth-window-beats harmonisation) (cdr window-beats))
|
|
d@33
|
653 (window-sizes (ground-truth-window-sizes harmonisation) (cdr window-sizes))
|
|
d@33
|
654 (gt-chords (ground-truth-chords harmonisation) (cdr gt-chords)))
|
|
d@33
|
655 ((null window-beats) t)
|
|
d@33
|
656 (setf pcd (pitch-class-distribution (make-anchored-period (+ (timepoint harmonisation)
|
|
d@33
|
657 (1- (first window-beats)))
|
|
d@33
|
658 (first window-sizes))
|
|
d@33
|
659 (%composition harmonisation)))
|
|
d@33
|
660 (unless (and (> (reduce #'+ pcd) 1)
|
|
d@33
|
661 (> (aref pcd (pitch-class-from-gt (slot-value (first gt-chords) 'root)))
|
|
d@33
|
662 1/16))
|
|
d@33
|
663 (push (list bar piece) *ignored*)
|
|
d@33
|
664 (return-from goodness-test nil)))))
|
|
d@33
|
665
|
|
d@33
|
666 (defun test-harmonies (&key (test-set *test-set*))
|
|
d@33
|
667 ;; FIXME: whole bars only at the mo!
|
|
d@33
|
668 (loop for test in test-set
|
|
d@33
|
669 count (when (goodness-test (cdr test) (car test))
|
|
d@33
|
670 (compare-harmonies-with-gt-windows (cdr test) (car test)))))
|
|
d@33
|
671
|
|
d@33
|
672 (defun test-paths-and-chords (&key (test-set *test-set*))
|
|
d@33
|
673 (let ((bars 0) (grand-score 0) (grand-total 0))
|
|
d@33
|
674 (loop for test in test-set
|
|
d@33
|
675 do (when (goodness-test (cdr test) (car test))
|
|
d@33
|
676 (multiple-value-bind (match score total)
|
|
d@33
|
677 (compare-paths-and-harmonies (cdr test) (car test))
|
|
d@33
|
678 (when match (incf bars))
|
|
d@33
|
679 (incf grand-score score)
|
|
d@33
|
680 (incf grand-total total))))
|
|
d@33
|
681 (values bars grand-score grand-total)))
|
|
d@33
|
682
|
|
d@33
|
683 (defun test-harmonies-by-window (&key (test-set *test-set*))
|
|
d@33
|
684 (let ((bars 0) (grand-score 0) (grand-total 0))
|
|
d@33
|
685 (loop for test in test-set
|
|
d@33
|
686 do (when (goodness-test (cdr test) (car test))
|
|
d@33
|
687 (multiple-value-bind (match score total)
|
|
d@33
|
688 (compare-harmonies-with-gt-windows (cdr test) (car test))
|
|
d@33
|
689 (when match (incf bars))
|
|
d@33
|
690 (incf grand-score score)
|
|
d@33
|
691 (incf grand-total total))))
|
|
d@33
|
692 (values bars grand-score grand-total)))
|
|
d@33
|
693
|
|
d@33
|
694 (defun test-harmonies-by-beat (&key (test-set *test-set*))
|
|
d@33
|
695 (let ((bars 0) (grand-score 0) (grand-total 0))
|
|
d@33
|
696 (loop for test in test-set
|
|
d@33
|
697 do (when (goodness-test (cdr test) (car test))
|
|
d@33
|
698 (multiple-value-bind (match score total)
|
|
d@33
|
699 (compare-harmonies-by-beat (cdr test) (car test))
|
|
d@33
|
700 (when match (incf bars))
|
|
d@33
|
701 (incf grand-score score)
|
|
d@33
|
702 (incf grand-total total))))
|
|
d@33
|
703 (values bars grand-score grand-total)))
|
|
d@33
|
704
|
|
d@33
|
705 (defgeneric whole-bar-period (bar-number composition))
|
|
d@33
|
706 (defmethod whole-bar-period (bar-number (composition geerdes-midi-composition))
|
|
d@33
|
707 (multiple-value-bind (beat-no timesig)
|
|
d@33
|
708 (bar-number-to-beats bar-number composition)
|
|
d@33
|
709 (make-anchored-period (timepoint beat-no) (crotchets-in-a-bar timesig))))
|
|
d@33
|
710
|
|
d@33
|
711 (defgeneric bar-number-to-beats (bar-number composition))
|
|
d@33
|
712 (defmethod bar-number-to-beats (bar-number (composition geerdes-midi-composition))
|
|
d@33
|
713 (do* ((time-sig-list (time-signatures composition) (cdr time-sig-list))
|
|
d@33
|
714 (current-sig (car time-sig-list) (car time-sig-list))
|
|
d@33
|
715 (beats-per-bar (make-floating-period (crotchets-in-a-bar current-sig))
|
|
d@33
|
716 (make-floating-period (crotchets-in-a-bar current-sig)))
|
|
d@33
|
717 (bars-left bar-number))
|
|
d@33
|
718 ((time>= (cut-off current-sig)
|
|
d@33
|
719 (time+ (onset current-sig)
|
|
d@33
|
720 (duration* beats-per-bar bars-left)))
|
|
d@33
|
721 (values (time+ (onset current-sig)
|
|
d@33
|
722 (duration* beats-per-bar bars-left))
|
|
d@33
|
723 current-sig))
|
|
d@33
|
724 (decf bars-left (duration/ current-sig beats-per-bar))))
|
|
d@33
|
725
|
|
d@33
|
726 (defun samechordp (root1 label1 root2 label2)
|
|
d@33
|
727 (or (and (= root1 root2)
|
|
d@33
|
728 (eq label1 label2))
|
|
d@33
|
729 (and (eq label1 :sus4)
|
|
d@33
|
730 (eq label2 :sus9)
|
|
d@33
|
731 (= root2 (mod (+ root1 5) 12)))
|
|
d@33
|
732 (and (eq label2 :sus4)
|
|
d@33
|
733 (eq label1 :sus9)
|
|
d@33
|
734 (= root1 (mod (+ root2 5) 12)))))
|
|
d@33
|
735
|
|
d@33
|
736 (defun chord-from-gt (string)
|
|
d@33
|
737 (cdr (assoc string '(("maj" . :major) ("min" . :minor)
|
|
d@33
|
738 ("dim" . :dim) ("aug" . :aug)
|
|
d@33
|
739 ("sus4" . :sus4) ("sus9" . :sus9))
|
|
d@33
|
740 :test #'equal)))
|
|
d@33
|
741
|
|
d@33
|
742 (defun pitch-class-from-gt (string)
|
|
d@33
|
743 (position-if #'(lambda (x) (string-equal x string))
|
|
d@33
|
744 *dm-note-names*))
|
|
d@33
|
745
|
|
d@33
|
746 (defun piece-chord-list (id)
|
|
d@33
|
747 (remove-if #'(lambda (x)
|
|
d@33
|
748 (not (= (cat_id x) id)))
|
|
d@33
|
749 (all-chords)))
|
|
d@33
|
750
|
|
d@33
|
751 (defun get-gt-bar-chords (piece bar)
|
|
d@33
|
752 (let ((bar-beats (* 4 bar))
|
|
d@33
|
753 (chord-list (sort (piece-chord-list piece)
|
|
d@33
|
754 #'chord-time->)))
|
|
d@33
|
755 (loop for i from bar-beats to (+ 3 bar-beats)
|
|
d@33
|
756 collect (gt-chord-to-list (get-applicable-chord i chord-list)))))
|
|
d@33
|
757
|
|
d@33
|
758 (defun gt-chord-to-list (chord)
|
|
d@33
|
759 (list (pitch-class-from-gt (slot-value chord 'root))
|
|
d@33
|
760 (chord-from-gt (chord-type chord))))
|
|
d@33
|
761
|
|
d@33
|
762 (defun explore-parameters (&key (alpha-scale '(0.4 3)) (beta '(4 14)))
|
|
d@33
|
763 (let* ((original-alpha *alpha*)
|
|
d@33
|
764 (original-betas *betas*)
|
|
d@33
|
765 (results (loop for i from (first alpha-scale) to (second alpha-scale) by 0.3
|
|
d@33
|
766 collect (progn
|
|
d@33
|
767 (setf *alpha* (map 'vector
|
|
d@33
|
768 #'(lambda (x)
|
|
d@33
|
769 (* x i))
|
|
d@33
|
770 original-alpha))
|
|
d@33
|
771 (print *alpha*)
|
|
d@33
|
772 (list i (explore-betas beta))))))
|
|
d@33
|
773 (setf *alpha* original-alpha
|
|
d@33
|
774 *betas* original-betas)
|
|
d@33
|
775 results))
|
|
d@33
|
776
|
|
d@33
|
777 (defun explore-betas (beta)
|
|
d@33
|
778 (let* ((b1 (first beta))
|
|
d@33
|
779 (bn (second beta))
|
|
d@33
|
780 (n (- bn b1)))
|
|
d@33
|
781 (assert (equal (array-dimensions *results*)
|
|
d@33
|
782 (list n n n n 4)))
|
|
d@33
|
783 (loop for semi from 0 to (1- n) by 2
|
|
d@33
|
784 do (progn
|
|
d@33
|
785 (format t "|~D |" (+ semi b1))
|
|
d@33
|
786 (loop for dotted-minim from 0 to (1- n) by 2
|
|
d@33
|
787 do (loop for minim from 0 to (1- n) by 2
|
|
d@33
|
788 do (loop for crotchet from 0 to (1- n) by 2
|
|
d@33
|
789 do (progn
|
|
d@33
|
790 (setf *harmonic-evaluation-period-cache* nil
|
|
d@33
|
791 *betas* (list (cons 1 (+ b1 semi))
|
|
d@33
|
792 (cons 3/4 (+ b1 dotted-minim))
|
|
d@33
|
793 (cons 1/2 (+ b1 minim))
|
|
d@33
|
794 (cons 1/4 (+ b1 crotchet))))
|
|
d@33
|
795 (unless (> (aref *results* semi dotted-minim minim crotchet 0)
|
|
d@33
|
796 0)
|
|
d@33
|
797 (multiple-value-bind (dull score total)
|
|
d@33
|
798 (test-paths)
|
|
d@33
|
799 (declare (ignore dull))
|
|
d@33
|
800 (setf (aref *results* semi dotted-minim minim crotchet 0)
|
|
d@33
|
801 (/ score total))))
|
|
d@33
|
802 (unless (> (aref *results* semi dotted-minim minim crotchet 1)
|
|
d@33
|
803 0)
|
|
d@33
|
804 (multiple-value-bind (dull score total)
|
|
d@33
|
805 (test-paths-and-chords)
|
|
d@33
|
806 (declare (ignore dull))
|
|
d@33
|
807 (setf (aref *results* semi dotted-minim minim crotchet 1)
|
|
d@33
|
808 (/ score total))))
|
|
d@33
|
809 (unless (> (aref *results* semi dotted-minim minim crotchet 2)
|
|
d@33
|
810 0)
|
|
d@33
|
811 (multiple-value-bind (dull score total)
|
|
d@33
|
812 (test-harmonies-by-window)
|
|
d@33
|
813 (declare (ignore dull))
|
|
d@33
|
814 (setf (aref *results* semi dotted-minim minim crotchet 2)
|
|
d@33
|
815 (/ score total))))
|
|
d@33
|
816 (unless (> (aref *results* semi dotted-minim minim crotchet 3)
|
|
d@33
|
817 0)
|
|
d@33
|
818 (multiple-value-bind (dull score total)
|
|
d@33
|
819 (test-harmonies-by-beat)
|
|
d@33
|
820 (declare (ignore dull))
|
|
d@33
|
821 (setf (aref *results* semi dotted-minim minim crotchet 3)
|
|
d@33
|
822 (/ score total))))))))))
|
|
d@33
|
823 *results*))
|
|
d@33
|
824
|
|
d@33
|
825 (defparameter *results* (make-array '(10 10 10 10 4) :element-type 'ratio))
|
|
d@33
|
826
|
|
d@33
|
827 (defun explore-parameters-to-file (pathname &key (alpha-scale '(0.4 3)) (beta '(4 14)))
|
|
d@33
|
828 (with-open-file (stream pathname :direction :output :if-exists :supersede)
|
|
d@33
|
829 (let* ((original-alpha *alpha*)
|
|
d@33
|
830 (original-betas *betas*))
|
|
d@33
|
831 (loop for i from (first alpha-scale) to (second alpha-scale) by 0.3
|
|
d@33
|
832 do (progn
|
|
d@33
|
833 (setf *alpha* (map 'vector
|
|
d@33
|
834 #'(lambda (x)
|
|
d@33
|
835 (* x i))
|
|
d@33
|
836 original-alpha))
|
|
d@33
|
837 (print *alpha*)
|
|
d@33
|
838 (explore-betas-to-stream beta stream)))
|
|
d@33
|
839 (setf *alpha* original-alpha
|
|
d@33
|
840 *betas* original-betas))))
|
|
d@33
|
841
|
|
d@33
|
842 (defun explore-betas-to-stream (beta stream)
|
|
d@33
|
843 (let* ((b1 (first beta))
|
|
d@33
|
844 (bn (second beta))
|
|
d@33
|
845 (n (- bn b1)) (tb #\tab))
|
|
d@33
|
846 (loop for semi from 0 to (1- n) by 2
|
|
d@33
|
847 do (progn
|
|
d@33
|
848 (format *standard-output* "|~D |" (+ semi b1))
|
|
d@33
|
849 (finish-output)
|
|
d@33
|
850 (loop for dotted-minim from 0 to (1- n) by 2
|
|
d@33
|
851 do (loop for minim from 0 to (1- n) by 2
|
|
d@33
|
852 do (loop for crotchet from 0 to (1- n) by 2
|
|
d@33
|
853 do (progn
|
|
d@33
|
854 (format stream "~D~C~D~C~D~C~D~C~D~C"
|
|
d@33
|
855 (aref *alpha* 0) tb
|
|
d@33
|
856 (+ b1 semi) tb
|
|
d@33
|
857 (+ b1 dotted-minim) tb
|
|
d@33
|
858 (+ b1 minim) tb
|
|
d@33
|
859 (+ b1 crotchet) tb)
|
|
d@33
|
860 (setf *harmonic-evaluation-period-cache* nil
|
|
d@33
|
861 *betas* (list (cons 1 (+ b1 semi))
|
|
d@33
|
862 (cons 3/4 (+ b1 dotted-minim))
|
|
d@33
|
863 (cons 1/2 (+ b1 minim))
|
|
d@33
|
864 (cons 1/4 (+ b1 crotchet))))
|
|
d@33
|
865 (multiple-value-bind (dull score total)
|
|
d@33
|
866 (test-paths)
|
|
d@33
|
867 (declare (ignore dull))
|
|
d@33
|
868 (format stream "~D~C" (/ score total) tb))
|
|
d@33
|
869 (multiple-value-bind (dull score total)
|
|
d@33
|
870 (test-paths-and-chords)
|
|
d@33
|
871 (declare (ignore dull))
|
|
d@33
|
872 (format stream "~D~C" (/ score total) tb))
|
|
d@33
|
873 (multiple-value-bind (dull score total)
|
|
d@33
|
874 (test-harmonies-by-window)
|
|
d@33
|
875 (declare (ignore dull))
|
|
d@33
|
876 (format stream "~D~C" (/ score total) tb))
|
|
d@33
|
877 (multiple-value-bind (dull score total)
|
|
d@33
|
878 (test-harmonies-by-beat)
|
|
d@33
|
879 (declare (ignore dull))
|
|
d@33
|
880 (format stream "~D~C~%" (/ score total) tb))
|
|
d@33
|
881 (finish-output stream)))))))))
|
|
d@33
|
882
|
