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

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

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

;;Pitch Track from SPEAR files

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

;;Mauricio Rodriguez - 2011

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

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

;;analyze-spear-file []

;;(analyze-spear-file)

;;Code:

(defvar *string-sequence* nil)

(defun choose-file-dialog (&key (prompt "Open file") (operation :open))

(let ((screen (capi:convert-to-screen)))

(capi:screen-width screen)

(capi:screen-height screen)

(capi:prompt-for-file prompt

:operation operation

:owner screen

:filters '("All Files" "*.*"))))

(defun load-text-file* ()

(setf *string-sequence* nil)

(setf *string-sequence*

(with-open-file (input (choose-file-dialog)

:direction :input)

(read-from input))))

(defun read-from (stream)

(let ((current-line (read-line stream nil)))

(unless (not current-line)

(cons current-line

(read-from stream)))))

;;(load-text-file*)

(defun load-text-file ()

(load-text-file*)

(loop for x in *string-sequence*

collect (read-from-string (concatenate 'string "(" x ")"))))

;;(load-text-file)

(defun append-data (list)

(if (endp list)

nil

(cons (second list) (append-data (rest (rest list))))))

(defun data-text-file (list)

(let ((non-header (nthcdr 4 list)))

(append-data non-header)))

(defun get-delta-time (list)

(if (endp list)

nil

(cons (first list) (get-delta-time (nthcdr 3 list)))))

(defun get-frequency (list)

(if (endp list)

nil

(cons (second list) (get-frequency (nthcdr 3 list)))))

(defun get-amplitude (list)

(if (endp list)

nil

(cons (third list) (get-amplitude (nthcdr 3 list)))))

(defvar *store-data* nil)

(defun load-data ()

(setf *store-data* nil)

(setf *store-data* (data-text-file (load-text-file))))

;;(load-data)

;;*store-data*

(defun time-table (list)

(sort (remove-duplicates (loop for alpha in (mapcar #'(lambda (x) (get-delta-time x)) list)

append alpha)) #'<))

(defun grouping (list)

(cond ((endp list) nil)

(t (append (list (list (first list) (second list) (third list)))

(grouping (nthcdr 3 list))))))

#|

(defun filter-amplitude-threshold* (list threshold)

(let ((group-list (grouping list)))

(loop for x in group-list

when (or (>= (third x) threshold)

(equal (third x) 0.0))

collect x)))

|#

(defun filter-amplitude-threshold (list threshold)

(let* ((group-list (grouping list))

(filter (loop for x in group-list

when (or (>= (third x) threshold)

(equal (third x) 0.0))

collect x)))

(loop for y in filter

append y)))

(defun locate-timing (time-point list)

(loop for x in list

when (= time-point (first x))

collect x))

;;(locate-timing 0.0 (grouping (loop for beta in (mapcar #'(lambda (x) (filter-amplitude-threshold x 0.005)) *store-data*) append beta)))

;;(locate-timing 0.137438 (grouping (loop for beta in (mapcar #'(lambda (x) (filter-amplitude-threshold x 0.005)) *store-data*) append beta)))

(defun get-max-amplitude (list)

(let ((maximum (apply #'max (loop for x in list

collect (third x)))))

(loop for alpha in list

when (equal maximum (third alpha))

collect alpha)))

(defun get-max-frequency (list)

(let ((maximum (apply #'max (loop for x in list

collect (second x)))))

(loop for alpha in list

when (equal maximum (second alpha))

collect alpha)))

(defun locate-timing-filter* (list)

(let ((max-amplitude (get-max-amplitude list)))

(if (= (length max-amplitude) 1)

(first max-amplitude)

(first (get-max-frequency max-amplitude)))))

(defun partials-data (amplitude-threshold list)

(let* ((filter-threshold (mapcar #'(lambda (x) (filter-amplitude-threshold x amplitude-threshold)) list))

(time-points (time-table filter-threshold))

(group-data (grouping (loop for x in filter-threshold

append x))))

(loop for y in time-points

collect (locate-timing-filter* (locate-timing y group-data)))))

;;(partials-data 0.005 *store-data*)

#|

(defun continuity-p (reference-value input)

(or (= reference-value input)

(and (> input reference-value) (<= input (+ reference-value 1)))

(and (< input reference-value) (>= input (- reference-value 1)))))

(defun continuity-p (reference-value input)

(cond ((equal input 'nil) t)

((or (= reference-value input)

(and (> input reference-value) (<= input (+ reference-value 1)))

(and (< input reference-value) (>= input (- reference-value 1)))) t)

(t 'nil)))

|#

(defun continuity-p (reference-value input resolution)

(cond ((equal input 'nil) t)

((or (= reference-value input)

(and (> input reference-value) (<= input (+ reference-value resolution)))

(and (< input reference-value) (>= input (- reference-value resolution)))) t)

(t 'nil)))

#|

(defun sequence-continuity (list)

(do ((reference-value (first list) (first current-list))

(current-list (rest list) (rest current-list))

(output (list (first list)) (cons (first current-list) output)))

((or (endp current-list) (not (continuity-p reference-value (first current-list)))) (reverse output))))

|#

(defun sequence-continuity (list resolution)

(do ((reference-value (first list) (first current-list))

(current-list (rest list) (rest current-list))

(output (list (first list)) (cons (first current-list) output)))

((or (endp current-list) (not (continuity-p reference-value (first current-list) resolution))) (reverse output))))

#|

(defun group-continuity (list)

(do ((output nil (cons (sequence-continuity current-list) output))

(current-list list (nthcdr (length (sequence-continuity current-list)) current-list)))

((endp current-list) (reverse output))))

|#

(defun group-continuity (list resolution)

(do ((output nil (cons (sequence-continuity current-list resolution) output))

(current-list list (nthcdr (length (sequence-continuity current-list resolution)) current-list)))

((endp current-list) (reverse output))))

(defun group-frequency-continuity (list resolution)

(group-continuity

(loop for x in list

collect (second x))

resolution))

(defun length-index (list)

(loop for x in list

collect (length x)))

(defun gather-n (list n)

(if (= n 0) nil

(cons (first list) (gather-n (rest list) (1- n)))))

(defun group-list (list index-group)

(do ((current-list list (nthcdr (first indexing) current-list))

(indexing index-group (rest indexing))

(output nil (cons (gather-n current-list (first indexing)) output)))

((endp indexing) (reverse output))))

(defun flat-once (compound-list)

(loop for x in compound-list

collect (loop for y in x

append y)))

#|

(defun group-partials (amplitude-threshold list resolution)

(let* ((data (partials-data amplitude-threshold list))

(index (length-index (group-frequency-continuity data resolution))))

(flat-once (group-list data index))))

;;(group-partials 0.005 *store-data* 40)

|#

(defun group-partials (amplitude-threshold list resolution)

(let* ((data (partials-data amplitude-threshold list))

(index (length-index (group-frequency-continuity data resolution))))

(group-list data index)))

;;(group-partials 0.005 *store-data* 40)

(defun choose-new-file-dialog (&key (prompt "Save File") (operation :save))

(choose-file-dialog :prompt prompt :operation operation))

(defun flatten-list (list)

(cond ((endp list) nil)

((listp (first list))

(append (flatten-list (first list))

(flatten-list (rest list))))

(t (cons (first list)

(flatten-list (rest list))))))

(defun spear-format (amplitude-threshold resolution)

(let ((partials (group-partials amplitude-threshold *store-data* resolution)))

(with-open-file (output (choose-new-file-dialog)

:direction :output

:if-exists :supersede)

(do ((current-list partials (rest current-list))

(index 0 (+ 1 index))

(printing

(progn

(format output "~&~a" "par-text-partials-format")

(format output "~&~a" "point-type time frequency amplitude")

(format output "~&~a ~a" "partials-count" (length partials))

(format output "~&~a" "partials-data"))

(progn

(format output "~&~a ~a ~,6f ~,6f"

index

(length (first current-list))

(third (first (last (first current-list))))

(first (first (last (first current-list)))))

(format output "~&~{~,6f ~}" (flatten-list (first current-list))))))

((endp current-list) t)))))

(defun convert-frequency-to-midi (frequency)

(+ 69 (* 12 (/ (log (/ frequency 440.0) 10) (log 2 10)))))

(defun frequency-to-midi (input-list)

(mapcar #'convert-frequency-to-midi input-list))

(defun mean-value (list)

(/ (apply #'+ list) (float (length list))))

(defun mean-frequency (list)

(loop for x in list

collect (convert-frequency-to-midi (mean-value (get-frequency x)))))

;;(load-data)

;;*store-data*

;;(spear-format 0.005 40)

;;(length (mean-frequency *store-data*))

(defun take-n (n input)

(if (zerop n)

'nil

(cons (first input) (take-n (- n 1) (rest input)))))

(defun normalize (x a b c d)

(+ c (* (- x a) (/ (float (- d c)) (- b a)))))

(defun normalize-list-frequency (input)

(let ((minimum (apply #'min input))

(maximum (apply #'max input)))

(mapcar #'(lambda (x) (normalize x minimum maximum 0.0 1.0)) input)))

(defun save-pitch-analysis ()

(with-open-file

(output (make-pathname :directory '(:absolute "users" "home" "directory")

:name "pitch-analysis"

:type "txt")

:direction :output

:if-exists :supersede)

(loop for x in (normalize-list-frequency (mean-frequency *store-data*))

for string = "~,2f" then " ~&~,2f"

do (format output string x))

't))

;;(save-pitch-analysis)

(defun analyze-spear-file ()

(load-data)

(spear-format 0.005 40)

(save-pitch-analysis))

;;(analyze-spear-file)