view tools/segmentation/simple-example.lisp @ 75:6b2ac9eef629

Improved segmentation implementation (ta, MTP)

darcs-hash:20070713112322-f76cc-42a6ead0d8822164af5554d11ca98f93a1f96359.gz

(in-package "AMUSE-SEGMENTATION")

;;;;;;;;;;;;;;;;;
;; 
;; Demo example: `simple segmenter'
;;
;; Simple segmenter segments a piece at long gaps between notes (where
;; `gaps' are the amount of time between successive note-onsets).
;;
;; In this implementation, the modal gap-length is calculated (the
;; highest is taken in cases of a tie) and a threshold is taken of 3.9
;; times that length. An absolute gap of 1.5 seconds is also used if
;; beats-to-seconds is available.

(defclass simple-segmenter (before-segmenter) ())

(defmethod boundary-strength ((segmenter simple-segmenter) (event moment-designator) (composition composition))
  (declare (ignore segmenter))
  (multiple-value-bind (i-o-i mode i-o-i-rt)
      (inter-onset-intervals-for-simple-segmenter-with-cache composition)
    (if (or (eq event (elt composition 0))
	    (> (cdr (assoc event i-o-i)) (* mode 3.9))
	    (and i-o-i-rt (> (cdr (assoc event i-o-i-rt))
			     1.5)))
	1
	0)))

(defgeneric simple-segmentsp (event composition))
(defmethod simple-segmentsp ((event moment-designator) (composition composition))
  (multiple-value-bind (i-o-i mode i-o-i-rt)
      (inter-onset-intervals-for-simple-segmenter-with-cache composition)
    (if (or (eq event (elt composition 0))
	    (> (cdr (assoc event i-o-i)) (* mode 3.9))
	    (and i-o-i-rt (> (cdr (assoc event i-o-i-rt))
			     1.5)))
	1
	0)))

;; helper-functions

(defparameter *i-o-i-cache* (make-hash-table :weakness :KEY))
(defun inter-onset-intervals-for-simple-segmenter-with-cache (composition &key (rounding-divisor 1/4))
  (unless (gethash composition *i-o-i-cache*)
    (setf (gethash composition *i-o-i-cache*)
	  (multiple-value-list (inter-onset-intervals-for-simple-segmenter composition
									   :rounding-divisor rounding-divisor))))
  (values-list (gethash composition *i-o-i-cache*)))

(defgeneric inter-onset-intervals-for-simple-segmenter (composition &key rounding-divisor)
  (:documentation "Returns values: inter-onset-intervals, i-o-i
  mode and real-time-i-o-is. Both sets of i-o-is are alists
  of (<event> . i-o-i)"))
(defmethod inter-onset-intervals-for-simple-segmenter ((composition composition)
						       &key (rounding-divisor 1/4))
  ;; FIXME: (vaguely) assumes monody
  (let ((i-o-i-list) (i-o-i-secs-list) (real-time t) (prev) (i-o-i-period)
	(hits (make-array (1+ (/ 32 rounding-divisor))))
	(modal-value) (modal-count 0))
    (sequence:dosequence (event composition)
      (when prev
	(setf i-o-i-period (inter-onset-interval prev event))
	(when real-time
	  (setf i-o-i-secs-list
		(acons event (handler-case (beats-to-seconds i-o-i-period composition)
			       ((or undefined-action insufficient-information) ()
				   (setf real-time nil)))
		       i-o-i-secs-list)))
	(setf i-o-i-list (acons event (duration i-o-i-period) i-o-i-list))
	(when (and (< (round (duration i-o-i-period) rounding-divisor) 32)
		   (> (round (duration i-o-i-period) rounding-divisor) 0))
	  ;; larger than 32 crotchets doesn't really count as a useful
	  ;; i-o-i for our purposes (or am I just doing this because
	  ;; I'm using an array.
	  (incf (aref hits (round (duration i-o-i-period) rounding-divisor)))))
      (setf prev event))
    (loop for i downfrom (1- (length hits)) to 0
       ;; we want the highest mode if there are several
       when (> (aref hits i) modal-count)
       do (setf modal-value i
		modal-count (aref hits i)))
    (values i-o-i-list (* modal-value rounding-divisor) (and real-time i-o-i-secs-list))))