|
d@74
|
1 (in-package "AMUSE-SEGMENTATION")
|
|
d@74
|
2
|
|
d@136
|
3 (defmethod boundary-time (segmenter (object anchored-period))
|
|
d@74
|
4 (if (segments-beforep segmenter)
|
|
d@74
|
5 (onset object)
|
|
d@74
|
6 (cut-off object)))
|
|
d@136
|
7 (defmethod boundary-time (segmenter (object moment))
|
|
d@74
|
8 object)
|
|
d@74
|
9
|
|
d@74
|
10 ;;;;;;;;;;;;;;;;;;;;;;;
|
|
d@74
|
11 ;;; Seriously made-up stuff (= dodgy)
|
|
d@74
|
12
|
|
d@74
|
13 (defun map-segmenters (composition &key (start-boundary-segmenter nil) (end-boundary-segmenter nil))
|
|
d@74
|
14 (cond
|
|
d@74
|
15 ((and start-boundary-segmenter end-boundary-segmenter)
|
|
d@161
|
16 #+nil (%map-non-contiguous-segmenters composition start-boundary-segmenter end-boundary-segmenter)
|
|
d@161
|
17 ;; hacky fix for broken code
|
|
d@161
|
18 (remove-duplicates (nconc (%map-start-segmenter composition start-boundary-segmenter)
|
|
d@161
|
19 (%map-end-segmenter composition end-boundary-segmenter))
|
|
d@161
|
20 :test #'period=))
|
|
d@74
|
21 (start-boundary-segmenter
|
|
d@74
|
22 (%map-start-segmenter composition start-boundary-segmenter))
|
|
d@74
|
23 (end-boundary-segmenter
|
|
d@74
|
24 (%map-end-segmenter composition end-boundary-segmenter))
|
|
d@74
|
25 (t (error "Map-segmenters called with no segmenters"))))
|
|
d@74
|
26
|
|
d@74
|
27 (defun %map-start-segmenter (composition segmenter)
|
|
d@74
|
28 (let ((segments))
|
|
d@74
|
29 (sequence:dosequence (event composition (progn
|
|
d@74
|
30 (setf (duration (car segments))
|
|
d@74
|
31 (duration (time- (cut-off composition)
|
|
d@74
|
32 (onset (car segments)))))
|
|
d@74
|
33 (reverse segments)))
|
|
d@74
|
34 (when (> (boundary-strength segmenter event composition) 0)
|
|
d@74
|
35 (when segments
|
|
d@74
|
36 (setf (duration (car segments))
|
|
d@74
|
37 (duration (time- (boundary-time segmenter event)
|
|
d@74
|
38 (onset (car segments))))))
|
|
d@161
|
39 (push (make-instance 'standard-anchored-period
|
|
d@74
|
40 :time (timepoint (boundary-time segmenter event)))
|
|
d@74
|
41 segments)))))
|
|
d@74
|
42
|
|
d@74
|
43 (defun %map-end-segmenter (composition segmenter)
|
|
d@161
|
44 (let ((segments (list (make-instance 'standard-anchored-period :time (timepoint composition)))))
|
|
d@74
|
45 (sequence:dosequence (event composition (reverse (cdr segments)))
|
|
d@74
|
46 (when (> (boundary-strength segmenter event composition) 0)
|
|
d@74
|
47 (setf (duration (car segments))
|
|
d@74
|
48 (duration (time- (boundary-time segmenter event)
|
|
d@74
|
49 (onset (car segments)))))
|
|
d@161
|
50 (push (make-instance 'standard-anchored-period
|
|
d@74
|
51 :time (timepoint (boundary-time segmenter event)))
|
|
d@74
|
52 segments)))))
|
|
d@74
|
53
|
|
d@74
|
54 (defun %map-non-contiguous-segmenters (composition start-boundary-segmenter end-boundary-segmenter)
|
|
d@74
|
55 ;; FIXME: crappy queue implementation
|
|
d@74
|
56 ;; FIXME: This only returns paired starts and ends. Should we
|
|
d@74
|
57 ;; process unpaired boundaries?
|
|
d@74
|
58 (let ((segments) (starts))
|
|
d@74
|
59 (sequence:dosequence (event composition (reverse segments))
|
|
d@74
|
60 (when (> (boundary-strength start-boundary-segmenter event composition) 0)
|
|
d@161
|
61 (if starts
|
|
d@161
|
62 (setf (cdr (last starts))
|
|
d@161
|
63 (list (boundary-time start-boundary-segmenter event)))
|
|
d@161
|
64 (setf starts (list (boundary-time start-boundary-segmenter event)))))
|
|
d@74
|
65 (when (> (boundary-strength end-boundary-segmenter event composition) 0)
|
|
d@74
|
66 (when starts
|
|
d@161
|
67 (push (make-instance 'standard-anchored-period
|
|
d@74
|
68 :interval (amuse::duration (time- (boundary-time end-boundary-segmenter event)
|
|
d@74
|
69 (car starts)))
|
|
d@74
|
70 :time (timepoint (pop starts)))
|
|
d@74
|
71 segments))))))
|
|
d@74
|
72
|
