view utils/utils.lisp @ 61:c911d65ae94d

pointy-clicky misspelling correction

darcs-hash:20070627102839-dc3a5-16cb5156dafee4b4a1aa3442274fab6c7260ed9c.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)))
    (if (= equation-b 0)
	(make-array 12 :initial-element 0)
	(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-minor-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-major-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))))
    (values key (key->midi-key-signature key anchored-period))))

(defvar *line-of-fifths* (list 1 8 3 10 5 0 7 2 9 4 11 6))

(defun key->midi-key-signature (key anchored-period)
  (let* ((tonic (car key))
         (mode (cadr key))
         (sharps (- (ecase mode
                      (:major (position tonic *line-of-fifths*))
                      (:minor (position (mod (- tonic 9) 12) *line-of-fifths*)))
                    5))
         (mode (ecase mode (:major 0) (:minor 9))))
    (amuse:make-midi-key-signature sharps mode 
                                   (timepoint anchored-period) 
                                   (duration anchored-period))))

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

;;;;;;;;;;;;;;;;;;;;;;
;;
;; More experimental (from amuse-geerdes)
;;
;; Monody functions

(defun monodificate (composition)
  (let ((events-bags) (latest-cut-off))
  ;; - Filter out very short notes (<50ms) 
  ;; - If there are notes with the same onset time or a large
  ;;   proportion (e.g. >25%) of the notes in the segment have
  ;;   overlapping durations (of >75%), do for every simultaneous or
  ;;   overlapping pair of notes
  ;; -- if one note is louder than the other note (e.g. quieter note
  ;;    <75% of louder one) select it as melody note
  ;; -- else select note with higher pitch
  ;; [FIXME: I'm ignoring overlaps for the time being]
  ;; - For non-simultaneous notes with little overlap, set note ends
  ;;   to beginning of of onset of next (overlapping) note.

  ;; STEP 1: 
  ;; `Filter out very short notes (<50ms)' and find `segments' for
  ;; further filtering.
    (sequence::dosequence (event composition)
      (when (> (beats-to-seconds event composition)
	       1/20)
	(if (or (not latest-cut-off)
		(time> (onset event) latest-cut-off))
	    (push (list event) events-bags)
	    (push event (car events-bags)))
	(when (or (not latest-cut-off)
		  (time> (cut-off event) latest-cut-off))
	  (setf latest-cut-off (cut-off event)))))
    ;; Now check each segment for overlaps and
    ;; simultanaieties. N.B. this is a reverse list of reversed
    ;; lists.
    (let ((adjusted-bags))
      (dolist (events-bag events-bags)
	(setf events-bag (reverse events-bag))
	(let ((polyphonic-p (check-events-bag-for-polyphony events-bag)))
	  (cond
	    (polyphonic-p
	     (push (resolve-polyphony events-bag composition) adjusted-bags))
	    (t
	     (if (cdr events-bag)		   
		 (push (adjust-durations events-bag) adjusted-bags)
		 (push events-bag adjusted-bags))))))
      (apply #'nconc adjusted-bags))))

(defun resolve-polyphony (event-list composition)
  (do ((i 0 (1+ i)))
      ((>= i (length event-list)) event-list)
    (let ((event (nth i event-list)))
      (do ((j (1+ i) (1+ j)))
	  ((or (>= j (length event-list))
	       (time>= (onset (nth j event-list))
		       (cut-off event))))
	(let* ((event-2 (nth j event-list))
	       (inter-onset (time- (onset event-2) (onset event))))
	  (cond
	    ((and inter-onset
		  (< (* 2 (duration inter-onset))
		      (duration event))
		  (< (* 2 (duration inter-onset))
		      (duration event-2))
		  (< (beats-to-seconds inter-onset composition)
		      1/8))
	     ;; This is clearly polyphony
	     (cond
	       ((significantly-louderp event-2 event)
		;; Take event-2
		(setf event-list (remove event event-list))
		(decf i)
		(return))
	       ((significantly-louderp event event-2)
		;; Take event
		(setf event-list (remove event-2 event-list))
		(decf j))
	       ((pitch> event event-2)
		;; Take event
		(setf event-list (remove event-2 event-list))
		(decf j))
	       (t
		;; Take event-2
		(setf event-list (remove event event-list))
		(decf i)
		(return))))
	    (t
	     (cond
	       ((substantially-louderp event-2 event)
		;; Take event-2
		(setf event-list (remove event event-list))
		(decf i)
		(return))
	       ((substantially-louderp event event-2)
		;; Take event
		(setf event-list (remove event-2 event-list))
		(decf j))
	       (t
		;; Take both
		(let ((event-overlap (period-intersection event event-2)))
		  (when event-overlap
		    (setf (duration event)
			  (duration (time- event-overlap event))))))))))))))

(defgeneric significantly-louderp (event1 event2)
  ;; noticably louder
  (:method (e1 e2) (declare (ignore e1 e2)) nil))

(defgeneric substantially-louderp (event1 event2)
  ;; much louder
  (:method (e1 e2) (declare (ignore e1 e2)) nil))

(defun adjust-durations (events-list)
  (do* ((old-list events-list (cdr old-list))
	(event (first old-list) (first old-list))
	(event-2 (second old-list) (second old-list)))
       ((not event-2) events-list)
    (let ((event-overlap (period-intersection event event-2)))
      (when event-overlap
	(setf (duration event)
	      (duration (time- event-overlap event)))))))

(defun check-events-bag-for-polyphony (events-bag)
  (let ((overlaps (make-array (length events-bag) :initial-element nil)))
    (when (= (length events-bag) 1)
      ;; obviously no overlaps
      (return-from check-events-bag-for-polyphony nil))
    (unless (= (length (remove-duplicates events-bag :test #'time=))
	       (length events-bag))
      ;; Duplicated onsets
      (return-from check-events-bag-for-polyphony 'T))
    ;; Now for the main bit
    (do* ((events events-bag (cdr events))
	  (i 0 (1+ i))
	  (event (car events) (car events)))
	 ((null (cdr events)))
      (unless (and (aref overlaps i)
		   (= (aref overlaps i) 1))
	;; Would mean we already have a maximal value
	;; and don't need any more checks
	(do* ((events-2 (cdr events) (cdr events-2))
	      (j (1+ i) (1+ j))
	      (event-2 (car events-2) (car events-2)))
	     ((null events-2))
	  (when (time>= (onset event-2) (cut-off event))
	    ;; So no more overlaps
	    (return))
	  (let ((shorter (if (duration< event event-2)
			     i
			     j))
		(overlap (/ (duration (period-intersection event event-2))
			    (min (duration event) (duration event-2)))))
	    ;; only look at pairings for the shorter note. This can
	    ;; have odd side effects, but means we never
	    ;; under-represent an overlap (I think)
	    (when (or (not (aref overlaps shorter))
		      (>= overlap (aref overlaps shorter)))
	      (setf (aref overlaps shorter) overlap)
	      (when (and (= shorter i)
			 (= overlap 1))
		;; Maximum value - we can stop
		(return)))))))
    (let ((total 0) (overs 0))
      (loop for i from 0 to (1- (length events-bag))
	 do (when (aref overlaps i)
	      (incf total)
	      (when (>= (aref overlaps i) 3/4)
		(incf overs))))
      (if (and (> total 0)
	       (>= (/ overs total)
		   1/4))
	  'T
	  'nil))))

(defgeneric inter-onset-intervals (composition &key rounding-divisor))
(defmethod inter-onset-intervals ((composition composition) &key (rounding-divisor 1/4))
  ;; returns values - list inter-onset intervals in beats, modal i-o-i
  ;; and i-o-is in seconds.
  ;; ** Only makes sense for monodic music
  ;; FIXME: Should this keep in objects or am I right to make numbers
  ;; here?
  ;; FIXME: Should I (do I) filter out 0s?
  (let ((i-o-i-list) (i-o-i-secs-list) (prev)
	(hits (make-array (/ 32 rounding-divisor))))
    (loop for event being the elements of composition
       do (progn
	    (when prev
	      (let* ((i-o-i-period (inter-onset-interval prev event))
		     (i-o-i (duration i-o-i-period))
		     (i-o-i-secs (amuse-utils:beats-to-seconds i-o-i-period composition)))
		(when (= i-o-i-secs 0)
		  (format t "~D, ~D -- " (timepoint prev) (timepoint event)))
		(push i-o-i i-o-i-list)
		(push i-o-i-secs i-o-i-secs-list)
		(when (< i-o-i 32)
		  ;; Not really interested in very long results for the
		  ;; modal value anyway.
		  (incf (aref hits (round i-o-i rounding-divisor))))))
	    (setf prev event)))
    (let ((mode '(0 0)))
      ;; we want the position of the highest mode
      (loop for i downfrom (1- (length hits)) to 0
	 when (> (aref hits i) (car mode))
	 do (setf mode (list (aref hits i) i)))
      (values (reverse i-o-i-list)
	      (* (cadr mode) rounding-divisor)
	      (reverse i-o-i-secs-list)))))

(defun pitch-interval-list (composition)
  (let ((intervals)
	(previous-event))
    (sequence:dosequence (event composition (reverse intervals))
      (when previous-event
	(push (span (pitch- event previous-event))
	      intervals))
      (setf previous-event event))))