changeset 151:30341910a67e

Add make-sequence-like for standard-composition (should make remove-if work)

darcs-hash:20071107111403-f76cc-4b52a0c757c3861f3390b7447f992b2cff07e1bd.gz

--- a/base/methods.lisp	Fri Nov 02 17:02:05 2007 +0000
+++ b/base/methods.lisp	Wed Nov 07 11:14:03 2007 +0000
@@ -454,3 +454,39 @@
 (defmethod make-anchored-period ((onset-value real) (duration-value real))
   "Returns STANDARD-ANCHORED-PERIOD given a real"
   (make-standard-anchored-period onset-value duration-value))
+
+;; Needed by some sequence functions, notably remove-if.
+(defmethod sequence:make-sequence-like :around ((o standard-composition) length
+						&key (initial-element nil iep)
+						(initial-contents nil icp))
+  " Around method for make-sequence-like, only with all slots
+  preserved from the source sequence (except onset and duration,
+  which are calculated afresh)."
+  (declare (ignore length initial-element initial-contents iep icp))
+  (let ((new-sequence (call-next-method))
+	(start) (finish))
+    ;; Get timing information
+    (sequence:dosequence (element new-sequence)
+      ;; Actually, this next bit is pretty stupid - I know this is
+      ;; ordered, so this bit could be replaced by
+      ;; (setf (timepoint new-sequence)
+      ;;    (timepoint (elt new-sequence 0)))
+      ;; outside of the loop.
+      (when (or (not start)
+		(< (timepoint element) start))
+	(setf start (timepoint element)))
+      (when (or (not finish)
+		(> (timepoint (cut-off element))
+		   finish))
+	(setf finish (timepoint (cut-off element)))))
+    (setf (timepoint new-sequence) start
+	  (duration new-sequence) (- finish start))
+    (dolist (slotd (sb-mop:class-slots new-sequence) new-sequence)
+      (unless (or (equal (sb-mop:slot-definition-name slotd) 'time)
+		  (equal (sb-mop:slot-definition-name slotd) 'interval))
+	(setf (sb-mop:slot-value-using-class (class-of new-sequence)
+					     new-sequence
+					     slotd)
+	      (sb-mop:slot-value-using-class (class-of new-sequence)
+					     o ;; if this isn't the same, we're lost anyway
+					     slotd))))))
\ No newline at end of file