d@74: (in-package "AMUSE-SEGMENTATION")
d@74: 
d@74: ;;;;;;;;;;;;;;;;;
d@74: ;; 
d@74: ;; Demo example: `simple segmenter'
d@74: ;;
d@74: ;; Simple segmenter segments a piece at long gaps between notes (where
d@74: ;; `gaps' are the amount of time between successive note-onsets).
d@74: ;;
d@74: ;; In this implementation, the modal gap-length is calculated (the
d@74: ;; highest is taken in cases of a tie) and a threshold is taken of 3.9
d@74: ;; times that length. An absolute gap of 1.5 seconds is also used if
d@74: ;; beats-to-seconds is available.
d@74: 
m@78: (defclass simple-segmenter (after-segmenter) ())
d@75: 
d@136: (defmethod boundary-strength ((segmenter simple-segmenter) (event moment) (composition composition))
d@75:   (declare (ignore segmenter))
d@75:   (multiple-value-bind (i-o-i mode i-o-i-rt)
d@75:       (inter-onset-intervals-for-simple-segmenter-with-cache composition)
d@75:     (if (or (eq event (elt composition 0))
d@75: 	    (> (cdr (assoc event i-o-i)) (* mode 3.9))
d@75: 	    (and i-o-i-rt (> (cdr (assoc event i-o-i-rt))
d@75: 			     1.5)))
d@75: 	1
d@75: 	0)))
d@74: 
d@74: ;; helper-functions
d@74: 
d@74: (defparameter *i-o-i-cache* (make-hash-table :weakness :KEY))
d@74: (defun inter-onset-intervals-for-simple-segmenter-with-cache (composition &key (rounding-divisor 1/4))
d@74:   (unless (gethash composition *i-o-i-cache*)
d@74:     (setf (gethash composition *i-o-i-cache*)
d@74: 	  (multiple-value-list (inter-onset-intervals-for-simple-segmenter composition
d@74: 									   :rounding-divisor rounding-divisor))))
d@74:   (values-list (gethash composition *i-o-i-cache*)))
d@74: 
d@74: (defgeneric inter-onset-intervals-for-simple-segmenter (composition &key rounding-divisor)
d@74:   (:documentation "Returns values: inter-onset-intervals, i-o-i
d@74:   mode and real-time-i-o-is. Both sets of i-o-is are alists
d@74:   of (<event> . i-o-i)"))
m@78: 
d@74: (defmethod inter-onset-intervals-for-simple-segmenter ((composition composition)
d@74: 						       &key (rounding-divisor 1/4))
d@74:   ;; FIXME: (vaguely) assumes monody
d@74:   (let ((i-o-i-list) (i-o-i-secs-list) (real-time t) (prev) (i-o-i-period)
d@77: 	(hits (make-hash-table))
d@74: 	(modal-value) (modal-count 0))
d@74:     (sequence:dosequence (event composition)
d@74:       (when prev
d@74: 	(setf i-o-i-period (inter-onset-interval prev event))
d@74: 	(when real-time
d@74: 	  (setf i-o-i-secs-list
d@74: 		(acons event (handler-case (beats-to-seconds i-o-i-period composition)
d@74: 			       ((or undefined-action insufficient-information) ()
d@74: 				   (setf real-time nil)))
d@74: 		       i-o-i-secs-list)))
d@74: 	(setf i-o-i-list (acons event (duration i-o-i-period) i-o-i-list))
d@77: 	(when (> (round (duration i-o-i-period) rounding-divisor) 0)
d@74: 	  ;; larger than 32 crotchets doesn't really count as a useful
d@74: 	  ;; i-o-i for our purposes (or am I just doing this because
d@77: 	  ;; I'm using an array).
m@78: 	  (if (gethash (round (duration i-o-i-period) rounding-divisor) hits)
m@78: 	      (incf (gethash (round (duration i-o-i-period) rounding-divisor) hits))
m@78: 	      (setf (gethash (round (duration i-o-i-period) rounding-divisor) hits) 1))))
d@74:       (setf prev event))
m@78:     ;; we want the highest mode if there are several
m@78:     (maphash #'(lambda (key value) 
m@78:                  (when (> value modal-count)
m@78:                    (setf modal-value key 
m@78:                          modal-count value)))
m@78:              hits)
d@74:     (values i-o-i-list (* modal-value rounding-divisor) (and real-time i-o-i-secs-list))))