annotate utils/utils.lisp @ 37:9aeb5bff013a

Added levenshtein distance with cost functions

darcs-hash:20070516124658-f76cc-8b96080b5c4018f2077650697bec4d1213917505.gz

;;; General purpose utilities 

(cl:in-package #:amuse-utils) 

;; Booleans (for filters)
(defgeneric pitchedp (event)
  (:method (e) (declare (ignore e)) nil))
(defmethod pitchedp ((event amuse:pitched-event))
  T)
(defgeneric unpitchedp (event)
  (:method (e) (not (pitchedp e))))

;; Rhythm methods
(defgeneric crotchets-in-a-bar (time-signature))
(defmethod crotchets-in-a-bar ((time-signature basic-time-signature))
  (let ((num (time-signature-numerator time-signature))
	(den (time-signature-denominator time-signature)))
    (* num (/ 4 den))))

(defgeneric beats-to-seconds (object1 object2))
(defmethod beats-to-seconds ((object1 anchored-period)
			     (object2 constituent))
  (let ((tempi (get-applicable-tempi object1 object2))
	(s 0))
    (dolist (tempo tempi (/ s 1000000))
      (incf s (* (duration (period-intersection tempo object1))
		 (amuse:microseconds-per-crotchet tempo))))))
(defmethod beats-to-seconds ((object1 moment)
			     (object2 constituent))
  (beats-to-seconds (make-anchored-period 0
					  (timepoint object1))
		    object2))
					  

;; Pitch methods

(defgeneric sounding-events (anchored-period sequence))
(defmethod sounding-events ((anchored-period anchored-period)
			    (sequence composition))
  (let ((sounding))
    (sequence:dosequence (event sequence (reverse sounding))
      (cond
	((time>= event (cut-off anchored-period))
	 (return-from sounding-events (reverse sounding)))
	((period-intersection anchored-period event)
	 (push event sounding))))))

(defgeneric midi-pitch-distribution (anchored-period composition))
(defmethod midi-pitch-distribution ((anchored-period anchored-period)
				    composition)
  (let ((pitches (make-array 128 :initial-element 0)))
    (dolist (event (remove-if #'unpitchedp (sounding-events anchored-period composition)) pitches)
      (let ((overlap (period-intersection anchored-period event)))
	(if overlap
	    (incf (aref pitches (midi-pitch-number event))
		  (duration overlap))
	    (if (= (duration event) 0)
		(format t "~%Note ~D beats in has no duration" (timepoint event))
		(error "This function has gone wrong - looking for overlaps that don't exist")))))))

(defgeneric pitch-class-distribution (anchored-period composition))
(defmethod pitch-class-distribution ((anchored-period anchored-period)
				     composition)
  (let ((pitches (make-array 12 :initial-element 0)))
    (dolist (event (remove-if #'unpitchedp (sounding-events anchored-period composition)) pitches)
      (let ((overlap (period-intersection anchored-period event)))
	(if overlap
	    (incf (aref pitches (pitch-class event))
		  (duration overlap))
	    (if (= (duration event) 0)
		(format t "~%Note ~D beats in has no duration" (timepoint event))
		(error "This function has gone wrong - looking for overlaps that don't exist")))))))

(defun normalised-midi-pitch-distribution (object1 object2)
  (normalise-vector (midi-pitch-distribution object1 object2)))
(defun normalised-pitch-class-distribution (object1 object2)
  (normalise-vector (pitch-class-distribution object1 object2)))
(defun normalise-vector (vector &optional (target-sum 1))
  (let ((total (loop for i from 0 to (1- (length vector))
		  sum (aref vector i))))
    (cond
      ((= total target-sum)
       vector)
      ((= total 0)
       (make-array (length vector)
		   :initial-element (/ target-sum (length vector))))
      (t
       (map 'vector #'(lambda (x) (* x (/ target-sum total))) vector)))))

;; Not as simple as it seems - have to take into account numbering
;; practices and leading silences in representations where bar number
;; isn't part of the explicit structure.
(defgeneric bar-number (moment composition))
(defgeneric bar-onset (bar-number composition))

(defgeneric bass-note (anchored-period composition))

(defun vector-correlation (vector1 vector2)
  ;; useful for Krumhansl-Schmukler-like calculations
  (assert (= (length vector1) (length vector2)))
  (let* ((n (length vector1))
	 (sum-x (loop for i from 0 to (1- n)
		      sum (aref vector1 i)))
	 (sum-y (loop for i from 0 to (1- n)
		      sum (aref vector2 i)))
	 (equation-bl (sqrt (- (* n
				  (loop for i from 0 to (1- n)
					sum (expt (aref vector1 i) 2)))				  
			       (expt sum-x 2))))
	 (equation-br (sqrt (- (* n
				  (loop for i from 0 to (1- n)
					sum (expt (aref vector2 i) 2)))
			       (expt sum-y 2))))
	 (equation-b (* equation-br equation-bl))
	 (equation-tr (* sum-x sum-y))
	 (equation-t 0)
	 (results-array (make-array n)))
    (do ((i 0 (1+ i)))
	((= i n) results-array)
      (setf equation-t (- (* n (loop for j from 0 to (1- n)
				       sum (* (aref vector1 (mod (+ i j) n))
					      (aref vector2 j))))
			  equation-tr)
	    (aref results-array i) (/ equation-t equation-b)))))


(defparameter *krumhansl-schmuckler-major-key*
  (make-array 12 :initial-contents '(6.33 2.68 3.52 5.38 2.6 3.53 2.54 4.75 3.98 2.69 3.34 3.17)))

(defparameter *krumhansl-schmuckler-minor-key*
  (make-array 12 :initial-contents '(6.35 2.23 3.48 2.33 4.38 4.09 2.52 5.19 2.39 3.66 2.29 2.88)))

(defun krumhansl-key-finder (anchored-period composition
			     &key (major *krumhansl-schmuckler-major-key*)
			     (minor *krumhansl-schmuckler-minor-key*))
  (let* ((key) (best-score -1)
	 (pitches (pitch-class-distribution anchored-period composition))
	 (majors (vector-correlation pitches major))
	 (minors (vector-correlation pitches minor)))
    (loop for i from 0 to 11
	  do (when (> (aref majors i) best-score)
	       (setf key (list i :major)
		     best-score (aref majors i))))
    (loop for i from 0 to 11
	  do (when (> (aref minors i) best-score)
	       (setf key (list i :minor)
		     best-score (aref minors i))))
    key))

(defun levenshtein-distance (s1 s2 &key (insertion-cost 1)
			  (insertion-function) (deletion-cost 1)
			  (deletion-function) (substitution-cost 1)
			  (substitution-test #'equal) (substitution-function))
  ;; This is an implementation of the Levenshtein distance measure
  ;; based on the cliki asdf package, itself based on the wikipedia
  ;; scheme example of the same algorithm. This version is generalised
  ;; such that operations costs may take constant or calculated
  ;; values. If insertion-function, deletion-function or
  ;; substitution-test are specified, the applicable cost values are
  ;; ignored and the function output is used instead.
  (let* ((width (1+ (length s1)))
	 (height (1+ (length s2)))
	 (d (make-array (list height width))))
    (dotimes (x width)
      (setf (aref d 0 x) (* x deletion-cost)))
    (dotimes (y height)
      (setf (aref d y 0) (* y insertion-cost)))
    (dotimes (x (length s1))
      (dotimes (y (length s2))
	(setf (aref d (1+ y) (1+ x))
	      (min (+ (if insertion-function
			  (apply insertion-function (elt s1 x))
			  insertion-cost)
		      (aref d y (1+ x)))
		   (+ (if deletion-function
			  (apply deletion-function (elt s2 y))
			  deletion-cost)
		      (aref d (1+ y) x))
		   (+ (aref d y x)
		      (if substitution-function
			  (apply substitution-function (list (elt s1 x) (elt s2 y)))
			  (if (apply substitution-test (list (elt s1 x) (elt s2 y)))
			      0
			      substitution-cost)))))))
    (aref d (1- height) (1- width))))