lists.lisp - clic - Clic is an command line interactive client for gopher writt… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
lists.lisp (14160B) | |
--- | |
1 (in-package :alexandria) | |
2 | |
3 (declaim (inline safe-endp)) | |
4 (defun safe-endp (x) | |
5 (declare (optimize safety)) | |
6 (endp x)) | |
7 | |
8 (defun alist-plist (alist) | |
9 "Returns a property list containing the same keys and values as the | |
10 association list ALIST in the same order." | |
11 (let (plist) | |
12 (dolist (pair alist) | |
13 (push (car pair) plist) | |
14 (push (cdr pair) plist)) | |
15 (nreverse plist))) | |
16 | |
17 (defun plist-alist (plist) | |
18 "Returns an association list containing the same keys and values as the | |
19 property list PLIST in the same order." | |
20 (let (alist) | |
21 (do ((tail plist (cddr tail))) | |
22 ((safe-endp tail) (nreverse alist)) | |
23 (push (cons (car tail) (cadr tail)) alist)))) | |
24 | |
25 (declaim (inline racons)) | |
26 (defun racons (key value ralist) | |
27 (acons value key ralist)) | |
28 | |
29 (macrolet | |
30 ((define-alist-get (name get-entry get-value-from-entry add doc) | |
31 `(progn | |
32 (declaim (inline ,name)) | |
33 (defun ,name (alist key &key (test 'eql)) | |
34 ,doc | |
35 (let ((entry (,get-entry key alist :test test))) | |
36 (values (,get-value-from-entry entry) entry))) | |
37 (define-setf-expander ,name (place key &key (test ''eql) | |
38 &environment env) | |
39 (multiple-value-bind | |
40 (temporary-variables initforms newvals setter getter) | |
41 (get-setf-expansion place env) | |
42 (when (cdr newvals) | |
43 (error "~A cannot store multiple values in one place" ',… | |
44 (with-unique-names (new-value key-val test-val alist entry) | |
45 (values | |
46 (append temporary-variables | |
47 (list alist | |
48 key-val | |
49 test-val | |
50 entry)) | |
51 (append initforms | |
52 (list getter | |
53 key | |
54 test | |
55 `(,',get-entry ,key-val ,alist :test ,tes… | |
56 `(,new-value) | |
57 `(cond | |
58 (,entry | |
59 (setf (,',get-value-from-entry ,entry) ,new-value)) | |
60 (t | |
61 (let ,newvals | |
62 (setf ,(first newvals) (,',add ,key ,new-value ,a… | |
63 ,setter | |
64 ,new-value))) | |
65 `(,',get-value-from-entry ,entry)))))))) | |
66 (define-alist-get assoc-value assoc cdr acons | |
67 "ASSOC-VALUE is an alist accessor very much like ASSOC, but it can | |
68 be used with SETF.") | |
69 (define-alist-get rassoc-value rassoc car racons | |
70 "RASSOC-VALUE is an alist accessor very much like RASSOC, but it can | |
71 be used with SETF.")) | |
72 | |
73 (defun malformed-plist (plist) | |
74 (error "Malformed plist: ~S" plist)) | |
75 | |
76 (defmacro doplist ((key val plist &optional values) &body body) | |
77 "Iterates over elements of PLIST. BODY can be preceded by | |
78 declarations, and is like a TAGBODY. RETURN may be used to terminate | |
79 the iteration early. If RETURN is not used, returns VALUES." | |
80 (multiple-value-bind (forms declarations) (parse-body body) | |
81 (with-gensyms (tail loop results) | |
82 `(block nil | |
83 (flet ((,results () | |
84 (let (,key ,val) | |
85 (declare (ignorable ,key ,val)) | |
86 (return ,values)))) | |
87 (let* ((,tail ,plist) | |
88 (,key (if ,tail | |
89 (pop ,tail) | |
90 (,results))) | |
91 (,val (if ,tail | |
92 (pop ,tail) | |
93 (malformed-plist ',plist)))) | |
94 (declare (ignorable ,key ,val)) | |
95 ,@declarations | |
96 (tagbody | |
97 ,loop | |
98 ,@forms | |
99 (setf ,key (if ,tail | |
100 (pop ,tail) | |
101 (,results)) | |
102 ,val (if ,tail | |
103 (pop ,tail) | |
104 (malformed-plist ',plist))) | |
105 (go ,loop)))))))) | |
106 | |
107 (define-modify-macro appendf (&rest lists) append | |
108 "Modify-macro for APPEND. Appends LISTS to the place designated by the… | |
109 argument.") | |
110 | |
111 (define-modify-macro nconcf (&rest lists) nconc | |
112 "Modify-macro for NCONC. Concatenates LISTS to place designated by the… | |
113 argument.") | |
114 | |
115 (define-modify-macro unionf (list &rest args) union | |
116 "Modify-macro for UNION. Saves the union of LIST and the contents of t… | |
117 place designated by the first argument to the designated place.") | |
118 | |
119 (define-modify-macro nunionf (list &rest args) nunion | |
120 "Modify-macro for NUNION. Saves the union of LIST and the contents of … | |
121 place designated by the first argument to the designated place. May modi… | |
122 either argument.") | |
123 | |
124 (define-modify-macro reversef () reverse | |
125 "Modify-macro for REVERSE. Copies and reverses the list stored in the … | |
126 place and saves back the result into the place.") | |
127 | |
128 (define-modify-macro nreversef () nreverse | |
129 "Modify-macro for NREVERSE. Reverses the list stored in the given plac… | |
130 destructively modifying it and saves back the result into the place.") | |
131 | |
132 (defun circular-list (&rest elements) | |
133 "Creates a circular list of ELEMENTS." | |
134 (let ((cycle (copy-list elements))) | |
135 (nconc cycle cycle))) | |
136 | |
137 (defun circular-list-p (object) | |
138 "Returns true if OBJECT is a circular list, NIL otherwise." | |
139 (and (listp object) | |
140 (do ((fast object (cddr fast)) | |
141 (slow (cons (car object) (cdr object)) (cdr slow))) | |
142 (nil) | |
143 (unless (and (consp fast) (listp (cdr fast))) | |
144 (return nil)) | |
145 (when (eq fast slow) | |
146 (return t))))) | |
147 | |
148 (defun circular-tree-p (object) | |
149 "Returns true if OBJECT is a circular tree, NIL otherwise." | |
150 (labels ((circularp (object seen) | |
151 (and (consp object) | |
152 (do ((fast (cons (car object) (cdr object)) (cddr fast… | |
153 (slow object (cdr slow))) | |
154 (nil) | |
155 (when (or (eq fast slow) (member slow seen)) | |
156 (return-from circular-tree-p t)) | |
157 (when (or (not (consp fast)) (not (consp (cdr slow))… | |
158 (return | |
159 (do ((tail object (cdr tail))) | |
160 ((not (consp tail)) | |
161 nil) | |
162 (let ((elt (car tail))) | |
163 (circularp elt (cons object seen)))))))))) | |
164 (circularp object nil))) | |
165 | |
166 (defun proper-list-p (object) | |
167 "Returns true if OBJECT is a proper list." | |
168 (cond ((not object) | |
169 t) | |
170 ((consp object) | |
171 (do ((fast object (cddr fast)) | |
172 (slow (cons (car object) (cdr object)) (cdr slow))) | |
173 (nil) | |
174 (unless (and (listp fast) (consp (cdr fast))) | |
175 (return (and (listp fast) (not (cdr fast))))) | |
176 (when (eq fast slow) | |
177 (return nil)))) | |
178 (t | |
179 nil))) | |
180 | |
181 (deftype proper-list () | |
182 "Type designator for proper lists. Implemented as a SATISFIES type, he… | |
183 not recommended for performance intensive use. Main usefullness as a type | |
184 designator of the expected type in a TYPE-ERROR." | |
185 `(and list (satisfies proper-list-p))) | |
186 | |
187 (defun circular-list-error (list) | |
188 (error 'type-error | |
189 :datum list | |
190 :expected-type '(and list (not circular-list)))) | |
191 | |
192 (macrolet ((def (name lambda-list doc step declare ret1 ret2) | |
193 (assert (member 'list lambda-list)) | |
194 `(defun ,name ,lambda-list | |
195 ,doc | |
196 (unless (listp list) | |
197 (error 'type-error :datum list :expected-type 'list)) | |
198 (do ((last list fast) | |
199 (fast list (cddr fast)) | |
200 (slow (cons (car list) (cdr list)) (cdr slow)) | |
201 ,@(when step (list step))) | |
202 (nil) | |
203 (declare (dynamic-extent slow) ,@(when declare (list d… | |
204 (ignorable last)) | |
205 (when (safe-endp fast) | |
206 (return ,ret1)) | |
207 (when (safe-endp (cdr fast)) | |
208 (return ,ret2)) | |
209 (when (eq fast slow) | |
210 (circular-list-error list)))))) | |
211 (def proper-list-length (list) | |
212 "Returns length of LIST, signalling an error if it is not a proper l… | |
213 (n 1 (+ n 2)) | |
214 ;; KLUDGE: Most implementations don't actually support lists with bi… | |
215 ;; elements -- and this is WAY faster on most implementations then d… | |
216 ;; N to be an UNSIGNED-BYTE. | |
217 (fixnum n) | |
218 (1- n) | |
219 n) | |
220 | |
221 (def lastcar (list) | |
222 "Returns the last element of LIST. Signals a type-error if LIST is… | |
223 proper list." | |
224 nil | |
225 nil | |
226 (cadr last) | |
227 (car fast)) | |
228 | |
229 (def (setf lastcar) (object list) | |
230 "Sets the last element of LIST. Signals a type-error if LIST is no… | |
231 list." | |
232 nil | |
233 nil | |
234 (setf (cadr last) object) | |
235 (setf (car fast) object))) | |
236 | |
237 (defun make-circular-list (length &key initial-element) | |
238 "Creates a circular list of LENGTH with the given INITIAL-ELEMENT." | |
239 (let ((cycle (make-list length :initial-element initial-element))) | |
240 (nconc cycle cycle))) | |
241 | |
242 (deftype circular-list () | |
243 "Type designator for circular lists. Implemented as a SATISFIES type, … | |
244 recommended for performance intensive use. Main usefullness as the | |
245 expected-type designator of a TYPE-ERROR." | |
246 `(satisfies circular-list-p)) | |
247 | |
248 (defun ensure-car (thing) | |
249 "If THING is a CONS, its CAR is returned. Otherwise THING is returned." | |
250 (if (consp thing) | |
251 (car thing) | |
252 thing)) | |
253 | |
254 (defun ensure-cons (cons) | |
255 "If CONS is a cons, it is returned. Otherwise returns a fresh cons wit… | |
256 in the car, and NIL in the cdr." | |
257 (if (consp cons) | |
258 cons | |
259 (cons cons nil))) | |
260 | |
261 (defun ensure-list (list) | |
262 "If LIST is a list, it is returned. Otherwise returns the list designa… | |
263 (if (listp list) | |
264 list | |
265 (list list))) | |
266 | |
267 (defun remove-from-plist (plist &rest keys) | |
268 "Returns a propery-list with same keys and values as PLIST, except tha… | |
269 in the list designated by KEYS and values corresponding to them are remo… | |
270 The returned property-list may share structure with the PLIST, but PLIST… | |
271 not destructively modified. Keys are compared using EQ." | |
272 (declare (optimize (speed 3))) | |
273 ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) … | |
274 ;; could return the tail without consing up a new list. | |
275 (loop for (key . rest) on plist by #'cddr | |
276 do (assert rest () "Expected a proper plist, got ~S" plist) | |
277 unless (member key keys :test #'eq) | |
278 collect key and collect (first rest))) | |
279 | |
280 (defun delete-from-plist (plist &rest keys) | |
281 "Just like REMOVE-FROM-PLIST, but this version may destructively modif… | |
282 provided PLIST." | |
283 (declare (optimize speed)) | |
284 (loop with head = plist | |
285 with tail = nil ; a nil tail means an empty result so far | |
286 for (key . rest) on plist by #'cddr | |
287 do (assert rest () "Expected a proper plist, got ~S" plist) | |
288 (if (member key keys :test #'eq) | |
289 ;; skip over this pair | |
290 (let ((next (cdr rest))) | |
291 (if tail | |
292 (setf (cdr tail) next) | |
293 (setf head next))) | |
294 ;; keep this pair | |
295 (setf tail rest)) | |
296 finally (return head))) | |
297 | |
298 (define-modify-macro remove-from-plistf (&rest keys) remove-from-plist | |
299 "Modify macro for REMOVE-FROM-PLIST.") | |
300 (define-modify-macro delete-from-plistf (&rest keys) delete-from-plist | |
301 "Modify macro for DELETE-FROM-PLIST.") | |
302 | |
303 (declaim (inline sans)) | |
304 (defun sans (plist &rest keys) | |
305 "Alias of REMOVE-FROM-PLIST for backward compatibility." | |
306 (apply #'remove-from-plist plist keys)) | |
307 | |
308 (defun mappend (function &rest lists) | |
309 "Applies FUNCTION to respective element(s) of each LIST, appending all… | |
310 all the result list to a single list. FUNCTION must return a list." | |
311 (loop for results in (apply #'mapcar function lists) | |
312 append results)) | |
313 | |
314 (defun setp (object &key (test #'eql) (key #'identity)) | |
315 "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A… | |
316 denotes a set if each element of the list is unique under KEY and TEST." | |
317 (and (listp object) | |
318 (let (seen) | |
319 (dolist (elt object t) | |
320 (let ((key (funcall key elt))) | |
321 (if (member key seen :test test) | |
322 (return nil) | |
323 (push key seen))))))) | |
324 | |
325 (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) | |
326 "Returns true if every element of LIST1 matches some element of LIST2 … | |
327 every element of LIST2 matches some element of LIST1. Otherwise returns … | |
328 (let ((keylist1 (if keyp (mapcar key list1) list1)) | |
329 (keylist2 (if keyp (mapcar key list2) list2))) | |
330 (and (dolist (elt keylist1 t) | |
331 (or (member elt keylist2 :test test) | |
332 (return nil))) | |
333 (dolist (elt keylist2 t) | |
334 (or (member elt keylist1 :test test) | |
335 (return nil)))))) | |
336 | |
337 (defun map-product (function list &rest more-lists) | |
338 "Returns a list containing the results of calling FUNCTION with one ar… | |
339 from LIST, and one from each of MORE-LISTS for each combination of argum… | |
340 In other words, returns the product of LIST and MORE-LISTS using FUNCTIO… | |
341 | |
342 Example: | |
343 | |
344 (map-product 'list '(1 2) '(3 4) '(5 6)) | |
345 => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) | |
346 (2 3 5) (2 3 6) (2 4 5) (2 4 6)) | |
347 " | |
348 (labels ((%map-product (f lists) | |
349 (let ((more (cdr lists)) | |
350 (one (car lists))) | |
351 (if (not more) | |
352 (mapcar f one) | |
353 (mappend (lambda (x) | |
354 (%map-product (curry f x) more)) | |
355 one))))) | |
356 (%map-product (ensure-function function) (cons list more-lists)))) | |
357 | |
358 (defun flatten (tree) | |
359 "Traverses the tree in order, collecting non-null leaves into a list." | |
360 (let (list) | |
361 (labels ((traverse (subtree) | |
362 (when subtree | |
363 (if (consp subtree) | |
364 (progn | |
365 (traverse (car subtree)) | |
366 (traverse (cdr subtree))) | |
367 (push subtree list))))) | |
368 (traverse tree)) | |
369 (nreverse list))) |