Mercurial > hg > amuse
view tools/segmentation/methods.lisp @ 76:4ad1427d46d8
tools/segmentation: remove basic-segmenter
* remove last vestiges of basic-segmenter
* export new segmenter subclasses
darcs-hash:20070713113949-c0ce4-6386dbace0783bd252bfc7abf370cb580841f365.gz
author | Marcus Pearce <m.pearce@gold.ac.uk> |
---|---|
date | Fri, 13 Jul 2007 12:39:49 +0100 |
parents | 6b2ac9eef629 |
children | fd85f52d9f9d |
line wrap: on
line source
(in-package "AMUSE-SEGMENTATION") (defmethod boundary-time (segmenter (object anchored-period-designator)) (if (segments-beforep segmenter) (onset object) (cut-off object))) (defmethod boundary-time (segmenter (object moment-designator)) 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))))))