;;********************************************
;;********************************************
;;////////////////////////////////////////////
;;Pearson
Correlation Algorithm to find Tonal Key
;;////////////////////////////////////////////
;;Mauricio
Rodriguez - 2009
;;////////////////////////////////////////////
;;marod@ccrma.stanford.edu
;;////////////////////////////////////////////
;;********************************************
;;********************************************
#|
******************************
******************************
Use and
copying of this software and preparation of derivative works
based upon
this software are prohibited unless permission of the author.
Suggestions,
comments and bug reports are welcome. Please address email to:
marod@ccrma.stanford.edu
******************************
******************************
|#
;;Main:
;;key-finder
[note-sequence(pitch-class) major-weight minor-weight]
;;(key-finder
'(8 0 0 0 2 11 0 5 7 0 5 2) '(2 0 1 0 1 1 0 2 0 1 0 1) '(2 0 1 1 0 1 0 2 1 0
0.5 0.5))
;;Code:
#|
(defun
average-value (list)
(let ((current-list (remove-if
#'(lambda (x) (= 0 x)) list)))
(float (/ (apply #'+
current-list) (length current-list)))))
|#
(defun
average-value (list)
(float (/ (apply #'+ list) (length
list))))
(defun
pearson-correlation* (average-x average-y pitch-list weight-list)
(if (or (endp pitch-list) (endp
weight-list))
nil
(cons (list (- (first
pitch-list) average-x)
(- (first weight-list) average-y))
(pearson-correlation*
average-x
average-y
(rest
pitch-list)
(rest
weight-list)))))
;;(pearson-correlation*
3.3333 0.7500 '(8 0 0 0 2 11 0 5 7 0 5 2) '(2 0 1 0 1 1 0 2 0 1 0 1))
(defun
pearson-correlation** (average-x average-y pitch-list weight-list)
(let* ((correlation
(pearson-correlation* average-x average-y pitch-list weight-list))
(part-a (apply #'+ (loop
for x in correlation
collect (* (first x) (second x)))))
(part-b (apply #'+ (loop for x in correlation
collect (expt (first x) 2))))
(part-c (apply #'+ (loop for x in correlation
collect (expt (second x) 2)))))
(/ part-a (sqrt (* part-b
part-c)))))
;;(pearson-correlation**
3.3333 0.7500 '(8 0 0 0 2 11 0 5 7 0 5 2) '(2 0 1 0 1 1 0 2 0 1 0 1))
(defun pearson-correlation***
(pitch-list weight-list)
(pearson-correlation** (average-value
pitch-list)
(average-value weight-list)
pitch-list
weight-list))
;;(pearson-correlation***
'(8 0 0 0 2 11 0 5 7 0 5 2) '(2 0 1 0 1 1 0 2 0 1 0 1))
;;(pearson-correlation***
'(8 0 0 0 2 11 0 5 7 0 5 2) '(1 2 0 1 0 1 1 0 2 0 1 0))
;;(pearson-correlation***
'(8 0 0 0 2 11 0 5 7 0 5 2) '(0 1 2 0 1 0 1 1 0 2 0 1))
(defun
rotate-list (list)
(do ((count (length list) (- count 1))
(current-list list (append (last current-list) (butlast current-list)))
(output
nil (cons current-list output)))
((= count 0)
(reverse output))))
(defun pearson-correlation****
(pitch-list weight-list)
(let ((rotation (rotate-list
weight-list)))
(loop for x in rotation
collect
(pearson-correlation*** pitch-list x))))
(defun
major-key-label (list)
(loop for x in '(C-Major
Db-Major
D-Major
Eb-Major
E-Major
F-Major
F#-Major
G-Major
Ab-Major
A-Major
Bb-Major
B-Major)
for
y in list
collect (list x y)))
;;(major-key-label
'(1 2 3 4 5 6 7 8 9 10 11 12))
(defun
minor-key-label (list)
(loop for x in '(C-Minor
C#-Minor
D-Minor
Eb-Minor
E-Minor
F-Minor
F#-Minor
G-Minor
G#-Minor
A-Minor
Bb-Minor
B-Minor)
for
y in list
collect (list x y)))
;;(minor-key-label
'(1 2 3 4 5 6 7 8 9 10 11 12))
(defun
key-finder* (pitch-list major-weight minor-weight)
(append
(major-key-label
(pearson-correlation**** pitch-list major-weight))
(minor-key-label
(pearson-correlation**** pitch-list minor-weight))))
;;(key-finder*
'(8 0 0 0 2 11 0 5 7 0 5 2) '(2 0 1 0 1 1 0 2 0 1 0 1) '(2 0 1 1 0 1 0 2 1 0
0.5 0.5))
(defun
search-max-in-compound-list (list)
(let ((maxima
(apply #'max (loop for z in list
collect (second z)))))
(loop for x in list
for y =
(second x)
when (=
maxima y )
return
(first x))))
(defun
key-finder (pitch-list major-weight minor-weight)
(search-max-in-compound-list
(key-finder* pitch-list
major-weight minor-weight)))
;;(key-finder
'(8 0 0 0 2 11 0 5 7 0 5 2) '(2 0 1 0 1 1 0 2 0 1 0 1) '(2 0 1 1 0 1 0 2 1 0
0.5 0.5))
#|
;;Krumhansl-Kessler
probe-tone profiles:
(key-finder
'(8 0 0 0
2 11 0 5 7 0 5 2)
'(6.35
2.23 3.48 2.33 4.38 4.09 2.52 5.19 2.39 3.66 2.29 2.88)
'(6.33
2.68 3.52 5.38 2.60 3.53 2.54 4.75 3.98 2.69 3.34 3.17))
;;============================================
;;Aarden-Essen
continuity profiles:
(key-finder
'(8 0 0 0
2 11 0 5 7 0 5 2)
'(17.7661
0.145624 14.9265 0.160186 19.8049 11.3587 0.291248 22.062 0.145624 8.15494
0.232998 4.95122)
'(18.2648
0.737619 14.0499 16.8599 0.702494 14.4362 0.702494 18.6161 4.56621 1.93186
7.37619 1.75623))
;;============================================
;;Temperley-Kostka-Payne
chord-based profiles:
(key-finder
'(8 0 0 0 2
11 0 5 7 0 5 2)
'(0.748
0.060 0.488 0.082 0.670 0.460 0.096 0.715 0.104 0.366 0.057 0.400)
'(0.712
0.084 0.474 0.618 0.049 0.460 0.105 0.747 0.404 0.067 0.133 0.330))
|#