Mercurial > hg > amuse

--- a/amuse.asd	Tue Jul 10 11:08:56 2007 +0100
+++ b/amuse.asd	Fri Jul 13 11:07:51 2007 +0100
@@ -18,10 +18,16 @@
             ((:file "package")
              (:file "utils" :depends-on ("package"))
 	     (:file "n-grams" :depends-on ("package"))))
-   (:module tools
+   (:module tools
             :components
 	    ((:file "package")
-	     (:file "midi-output" :depends-on ("package"))))
+	     (:file "midi-output" :depends-on ("package"))
+	     (:module segmentation
+	              :components
+		      ((:file "package")
+		       (:file "classes" :depends-on ("package"))
+		       (:file "generics" :depends-on ("package"))
+		       (:file "methods" :depends-on ("package" "classes" "generics"))))))
    (:module implementations
             :components
             ((:module midi
--- a/base/generics.lisp	Tue Jul 10 11:08:56 2007 +0100
+++ b/base/generics.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -266,5 +266,4 @@

 ;;; Dynamics
 ;;; Voice
-;;; Boundary Strength (phrasing)
-
+;;; Boundary Strength (phrasing)
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/segmentation/classes.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -0,0 +1,18 @@
+(in-package "AMUSE-SEGMENTATION")
+
+(defclass segmenter () ()
+  (:documentation "Base class for identifying segment-boundary
+  methods."))
+
+(defclass basic-segmenter (segmenter)
+  ((direction :initarg :direction
+	      :initform :after
+	      :accessor %segmenter-direction)
+   (ground-truthp :initarg :ground-truthp
+		  :initform nil
+		  :accessor %segmenter-ground-truthp)
+   (method :initarg :method
+	   :accessor %segmenter-method))
+  (:documentation "Simple class for giving common segmenter
+  info. Method takes a moment-designator and a composition and
+  returns a positive number"))
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/segmentation/generics.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -0,0 +1,33 @@
+(in-package "AMUSE-SEGMENTATION")
+
+(defgeneric boundary-strength (segmenter object composition)
+  (:documentation "Returns a (positive?) number, with 0
+  indicating no boundary. N.B. Whether this indicates a boundary
+  before or after moment-designator is the responsibility of the
+  caller to know."))
+
+(defgeneric boundary-time (segmenter object)
+  (:documentation "Returns the moment that the value returned by
+  boundary-strength applies to if object is the second input to
+  the method. Essentially, this distinguishes between segmenters
+  that look to the beginning of a note and those that look at the
+  end.")
+
+(defgeneric ground-truth-segmenter-before (composition)
+  (:documentation "Returns the segmenter that, when put into
+  boundary-strength, supplies segmentation as given in a
+  ground truth for the composition. N.B. This needs to return one
+  segmenter only, so in cases of multiple ground truths, this
+  method must arbitrate."))
+
+(defgeneric ground-truth-segmenter-after (composition)
+  (:documentation "Returns the segmenter that, when put into
+  boundary-strength-after, supplies segmentation as given in a
+  ground truth for the composition. N.B. This needs to return one
+  segmenter only, so in cases of multiple ground truths, this
+  method must arbitrate."))
+
+(defgeneric ground-truth-segmenterp (segmenter)) ;; prob not necessary?
+(defgeneric segments-beforep (segmenter))
+(defgeneric segments-afterp (segmenter)
+  (:method (s) (not (segments-beforep s))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/segmentation/methods.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -0,0 +1,76 @@
+(in-package "AMUSE-SEGMENTATION")
+
+(defmethod boundary-strength ((segmenter basic-segmenter) object composition)
+  (funcall (%segmenter-method segmenter) object composition))
+
+(defmethod boundary-time ((segmenter basic-segmenter) (object anchored-period-designator))
+  (if (segments-beforep segmenter)
+      (onset object)
+      (cut-off object)))
+(defmethod boundary-time (segmenter (object moment-designator))
+  object)
+(defmethod ground-truth-segmenterp ((segmenter basic-segmenter))
+  (%segmenter-ground-truthp segmenter))
+(defmethod segments-beforep ((segmenter basic-segmenter))
+  (eq (%segmenter-direction segmenter) :before))
+
+(defun make-basic-segmenter (method &key (ground-truthp nil) (direction :after))
+  (make-instance 'basic-segmenter :method method :ground-truthp ground-truthp :direction direction))
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;;; Seriously made-up stuff (= dodgy)
+
+(defun map-segmenters (composition &key (start-boundary-segmenter nil) (end-boundary-segmenter nil))
+  (cond
+    ((and start-boundary-segmenter end-boundary-segmenter)
+     (%map-non-contiguous-segmenters composition start-boundary-segmenter end-boundary-segmenter))
+    (start-boundary-segmenter
+     (%map-start-segmenter composition start-boundary-segmenter))
+    (end-boundary-segmenter
+     (%map-end-segmenter composition end-boundary-segmenter))
+    (t (error "Map-segmenters called with no segmenters"))))
+
+(defun %map-start-segmenter (composition segmenter)
+  (let ((segments))
+    (sequence:dosequence (event composition (progn
+					      (setf (duration (car segments))
+						    (duration (time- (cut-off composition)
+								     (onset (car segments)))))
+					      (reverse segments)))
+      (when (> (boundary-strength segmenter event composition) 0)
+	(when segments
+	  (setf (duration (car segments))
+		(duration (time- (boundary-time segmenter event)
+				 (onset (car segments))))))
+	(push (make-instance 'anchored-period
+			     :time (timepoint (boundary-time segmenter event)))
+	      segments)))))
+
+(defun %map-end-segmenter (composition segmenter)
+  (let ((segments (list (make-instance 'anchored-period :time (timepoint composition)))))
+    (sequence:dosequence (event composition (reverse (cdr segments)))
+      (when (> (boundary-strength segmenter event composition) 0)
+	(setf (duration (car segments))
+	      (duration (time- (boundary-time segmenter event)
+			       (onset (car segments)))))
+	(push (make-instance 'anchored-period
+			     :time (timepoint (boundary-time segmenter event)))
+	      segments)))))
+
+(defun %map-non-contiguous-segmenters (composition start-boundary-segmenter end-boundary-segmenter)
+  ;; FIXME: crappy queue implementation
+  ;; FIXME: This only returns paired starts and ends. Should we
+  ;; process unpaired boundaries?
+  (let ((segments) (starts))
+    (sequence:dosequence (event composition (reverse segments))
+      (when (> (boundary-strength start-boundary-segmenter event composition) 0)
+	(setf (cdr (last starts))
+	      (list (boundary-time start-boundary-segmenter event))))
+      (when (> (boundary-strength end-boundary-segmenter event composition) 0)
+	(when starts
+	  (push (make-instance 'anchored-period
+			       :interval (amuse::duration (time- (boundary-time end-boundary-segmenter event)
+								 (car starts)))
+			       :time (timepoint (pop starts)))
+		segments))))))
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/segmentation/package.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -0,0 +1,13 @@
+(cl:defpackage #:amuse-segmentation
+  (:use #:common-lisp #:amuse #:amuse-utils #:midi)
+  (:export #:segmenter
+	   #:basic-segmenter
+	   #:boundary-strength
+	   #:boundary-time
+	   #:ground-truth-segmenter-before
+	   #:ground-truth-segmenter-after
+	   #:ground-truth-segmenterp
+	   #:segments-beforep
+	   #:segments-afterp
+	   #:make-basic-segmenter
+	   #:map-segmenters))
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/segmentation/simple-example.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -0,0 +1,73 @@
+(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.
+
+(defparameter *simple-segmenter*
+  (make-basic-segmenter #'simple-segmentsp :ground-truthp nil
+			:direction :before))
+
+(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))))
+
\ No newline at end of file
--- a/utils/utils.lisp	Tue Jul 10 11:08:56 2007 +0100
+++ b/utils/utils.lisp	Fri Jul 13 11:07:51 2007 +0100
@@ -20,7 +20,10 @@
 (defgeneric beats-to-seconds (object1 object2))
 (defmethod beats-to-seconds ((object1 anchored-period)
 			     (object2 constituent))
-  (let ((tempi (get-applicable-tempi object1 object2))
+  (let ((tempi (or (get-applicable-tempi object1 object2)
+		   (signal 'undefined-action
+			   :operation 'beats-to-seconds
+			   :datatype 'constituent)))
 	(s 0))
     (dolist (tempo tempi (/ s 1000000))
       (incf s (* (duration (period-intersection tempo object1))