[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv5113

Modified Files:
	sequences.lisp 
Log Message:
Improved map and remove-if.


--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/02 20:48:34	1.32
+++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/10 11:56:28	1.33
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.32 2006/04/02 20:48:34 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.33 2006/04/10 11:56:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -716,22 +716,21 @@
 	       (ignore function first-sequence more-sequences))
       (error "MAP not implemented."))))
 
-(defun map-for-string (function first-sequence &rest more-sequences)
+(defun map-for-vector (result function first-sequence &rest more-sequences)
   (numargs-case
-   (2 (function first-sequence)
+   (3 (result function first-sequence)
       (with-funcallable (mapf function)
-	(let ((result (make-string (length first-sequence))))
-	  (sequence-dispatch first-sequence
-	    (vector
-	     (do ((i 0 (1+ i)))
-		 ((>= i (length result)) result)
-	       (declare (index i))
-	       (setf (char result i) (mapf (aref first-sequence i)))))
-	    (list
-	     (do ((i 0 (1+ i)))
-		 ((>= i (length result)) result)
-	       (declare (index i))
-	       (setf (char result i) (mapf (pop first-sequence)))))))))
+	(sequence-dispatch first-sequence
+	  (vector
+	   (do ((i 0 (1+ i)))
+	       ((>= i (length result)) result)
+	     (declare (index i))
+	     (setf (aref result i) (mapf (aref first-sequence i)))))
+	  (list
+	   (do ((i 0 (1+ i)))
+	       ((>= i (length result)) result)
+	     (declare (index i))
+	     (setf (aref result i) (mapf (pop first-sequence))))))))
    (t (function first-sequence &rest more-sequences)
       (declare (ignore function first-sequence more-sequences))
       (error "MAP not implemented."))))
@@ -746,7 +745,13 @@
    ((eq 'list result-type)
     (apply 'map-for-list function first-sequence more-sequences))
    ((member result-type '(string simple-string))
-    (apply 'map-for-string function first-sequence more-sequences))
+    (apply 'map-for-vector
+	   (make-string (length first-sequence))
+	   function first-sequence more-sequences))
+   ((member result-type '(vector simple-vector))
+    (apply 'map-for-vector
+	   (make-array (length first-sequence))
+	   function first-sequence more-sequences))
    (t (error "MAP not implemented."))))
 
 (defun fill (sequence item &key (start 0) end)
@@ -1253,30 +1258,33 @@
     list)
    (t (with-funcallable (test)
 	(with-funcallable (key)
-	  (if (test (key (car list)))
-	      (list-remove-if test (cdr list) key
-			      (when end (1- end))
-			      (when count (1- count)))
-	    (do ((i 1 (1+ i))
-		 (p0 list (cdr p0))
-		 (p1 (cdr list) (cdr p1)))
-		((or (endp p1) (and end (>= i end))) list)
-	      (declare (index i))
-	      (when (test (key (car p1)))
-		(return
-		  ;; reiterate from <list> to <p1>, consing up a copy, with
-		  ;; the copy's tail being the recursive call to list-remove.
-		  (do* ((new-list (cons (car list) nil))
-			(x (cdr list) (cdr x))
-			(new-x new-list))
-		      ((eq x p1)
-		       (setf (cdr new-x) (list-remove-if test (cdr p1) key
-							 (when end (- end i 1))
-							 (when count (1- count))))
-		       new-list)
-		    (setf new-x
-		      (setf (cdr new-x)
-			(cons (car x) nil)))))))))))))
+	  (and (do () ((or (endp list)
+			   (and end (<= end 0))
+			   (not (test (key (car list))))
+			   (and count (<= (decf count) 0)))
+		       list)
+		 (when end (decf end))
+		 (setf list (cdr list)))
+	       (do ((i 1 (1+ i))
+		    (p0 list (cdr p0))
+		    (p1 (cdr list) (cdr p1)))
+		   ((or (endp p1) (and end (>= i end))) list)
+		 (declare (index i))
+		 (when (test (key (car p1)))
+		   (return
+		     ;; reiterate from <list> to <p1>, consing up a copy, with
+		     ;; the copy's tail being the recursive call to list-remove.
+		     (do* ((new-list (cons (car list) nil))
+			   (x (cdr list) (cdr x))
+			   (new-x new-list))
+			 ((eq x p1)
+			  (setf (cdr new-x) (list-remove-if test (cdr p1) key
+							    (when end (- end i 1))
+							    (when count (1- count))))
+			  new-list)
+		       (setf new-x
+			 (setf (cdr new-x)
+			   (cons (car x) nil)))))))))))))
 
 (defun remove-if (test sequence &key from-end (start 0) end count (key 'identity))
   (sequence-dispatch sequence