1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; listlib.lsp |
21 |
|
;;;; |
22 |
|
;;;; list manipulating routines |
23 |
|
|
24 |
|
; Rewritten 11 Feb 1993 by William Schelter and Gordon Novak to use iteration |
25 |
|
; rather than recursion, as needed for large data sets. |
26 |
|
|
27 |
|
|
28 |
|
(in-package 'lisp) |
29 |
|
|
30 |
|
(export '(union nunion intersection nintersection |
31 |
|
set-difference nset-difference set-exclusive-or nset-exclusive-or |
32 |
|
subsetp)) |
33 |
|
|
34 |
|
(in-package 'system) |
35 |
|
|
36 |
|
(eval-when (compile) |
37 |
|
(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) |
47 |
|
; (declare (ignore test test-not key)) |
48 |
|
; (cond ((null list1) list2) |
49 |
|
; ((apply #'member1 (car list1) list2 rest) |
50 |
|
; (apply #'union (cdr list1) list2 rest)) |
51 |
|
; (t |
52 |
|
; (cons (car list1) |
53 |
|
; (apply #'union (cdr list1) list2 rest))))) |
54 |
|
(defun union (list1 list2 &key test test-not key &aux first last) |
55 |
|
(do ((x list1 (cdr x))) |
56 |
|
((null x) (if last (rplacd last list2)) (return (or first list2))) |
57 |
|
(or (consp x) (error "UNION not passed a list")) |
58 |
|
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
59 |
|
(if last (progn (rplacd last (cons (car x) nil)) |
60 |
|
(setq last (cdr last))) |
61 |
|
(progn (setq first (cons (car x) nil)) |
62 |
|
(setq last first)))) ) ) |
63 |
|
|
64 |
|
;(defun nunion (list1 list2 &rest rest &key test test-not key) |
65 |
|
; (declare (ignore test test-not key)) |
66 |
|
; (cond ((null list1) list2) |
67 |
|
; ((apply #'member1 (car list1) list2 rest) |
68 |
|
; (apply #'nunion (cdr list1) list2 rest)) |
69 |
|
; (t |
70 |
|
; (rplacd list1 |
71 |
|
; (apply #'nunion (cdr list1) list2 rest))))) |
72 |
|
(defun nunion (list1 list2 &key test test-not key &aux first last) |
73 |
|
(do ((x list1 (cdr x))) |
74 |
|
((null x) (if last (rplacd last list2)) (return (or first list2))) |
75 |
|
(or (consp x) (error "NUNION not passed a list")) |
76 |
|
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
77 |
|
(progn (if last (rplacd last x) |
78 |
|
(setq first x)) |
79 |
|
(setq last x))) ) ) |
80 |
|
|
81 |
|
;(defun intersection (list1 list2 &rest rest &key test test-not key) |
82 |
|
; (declare (ignore test test-not key)) |
83 |
|
; (cond ((null list1) nil) |
84 |
|
; ((apply #'member1 (car list1) list2 rest) |
85 |
|
; (cons (car list1) |
86 |
|
; (apply #'intersection (cdr list1) list2 rest))) |
87 |
|
; (t (apply #'intersection (cdr list1) list2 rest)))) |
88 |
|
|
89 |
|
;; all functions in this file should be written as follows: |
90 |
|
;; Besides being non recursive, it allows compilation on safety 0 |
91 |
|
(defun intersection (list1 list2 &key test test-not key &aux ans) |
92 |
|
(do ((x list1 (cdr x))) |
93 |
|
((null x) (return ans)) |
94 |
|
(or (consp x) (error "INTERSECTION not passed a list")) |
95 |
|
(if (apply #'member1 (car x) list2 (key-list key test test-not)) |
96 |
|
(setq ans (cons (car x) ans)))) |
97 |
|
) |
98 |
|
|
99 |
|
;(defun nintersection (list1 list2 &rest rest &key test test-not key) |
100 |
|
; (declare (ignore test test-not key)) |
101 |
|
; (cond ((null list1) nil) |
102 |
|
; ((apply #'member1 (car list1) list2 rest) |
103 |
|
; (rplacd list1 |
104 |
|
; (apply #'nintersection (cdr list1) list2 rest))) |
105 |
|
; (t (apply #'nintersection (cdr list1) list2 rest)))) |
106 |
|
(defun nintersection (list1 list2 &key test test-not key &aux first last) |
107 |
|
(do ((x list1 (cdr x))) |
108 |
|
((null x) (if last (rplacd last nil)) (return first)) |
109 |
|
(or (consp x) (error "NINTERSECTION not passed a list")) |
110 |
|
(if (apply #'member1 (car x) list2 (key-list key test test-not)) |
111 |
|
(progn (if last (rplacd last x) |
112 |
|
(setq first x)) |
113 |
|
(setq last x))) ) ) |
114 |
|
|
115 |
|
;(defun set-difference (list1 list2 &rest rest &key test test-not key) |
116 |
|
; (declare (ignore test test-not key)) |
117 |
|
; (cond ((null list1) nil) |
118 |
|
; ((not (apply #'member1 (car list1) list2 rest)) |
119 |
|
; (cons (car list1) |
120 |
|
; (apply #'set-difference (cdr list1) list2 rest))) |
121 |
|
; (t (apply #'set-difference (cdr list1) list2 rest)))) |
122 |
|
(defun set-difference (list1 list2 &key test test-not key &aux ans) |
123 |
|
(do ((x list1 (cdr x))) |
124 |
|
((null x) (return ans)) |
125 |
|
(or (consp x) (error "SET-DIFFERENCE not passed a list")) |
126 |
|
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
127 |
|
(setq ans (cons (car x) ans)))) ) |
128 |
|
(defun set-difference-rev (list1 list2 &key test test-not key &aux ans) |
129 |
|
(do ((x list1 (cdr x))) |
130 |
|
((null x) (return ans)) |
131 |
|
(or (consp x) (error "SET-DIFFERENCE not passed a list")) |
132 |
|
(if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not))) |
133 |
|
(setq ans (cons (car x) ans)))) ) |
134 |
|
|
135 |
|
;(defun nset-difference (list1 list2 &rest rest &key test test-not key) |
136 |
|
; (declare (ignore test test-not key)) |
137 |
|
; (cond ((null list1) nil) |
138 |
|
; ((not (apply #'member1 (car list1) list2 rest)) |
139 |
|
; (rplacd list1 |
140 |
|
; (apply #'nset-difference (cdr list1) list2 rest))) |
141 |
|
; (t (apply #'nset-difference (cdr list1) list2 rest)))) |
142 |
|
(defun nset-difference (list1 list2 &key test test-not key &aux first last) |
143 |
|
(do ((x list1 (cdr x))) |
144 |
|
((null x) (if last (rplacd last nil)) (return first)) |
145 |
|
(or (consp x) (error "NSET-DIFFERENCE not passed a list")) |
146 |
|
(if (not (apply #'member1 (car x) list2 (key-list key test test-not))) |
147 |
|
(progn (if last (rplacd last x) |
148 |
|
(setq first x)) |
149 |
|
(setq last x))) ) ) |
150 |
|
(defun nset-difference-rev (list1 list2 &key test test-not key &aux first last) |
151 |
|
(do ((x list1 (cdr x))) |
152 |
|
((null x) (if last (rplacd last nil)) (return first)) |
153 |
|
(or (consp x) (error "NSET-DIFFERENCE not passed a list")) |
154 |
|
(if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not))) |
155 |
|
(progn (if last (rplacd last x) |
156 |
|
(setq first x)) |
157 |
|
(setq last x))) ) ) |
158 |
|
|
159 |
|
;(defun set-exclusive-or (list1 list2 &rest rest &key test test-not key) |
160 |
|
; (declare (ignore test test-not key)) |
161 |
|
; (append (apply #'set-difference list1 list2 rest) |
162 |
|
; (apply #'set-difference list2 list1 rest))) |
163 |
|
(defun set-exclusive-or (list1 list2 &key test test-not key) |
164 |
|
(nconc (apply #'set-difference list1 list2 (key-list key test test-not)) |
165 |
|
(apply #'set-difference-rev list2 list1 (key-list key test test-not)))) |
166 |
|
|
167 |
|
;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key) |
168 |
|
; (declare (ignore test test-not key)) |
169 |
|
; (nconc (apply #'set-difference list1 list2 rest) |
170 |
|
; (apply #'nset-difference list2 list1 rest))) |
171 |
|
(defun nset-exclusive-or (list1 list2 &key test test-not key &aux first last fint lint) |
172 |
|
(do ((x list1 (cdr x))) |
173 |
|
((null x) (if lint (rplacd lint nil)) |
174 |
|
(if last |
175 |
|
(progn (rplacd last |
176 |
|
(apply #'nset-difference-rev list2 fint (key-list key test test-not))) |
177 |
|
(return first)) |
178 |
|
(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")) |
180 |
|
(if (apply #'member1 (car x) list2 (key-list key test test-not)) |
181 |
|
(progn (if lint (rplacd lint x) |
182 |
|
(setq fint x)) |
183 |
|
(setq lint x)) |
184 |
|
(progn (if last (rplacd last x) |
185 |
|
(setq first x)) |
186 |
|
(setq last x))) ) ) |
187 |
|
|
188 |
|
(defun subsetp (list1 list2 &key test test-not key) |
189 |
|
(do ((l list1 (cdr l))) |
190 |
|
((null l) t) |
191 |
|
(or (consp l) (error "SUBSETP not passed a list")) |
192 |
|
(if (not (apply #'member1 (car l) list2 (key-list key test test-not))) (return nil)))) |
193 |
|
|
194 |
|
|