Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[e90b2f]: src / lsp / listlib.lsp Maximize Restore History

Download this file

listlib.lsp    161 lines (144 with data), 6.4 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;; Copyright (c) 1995, Giuseppe Attardi.
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; list manipulating routines
(in-package "SYSTEM")
(defun union (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns, as a list, the union of elements in LIST1 and in LIST2."
(do ((x list1 (cdr x))
(first) (last))
((null x)
(when last (rplacd last list2))
(or first list2))
(unless (member1 (car x) list2 test test-not key)
(if last
(progn (rplacd last (cons (car x) nil))
(setq last (cdr last)))
(progn (setq first (cons (car x) nil))
(setq last first))))))
(defun nunion (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive UNION. Both LIST1 and LIST2 may be destroyed."
(do ((x list1 (cdr x))
(first) (last))
((null x)
(when last (rplacd last list2))
(or first list2))
(unless (member1 (car x) list2 test test-not key)
(if last
(rplacd last x)
(setq first x))
(setq last x))))
(defun intersection (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns a list consisting of those objects that are elements of both LIST1 and
LIST2."
(do ((x list1 (cdr x))
(ans))
((null x)
(nreverse ans)) ; optional nreverse: not required by CLtL
(when (member1 (car x) list2 test test-not key)
(push (car x) ans))))
(defun nintersection (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive INTERSECTION. Only LIST1 may be destroyed."
(do ((x list1 (cdr x))
(first) (last))
((null x)
(when last (rplacd last nil))
first)
(when (member1 (car x) list2 test test-not key)
(if last
(rplacd last x)
(setq first x))
(setq last x))))
(defun set-difference (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns, as a list, those elements of LIST1 that are not elements of LIST2."
(do ((x list1 (cdr x))
(ans))
((null x) (nreverse ans))
(unless (member1 (car x) list2 test test-not key)
(push (car x) ans))))
(defun nset-difference (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive SET-DIFFERENCE. Only LIST1 may be destroyed."
(do ((x list1 (cdr x))
(first) (last))
((null x)
(when last (rplacd last nil))
first)
(unless (member1 (car x) list2 test test-not key)
(if last
(rplacd last x)
(setq first x))
(setq last x))))
(defun swap-args (f)
(declare (si::c-local))
(and f #'(lambda (x y) (funcall f y x))))
(defun set-exclusive-or (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns, as a list, those elements of LIST1 that are not elements of LIST2 and
those elements of LIST2 that are not elements of LIST1."
(nconc (set-difference list1 list2 :test test :test-not test-not :key key)
(set-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key)))
(defun nset-exclusive-or (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive SET-EXCLUSIVE-OR. Both LIST1 and LIST2 may be destroyed."
(nconc (set-difference list1 list2 :test test :test-not test-not :key key)
(nset-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key)))
(defun subsetp (list1 list2 &key test test-not key)
"Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns T if every element of LIST1 is also an element of LIST2. Returns NIL
otherwise."
(do ((l list1 (cdr l)))
((null l) t)
(unless (member1 (car l) list2 test test-not key)
(return nil))))
(defun rassoc-if (test alist &key key)
"Returns the first pair in ALIST whose cdr satisfies TEST. Returns NIL if no
such pair exists."
(rassoc test alist :test #'funcall :key key))
(defun rassoc-if-not (test alist &key key)
"Returns the first pair in ALIST whose cdr does not satisfy TEST. Returns NIL
if no such pair exists."
(rassoc test alist :test-not #'funcall :key key))
(defun assoc-if (test alist &key key)
"Returns the first pair in ALIST whose car satisfies TEST. Returns NIL if no
such pair exists."
(assoc test alist :test #'funcall :key key))
(defun assoc-if-not (test alist &key key)
"Returns the first pair in ALIST whose car does not satisfy TEST. Returns NIL
if no such pair exists."
(assoc test alist :test-not #'funcall :key key))
(defun member-if (test list &key key)
"Searches LIST for an element that satisfies TEST. If found, returns the
sublist of LIST that begins with the element. If not found, returns NIL."
(member test list :test #'funcall :key key))
(defun member-if-not (test list &key key)
"Searches LIST for an element that does not satisfy TEST. If found, returns
the sublist of LIST that begins with the element. If not found, returns NIL."
(member test list :test-not #'funcall :key key))
(defun subst-if (new test tree &key key)
"Substitutes NEW for subtrees of TREE that satisfy TEST and returns the result.
The original TREE is not destroyed."
(subst new test tree :test #'funcall :key key))
(defun subst-if-not (new test tree &key key)
"Substitutes NEW for subtrees of TREE that do not satisfy TEST and returns the
result. The original TREE is not destroyed."
(subst new test tree :test-not #'funcall :key key))
(defun nsubst-if (new test tree &key key)
"Destructive SUBST-IF. TREE may be modified."
(nsubst new test tree :test #'funcall :key key))
(defun nsubst-if-not (new test tree &key key)
"Destructive SUBST-IF-NOT. TREE may be modified."
(nsubst new test tree :test-not #'funcall :key key))