view tools/segmentation/methods.lisp @ 136:fd85f52d9f9d

Class revolution

* PITCH-DESIGNATOR -> PITCH (PITCH removed)
* MOMENT-DESIGNATOR -> MOMENT , MOMENT -> STANDARD-MOMENT
* PERIOD-DESIGNATOR -> PERIOD , PERIOD -> STANDARD-PERIOD
* ANCHORED-PERIOD-DESIGNATOR -> ANCHORED-PERIOD , ANCHORED-PERIOD -> STANDARD-ANCHORED-PERIOD
* FLOATING-PERIOD removed
* TIME-SIGNATURE-DESIGNATOR -> TIME-SIGNATURE & TIME-SIGNATURE-PERIOD
* TIME-SIGNATURE -> STANDARD-TIME-SIGNATURE & STANDARD-TIME-SIGNATURE-PERIOD
* KEY-SIGNATURE-DESIGNATOR -> KEY-SIGNATURE (& ...-PERIOD)
* KEY-SIGNATURE -> STANDARD-KEY-SIGNATURE (& ...-PERIOD)
* TEMPO now abstract (& TEMPO-PERIOD)
* STANDARD-TEMPO AND STANDARD-TEMPO-PERIOD
* COMPOSITION, CONSTITUENT & TIME-ORDERED-CONSTITUENT all have STANDARD- forms

make-x methods and specialisers changes appropriately

darcs-hash:20070831142943-f76cc-7be0d08963de06d87b36e4922076287d565c7ee2.gz

(in-package "AMUSE-SEGMENTATION")

(defmethod boundary-time (segmenter (object anchored-period))
  (if (segments-beforep segmenter)
      (onset object)
      (cut-off object)))
(defmethod boundary-time (segmenter (object moment))
  object)

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