[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Tue Mar 21 21:23:28 UTC 2006
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 at 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
More information about the Movitz-cvs
mailing list