;;********************************************

;;********************************************

;;////////////////////////////////////////////

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

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

|#