37 |
(proclaim '(optimize (safety 0) (space 3))) |
(proclaim '(optimize (safety 0) (space 3))) |
38 |
) |
) |
39 |
|
|
40 |
|
(defun key-list (key test test-not &aux (tem nil)) |
41 |
|
(when key (push :key tem) (push key tem)) |
42 |
|
(when test (push :test tem) (push test tem)) |
43 |
|
(when test-not (push :test-not tem) (push test-not tem)) |
44 |
|
(nreverse tem)) |
45 |
|
|
46 |
;(defun union (list1 list2 &rest rest &key test test-not key) |
;(defun union (list1 list2 &rest rest &key test test-not key) |
47 |
; (declare (ignore test test-not key)) |
; (declare (ignore test test-not key)) |
48 |
; (cond ((null list1) list2) |
; (cond ((null list1) list2) |
51 |
; (t |
; (t |
52 |
; (cons (car list1) |
; (cons (car list1) |
53 |
; (apply #'union (cdr list1) list2 rest))))) |
; (apply #'union (cdr list1) list2 rest))))) |
54 |
(defun union (list1 list2 &rest rest &aux first last) |
(defun union (list1 list2 &key test test-not key &aux first last) |
55 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
56 |
((null x) (if last (rplacd last list2)) (return (or first list2))) |
((null x) (if last (rplacd last list2)) (return (or first list2))) |
57 |
(or (consp x) (error "UNION not passed a list")) |
(or (consp x) (error "UNION not passed a list")) |
58 |
(if (not (apply #'member1 (car x) list2 rest)) |
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
59 |
(if last (progn (rplacd last (cons (car x) nil)) |
(if last (progn (rplacd last (cons (car x) nil)) |
60 |
(setq last (cdr last))) |
(setq last (cdr last))) |
61 |
(progn (setq first (cons (car x) nil)) |
(progn (setq first (cons (car x) nil)) |
69 |
; (t |
; (t |
70 |
; (rplacd list1 |
; (rplacd list1 |
71 |
; (apply #'nunion (cdr list1) list2 rest))))) |
; (apply #'nunion (cdr list1) list2 rest))))) |
72 |
(defun nunion (list1 list2 &rest rest &aux first last) |
(defun nunion (list1 list2 &key test test-not key &aux first last) |
73 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
74 |
((null x) (if last (rplacd last list2)) (return (or first list2))) |
((null x) (if last (rplacd last list2)) (return (or first list2))) |
75 |
(or (consp x) (error "NUNION not passed a list")) |
(or (consp x) (error "NUNION not passed a list")) |
76 |
(if (not (apply #'member1 (car x) list2 rest)) |
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
77 |
(progn (if last (rplacd last x) |
(progn (if last (rplacd last x) |
78 |
(setq first x)) |
(setq first x)) |
79 |
(setq last x))) ) ) |
(setq last x))) ) ) |
88 |
|
|
89 |
;; all functions in this file should be written as follows: |
;; all functions in this file should be written as follows: |
90 |
;; Besides being non recursive, it allows compilation on safety 0 |
;; Besides being non recursive, it allows compilation on safety 0 |
91 |
(defun intersection (list1 list2 &rest rest &aux ans) |
(defun intersection (list1 list2 &key test test-not key &aux ans) |
92 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
93 |
((null x) (return ans)) |
((null x) (return ans)) |
94 |
(or (consp x) (error "INTERSECTION not passed a list")) |
(or (consp x) (error "INTERSECTION not passed a list")) |
95 |
(if (apply #'member1 (car x) list2 rest) |
(if (apply #'member1 (car x) list2 (key-list key test test-not)) |
96 |
(setq ans (cons (car x) ans)))) |
(setq ans (cons (car x) ans)))) |
97 |
) |
) |
98 |
|
|
103 |
; (rplacd list1 |
; (rplacd list1 |
104 |
; (apply #'nintersection (cdr list1) list2 rest))) |
; (apply #'nintersection (cdr list1) list2 rest))) |
105 |
; (t (apply #'nintersection (cdr list1) list2 rest)))) |
; (t (apply #'nintersection (cdr list1) list2 rest)))) |
106 |
(defun nintersection (list1 list2 &rest rest &aux first last) |
(defun nintersection (list1 list2 &key test test-not key &aux first last) |
107 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
108 |
((null x) (if last (rplacd last nil)) (return first)) |
((null x) (if last (rplacd last nil)) (return first)) |
109 |
(or (consp x) (error "NINTERSECTION not passed a list")) |
(or (consp x) (error "NINTERSECTION not passed a list")) |
110 |
(if (apply #'member1 (car x) list2 rest) |
(if (apply #'member1 (car x) list2 (key-list key test test-not)) |
111 |
(progn (if last (rplacd last x) |
(progn (if last (rplacd last x) |
112 |
(setq first x)) |
(setq first x)) |
113 |
(setq last x))) ) ) |
(setq last x))) ) ) |
119 |
; (cons (car list1) |
; (cons (car list1) |
120 |
; (apply #'set-difference (cdr list1) list2 rest))) |
; (apply #'set-difference (cdr list1) list2 rest))) |
121 |
; (t (apply #'set-difference (cdr list1) list2 rest)))) |
; (t (apply #'set-difference (cdr list1) list2 rest)))) |
122 |
(defun set-difference (list1 list2 &rest rest &aux ans) |
(defun set-difference (list1 list2 &key test test-not key &aux ans) |
123 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
124 |
((null x) (return ans)) |
((null x) (return ans)) |
125 |
(or (consp x) (error "SET-DIFFERENCE not passed a list")) |
(or (consp x) (error "SET-DIFFERENCE not passed a list")) |
126 |
(if (not (apply #'member1 (car x) list2 rest)) |
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
127 |
(setq ans (cons (car x) ans)))) ) |
(setq ans (cons (car x) ans)))) ) |
128 |
(defun set-difference-rev (list1 list2 &rest rest &aux ans) |
(defun set-difference-rev (list1 list2 &key test test-not key &aux ans) |
129 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
130 |
((null x) (return ans)) |
((null x) (return ans)) |
131 |
(or (consp x) (error "SET-DIFFERENCE not passed a list")) |
(or (consp x) (error "SET-DIFFERENCE not passed a list")) |
132 |
(if (not (apply #'member1 (car x) list2 :rev t rest)) |
(if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not))) |
133 |
(setq ans (cons (car x) ans)))) ) |
(setq ans (cons (car x) ans)))) ) |
134 |
|
|
135 |
;(defun nset-difference (list1 list2 &rest rest &key test test-not key) |
;(defun nset-difference (list1 list2 &rest rest &key test test-not key) |
139 |
; (rplacd list1 |
; (rplacd list1 |
140 |
; (apply #'nset-difference (cdr list1) list2 rest))) |
; (apply #'nset-difference (cdr list1) list2 rest))) |
141 |
; (t (apply #'nset-difference (cdr list1) list2 rest)))) |
; (t (apply #'nset-difference (cdr list1) list2 rest)))) |
142 |
(defun nset-difference (list1 list2 &rest rest &aux first last) |
(defun nset-difference (list1 list2 &key test test-not key &aux first last) |
143 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
144 |
((null x) (if last (rplacd last nil)) (return first)) |
((null x) (if last (rplacd last nil)) (return first)) |
145 |
(or (consp x) (error "NSET-DIFFERENCE not passed a list")) |
(or (consp x) (error "NSET-DIFFERENCE not passed a list")) |
146 |
(if (not (apply #'member1 (car x) list2 rest)) |
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
147 |
(progn (if last (rplacd last x) |
(progn (if last (rplacd last x) |
148 |
(setq first x)) |
(setq first x)) |
149 |
(setq last x))) ) ) |
(setq last x))) ) ) |
150 |
(defun nset-difference-rev (list1 list2 &rest rest &aux first last) |
(defun nset-difference-rev (list1 list2 &key test test-not key &aux first last) |
151 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
152 |
((null x) (if last (rplacd last nil)) (return first)) |
((null x) (if last (rplacd last nil)) (return first)) |
153 |
(or (consp x) (error "NSET-DIFFERENCE not passed a list")) |
(or (consp x) (error "NSET-DIFFERENCE not passed a list")) |
154 |
(if (not (apply #'member1 (car x) list2 :rev t rest)) |
(if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not))) |
155 |
(progn (if last (rplacd last x) |
(progn (if last (rplacd last x) |
156 |
(setq first x)) |
(setq first x)) |
157 |
(setq last x))) ) ) |
(setq last x))) ) ) |
160 |
; (declare (ignore test test-not key)) |
; (declare (ignore test test-not key)) |
161 |
; (append (apply #'set-difference list1 list2 rest) |
; (append (apply #'set-difference list1 list2 rest) |
162 |
; (apply #'set-difference list2 list1 rest))) |
; (apply #'set-difference list2 list1 rest))) |
163 |
(defun set-exclusive-or (list1 list2 &rest rest &key test test-not key) |
(defun set-exclusive-or (list1 list2 &key test test-not key) |
164 |
(declare (ignore test test-not key)) |
(nconc (apply #'set-difference list1 list2 (key-list key test test-not)) |
165 |
(nconc (apply #'set-difference list1 list2 rest) |
(apply #'set-difference-rev list2 list1 (key-list key test test-not)))) |
|
(apply #'set-difference-rev list2 list1 rest))) |
|
166 |
|
|
167 |
;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key) |
;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key) |
168 |
; (declare (ignore test test-not key)) |
; (declare (ignore test test-not key)) |
169 |
; (nconc (apply #'set-difference list1 list2 rest) |
; (nconc (apply #'set-difference list1 list2 rest) |
170 |
; (apply #'nset-difference list2 list1 rest))) |
; (apply #'nset-difference list2 list1 rest))) |
171 |
(defun nset-exclusive-or (list1 list2 &rest rest &aux first last fint lint) |
(defun nset-exclusive-or (list1 list2 &key test test-not key &aux first last fint lint) |
172 |
(do ((x list1 (cdr x))) |
(do ((x list1 (cdr x))) |
173 |
((null x) (if lint (rplacd lint nil)) |
((null x) (if lint (rplacd lint nil)) |
174 |
(if last |
(if last |
175 |
(progn (rplacd last |
(progn (rplacd last |
176 |
(apply #'nset-difference-rev list2 fint rest)) |
(apply #'nset-difference-rev list2 fint (key-list key test test-not))) |
177 |
(return first)) |
(return first)) |
178 |
(return (apply #'nset-difference-rev list2 fint rest)))) |
(return (apply #'nset-difference-rev list2 fint (key-list key test test-not))))) |
179 |
(or (consp x) (error "NSET-EXCLUSIVE-OR not passed a list")) |
(or (consp x) (error "NSET-EXCLUSIVE-OR not passed a list")) |
180 |
(if (apply #'member1 (car x) list2 rest) |
(if (apply #'member1 (car x) list2 (key-list key test test-not)) |
181 |
(progn (if lint (rplacd lint x) |
(progn (if lint (rplacd lint x) |
182 |
(setq fint x)) |
(setq fint x)) |
183 |
(setq lint x)) |
(setq lint x)) |
185 |
(setq first x)) |
(setq first x)) |
186 |
(setq last x))) ) ) |
(setq last x))) ) ) |
187 |
|
|
188 |
(defun subsetp (list1 list2 &rest rest &key test test-not key) |
(defun subsetp (list1 list2 &key test test-not key) |
|
(declare (ignore test test-not key)) |
|
189 |
(do ((l list1 (cdr l))) |
(do ((l list1 (cdr l))) |
190 |
((null l) t) |
((null l) t) |
191 |
(or (consp l) (error "SUBSETP not passed a list")) |
(or (consp l) (error "SUBSETP not passed a list")) |
192 |
(if (not (apply #'member1 (car l) list2 rest)) (return nil)))) |
(if (not (apply #'member1 (car l) list2 (key-list key test test-not))) (return nil)))) |
193 |
|
|
194 |
|
|