/[gcl]/gcl/lsp/gcl_listlib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_listlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26