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

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

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

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

 

|#