[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	sequences.lisp 
Log Message:
Implemented reduce :from-end on lists.
Improved remove-duplicates and delete-duplicates not to use O(n) stack.


--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/03/25 20:59:16	1.31
+++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/02 20:48:34	1.32
@@ -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.31 2006/03/25 20:59:16 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.32 2006/04/02 20:48:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -126,8 +126,6 @@
    (t (function sequence &key (key 'identity) from-end
 		(start 0) (end (length sequence))
 		(initial-value nil initial-value-p))
-      (when from-end
-	(error "REDUCE from-end is not implemented."))
       (let ((start (check-the index start)))
 	(with-funcallable (funcall-function function)
 	  (with-funcallable (key)
@@ -140,18 +138,34 @@
 		   (key (elt sequence start))))
 	      (t (sequence-dispatch sequence
 		   (list
-		    (do* ((counter (1+ start) (1+ counter))
-			  (list (nthcdr start sequence))
-			  (result (funcall-function (if initial-value-p
-							initial-value
+		    (cond
+		     ((not from-end)
+		      (do* ((counter (1+ start) (1+ counter))
+			    (list (nthcdr start sequence))
+			    (result (funcall-function (if initial-value-p
+							  initial-value
+							(key (pop list)))
 						      (key (pop list)))
-						    (key (pop list)))
-				  (funcall-function result (key (pop list)))))
-			((or (null list)
-			     (= end counter))
-			 result)
-		      (declare (index counter))))
+				    (funcall-function result (key (pop list)))))
+			  ((or (null list)
+			       (= end counter))
+			   result)
+			(declare (index counter))))
+		     (from-end
+		      (do* ((counter (1+ start) (1+ counter))
+			    (list (nreverse (subseq sequence start end)))
+			    (result (funcall-function (key (pop list))
+						      (if initial-value-p
+							  initial-value
+							(key (pop list))))
+				    (funcall-function (key (pop list)) result)))
+			  ((or (null list)
+			       (= end counter))
+			   result)
+			(declare (index counter))))))
 		   (vector
+		    (when from-end
+		      (error "REDUCE from-end on vectors is not implemented."))
 		    (with-subvector-accessor (sequence-ref sequence start end)
 		      (do* ((index start)
 			    (result (funcall-function (if initial-value-p
@@ -731,7 +745,7 @@
     (apply 'map-for-nil function first-sequence more-sequences))
    ((eq 'list result-type)
     (apply 'map-for-list function first-sequence more-sequences))
-   ((eq 'string result-type)
+   ((member result-type '(string simple-string))
     (apply 'map-for-string function first-sequence more-sequences))
    (t (error "MAP not implemented."))))
 
@@ -1390,21 +1404,17 @@
     (setf test (complement test-not)))
   (sequence-dispatch sequence
     (list
-     (setf sequence (nthcdr start sequence))
-     (when end (decf end start))
-     (cond
-      ((endp sequence)
-       nil)
-      ((not from-end)
-       (let* ((new-end (when end (1- end)))
-	      (tail (remove-duplicates (cdr sequence) :test test :key key :end new-end)))
-	 (cond
-	  ((find (car sequence) (cdr sequence) :test test :key key :end new-end)
-	   tail)
-	  ((eq tail (cdr sequence))
-	   sequence)
-	  (t (cons (car sequence) tail)))))		   
-      (t (error "from-end not implemented."))))
+     (let ((list (nthcdr start sequence)))
+       (cond
+	((endp list)
+	 nil)
+	((and (not end) (not from-end))
+	 (do ((r nil))
+	     ((endp list) (nreverse r))
+	   (let ((x (pop list)))
+	     (unless (member x list :key key :test test)
+	       (push x r)))))
+	(t (error "remove-duplicates not implemented.")))))
     (vector
      (error "vector remove-duplicates not implemented."))))