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

Modified Files: sequences.lisp Log Message: Added substitute-if and nsubstitute-if, and rewrote substitute and nsubstitute in terms of those.

--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/21 20:23:42 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/21 21:23:27 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.28 2006/03/21 20:23:42 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.29 2006/03/21 21:23:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -1735,30 +1735,52 @@ (incf i (length s))) r)) (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) - + + (defun substitute (newitem olditem sequence &rest args &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) + "=> result-sequence" (declare (dynamic-extent args)) + (when test-not + (setf test (complement test-not))) + (with-funcallable (test (if test-not (complement test-not) test)) + (substitute-if newitem (lambda (x) (test olditem x)) sequence + :start start :end end + :count count :key key + :from-end from-end))) + +(defun nsubstitute (newitem olditem sequence &rest args + &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) "=> result-sequence" + (declare (dynamic-extent args)) (when test-not (setf test (complement test-not))) - (with-funcallable (test) + (with-funcallable (test (if test-not (complement test-not) test)) + (nsubstitute-if newitem (lambda (x) (test olditem x)) sequence + :start start :end end + :count count :key key + :from-end from-end))) + +(defun substitute-if (newitem predicate sequence &rest args + &key (start 0) end count (key 'identity) from-end) + "=> result-sequence" + (declare (dynamic-extent args)) + (with-funcallable (predicate) (with-funcallable (key) (sequence-dispatch sequence (vector - (apply #'nsubstitute newitem olditem (copy-seq sequence) args)) + (apply #'nsubstitute-if newitem predicate (copy-seq sequence) args)) (list (if from-end - (nreverse (nsubstitute newitem olditem (reverse sequence) - :test test :test-not test-not - :start start :end end - :count count :key key)) + (nreverse (nsubstitute-if newitem predicate (reverse sequence) + :start start :end end + :count count :key key)) (let ((sequence (nthcdr start sequence))) (if (or (null sequence) (and end (<= end start))) nil (let ((new-list (list #0=(let ((x (pop sequence))) - (if (test olditem (key x)) + (if (predicate (key x)) newitem x))))) (cond @@ -1779,7 +1801,7 @@ (copy-list sequence)) new-list) (setf (cdr new-tail) #1=(list (let ((x (pop sequence))) - (if (test olditem (key x)) + (if (predicate (key x)) (progn (incf c) newitem) x)))))) ((and end count) @@ -1793,11 +1815,9 @@ (setf (cdr new-tail) #1#))) ((error 'program-error))))))))))))

-(defun nsubstitute (newitem olditem sequence &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) +(defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence" - (when test-not - (setf test (complement test-not))) - (with-funcallable (test) + (with-funcallable (predicate) (with-funcallable (key) (sequence-dispatch sequence (vector @@ -1807,34 +1827,33 @@ ((and (not count) (not from-end)) (do ((i start (1+ i))) ((>= i end) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem)))) ((and count (not from-end)) (do ((c 0) (i start (1+ i))) ((>= i end) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem) (when (>= (incf c) count) (return sequence))))) ((and (not count) from-end) (do ((i (1- end) (1- i))) ((< i start) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem)))) ((and count from-end) (do ((c 0) (i (1- end) (1- i))) ((< i start) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem) (when (>= (incf c) count) (return sequence))))) ((error 'program-error)))))) (list (if from-end - (nreverse (nsubstitute newitem olditem (nreverse sequence) - :test test :test-not test-not + (nreverse (nsubstitute newitem predicate (nreverse sequence) :start start :end end :count count :key key)) (let ((p (nthcdr start sequence))) @@ -1842,19 +1861,19 @@ ((and (not end) (not count)) (do ((p p (cdr p))) ((endp p) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem)))) ((and end (not count)) (do ((i start (1+ i)) (p p (cdr p))) ((or (endp p) (>= i end)) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem)))) ((and (not end) count) (do ((c 0) (p p (cdr p))) ((endp p) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem) (when (>= (incf c) count) (return sequence))))) @@ -1863,8 +1882,8 @@ (i start (1+ i)) (p p (cdr p))) ((or (endp p) (>= i end)) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem) (when (>= (incf c) count) (return sequence))))) - ((error 'program-error)))))))))) + ((error 'program-error)))))))))) \ No newline at end of file