d@74: (in-package "AMUSE-SEGMENTATION")
d@74: 
d@136: (defmethod boundary-time (segmenter (object anchored-period))
d@74:   (if (segments-beforep segmenter)
d@74:       (onset object)
d@74:       (cut-off object)))
d@136: (defmethod boundary-time (segmenter (object moment))
d@74:   object)
d@74: 
d@74: ;;;;;;;;;;;;;;;;;;;;;;;
d@74: ;;; Seriously made-up stuff (= dodgy)
d@74: 
d@74: (defun map-segmenters (composition &key (start-boundary-segmenter nil) (end-boundary-segmenter nil))
d@74:   (cond
d@74:     ((and start-boundary-segmenter end-boundary-segmenter)
d@161:      #+nil (%map-non-contiguous-segmenters composition start-boundary-segmenter end-boundary-segmenter)
d@161:      ;; hacky fix for broken code
d@161:      (remove-duplicates (nconc (%map-start-segmenter composition start-boundary-segmenter)
d@161: 			       (%map-end-segmenter composition end-boundary-segmenter))
d@161: 			:test #'period=))
d@74:     (start-boundary-segmenter
d@74:      (%map-start-segmenter composition start-boundary-segmenter))
d@74:     (end-boundary-segmenter
d@74:      (%map-end-segmenter composition end-boundary-segmenter))
d@74:     (t (error "Map-segmenters called with no segmenters"))))
d@74: 
d@74: (defun %map-start-segmenter (composition segmenter)
d@74:   (let ((segments))
d@74:     (sequence:dosequence (event composition (progn
d@74: 					      (setf (duration (car segments))
d@74: 						    (duration (time- (cut-off composition)
d@74: 								     (onset (car segments)))))
d@74: 					      (reverse segments)))
d@74:       (when (> (boundary-strength segmenter event composition) 0)
d@74: 	(when segments
d@74: 	  (setf (duration (car segments))
d@74: 		(duration (time- (boundary-time segmenter event)
d@74: 				 (onset (car segments))))))
d@161: 	(push (make-instance 'standard-anchored-period
d@74: 			     :time (timepoint (boundary-time segmenter event)))
d@74: 	      segments)))))
d@74: 
d@74: (defun %map-end-segmenter (composition segmenter)
d@161:   (let ((segments (list (make-instance 'standard-anchored-period :time (timepoint composition)))))
d@74:     (sequence:dosequence (event composition (reverse (cdr segments)))
d@74:       (when (> (boundary-strength segmenter event composition) 0)
d@74: 	(setf (duration (car segments))
d@74: 	      (duration (time- (boundary-time segmenter event)
d@74: 			       (onset (car segments)))))
d@161: 	(push (make-instance 'standard-anchored-period
d@74: 			     :time (timepoint (boundary-time segmenter event)))
d@74: 	      segments)))))
d@74: 
d@74: (defun %map-non-contiguous-segmenters (composition start-boundary-segmenter end-boundary-segmenter)
d@74:   ;; FIXME: crappy queue implementation
d@74:   ;; FIXME: This only returns paired starts and ends. Should we
d@74:   ;; process unpaired boundaries?
d@74:   (let ((segments) (starts))
d@74:     (sequence:dosequence (event composition (reverse segments))
d@74:       (when (> (boundary-strength start-boundary-segmenter event composition) 0)
d@161: 	(if starts
d@161: 	    (setf (cdr (last starts))
d@161: 		  (list (boundary-time start-boundary-segmenter event)))
d@161: 	    (setf starts (list (boundary-time start-boundary-segmenter event)))))
d@74:       (when (> (boundary-strength end-boundary-segmenter event composition) 0)
d@74: 	(when starts
d@161: 	  (push (make-instance 'standard-anchored-period
d@74: 			       :interval (amuse::duration (time- (boundary-time end-boundary-segmenter event)
d@74: 								 (car starts)))
d@74: 			       :time (timepoint (pop starts)))
d@74: 		segments))))))
d@74: