-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathlist.lisp
262 lines (226 loc) · 10.5 KB
/
list.lisp
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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
;;; -*- Package: de.setf.utility.implementation; -*-
;;; This file is part of the 'de.setf.utility' library component.
;;; It defines list utility operators
;;; Copyright 2009, 2009, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved
;;; 'de.setf.utility' is free software: you can redistribute it and/or modify
;;; it under the terms of version 3 of the GNU Lesser General Public License as published by
;;; the Free Software Foundation.
;;;
;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU Lesser General Public License for more details.
;;;
;;; A copy of the GNU Lesser General Public License should be included with `de.setf.utility`, as `lgpl.txt`.
;;; If not, see the GNU [site](http://www.gnu.org/licenses/).
;;; 2006-02-09 janderson added &aux collection to parse-lambda-list
;;; 2009-03-29 janderson incorporated partial-order-sort from old system
;;; definition tools
(in-package :de.setf.utility.implementation)
(modpackage :de.setf.utility
(:export
:collate
:combinations
:destructuring-keys
:lambda-list-arity
:map-plist
:do-plist
:collect-list
:with-gensyms
:gensym-macrolet
:make-weak-hash-table
:parse-lambda-list
:permutations
:partial-order-sort
))
(defun make-weak-hash-table (&key (weakness :key) (test 'eq))
;; don't constrain the weakness/test combination here, but a runtime may
#+clozure (make-hash-table :test test :weak weakness)
#+digitool (make-hash-table :test test :weak weakness)
#+lispworks (make-hash-table :test test :weak-kind weakness)
#+sbcl (make-hash-table :test test :weakness weakness)
)
(defmacro with-gensyms (variables &rest forms)
(setf forms
(sublis (mapcar #'(lambda (variable) (cons variable (gensym (string variable)))) variables)
forms))
(if (rest forms) (cons 'progn forms) (first forms)))
(defmacro gensym-macrolet (variables &rest forms)
(setf forms
(sublis (mapcar #'(lambda (variable) (cons variable (gensym (string variable)))) variables)
forms))
(if (rest forms) (cons 'progn forms) (first forms)))
#+digitool
(pushnew '(gensym-macrolet . 1) *fred-special-indent-alist* :key #'first)
(defun map-plist (function plist &aux key)
(declare (type cons plist) (optimize (speed 3) (safety 0)))
(loop (unless (consp plist) (return))
(setf key (first plist) plist (rest plist))
(unless (consp plist) (return))
(funcall function key (first plist))
(setf plist (rest plist))))
#| the tail-recursive form takes 30% longer
(defun map-plist (function plist &aux key)
(declare (type cons plist) (optimize (speed 3) (safety 0)))
(when (consp plist)
(setf key (first plist) plist (rest plist))
(when (consp plist)
(funcall function key (first plist))
(map-plist function (rest plist)))))|#
(defmacro do-plist ((p-var v-var list &optional result) &rest body
&aux (l-var (if (symbolp list) list (gensym))))
(let ((form `(do ((,p-var (pop ,l-var) (when (rest ,l-var) (pop ,l-var)))
(,v-var (pop ,l-var) (pop ,l-var)))
((null ,p-var) ,@(when result `(,result)))
,@body)))
(if (eq l-var list)
form
`(let ((,l-var ,list)) ,form))))
(defmacro collect-list ((collector &key (predicate 'identity) (finally 'rest) key last) &rest body)
(let ((list (gensym "LIST-"))
(end (gensym "END-")))
`(let* ((,list (list nil)) (,end ,list))
(block nil
(flet ((,collector (datum)
,@(when key `((setf datum (,key datum))))
,(case predicate
((nil) `(setf (rest ,end) (list datum) ,end (rest ,end)))
(identity `(when datum (setf (rest ,end) (list datum) ,end (rest ,end))))
(t `(when (funcall ,predicate datum) (setf (rest ,end) (list datum) ,end (rest ,end))))))
,@(when last
`(((setf ,last) (datum)
(setf (rest ,end) datum)))))
,@body))
(,finally ,list))))
#+digitool
(setf (ccl:assq 'collect-list *fred-special-indent-alist*) 1)
(defun collate (key list &key (test #'eq))
(let ((result nil) (entry nil) (key-value nil))
(dolist (element list)
(setf key-value (funcall key element))
(setf entry (assoc key-value result :test test))
(if entry
(push element (rest entry))
(push (list key-value element) result)))
(dolist (entry result)
(setf (rest entry) (nreverse (rest entry))))
result))
;(collate #'symbol-package '(+ - :test :one *))
;; nb. lispworks does not tolerate let variables with '&' initials
(defun parse-lambda-list (list)
(let ((.optional nil)
(.rest nil)
(.key nil)
(.allow-other-keys nil)
(.aux nil)
(positional nil)
(state nil))
(dolist (parameter list)
(case parameter
((&optional &rest &key &aux) (setf state parameter))
(&allow-other-keys (setf .allow-other-keys t))
(t (case state
(&optional (push parameter .optional))
(&rest (setf .rest parameter))
(&key (push parameter .key))
(&aux (push parameter .aux))
(t (push parameter positional))))))
`(,(nreverse positional)
,@(when .optional `(:optional ,(nreverse .optional)))
,@(when .rest `(:rest , .rest))
,@(when .key `(:key ,(nreverse .key)))
,@(when .allow-other-keys '(:allow-other-keys t))
,@(when .aux `(:aux ,(nreverse .aux))))))
(defun lambda-list-arity (lambda-list)
(length (first (parse-lambda-list lambda-list))))
(defgeneric permutations (sequence length)
(:method ((list list) length)
(labels ((permute (remaining-count)
(if (zerop remaining-count)
(mapcar #'list list)
(let ((base (permute (1- remaining-count)))
(new nil))
(dolist (permutation base new)
(dolist (element list)
(push (cons element permutation) new)))))))
(permute (1- length)))))
;(permutations '(:a :s :d) 2)
(defgeneric dsu:combinations (sequence)
(:method ((list list))
(labels ((combine (remaining)
(if (rest remaining)
(loop for elt in remaining
append (loop for combination in (combine (remove elt remaining))
collect (cons elt combination)))
(list remaining))))
(combine list))))
(defun partial-order-sort
(sequence predicate &key key
&aux (keys (if key (map 'vector key sequence) sequence))
(length (length sequence)))
"sort a series for which the order relation is partial.
SEQUENCE : sequence : for which to destrictively sort the elements
PREDICATE : (FUNCTION (t t) BOOLEAN)
:KEY : (FUNCTION (T) T)
performs a destructive sort of the sequence's elements, where by all
element are pairwise compared, in order to ensure the a partial
relation is observed."
(dotimes (i1 length)
(do* ((i2 (1+ i1) (1+ i2)))
((>= i2 length))
(when (and (funcall predicate (elt keys i2) (elt keys i1))
(not (funcall predicate (elt keys i1) (elt keys i2))))
(rotatef (elt sequence i2) (elt sequence i1)))))
sequence)
(defmacro destructuring-keys (lambda-list value &body body-arg &environment env)
(let* ((body (member-if #'(lambda (x) (not (and (consp x) (eq (first x) 'declare)))) body-arg))
(declarations (ldiff body-arg body)))
(destructuring-bind (required-arguments &key key rest) (parse-lambda-list lambda-list)
(assert (null required-arguments))
(unless rest
(setf rest
(if (and (symbolp value) (eq (macroexpand-1 value env) value)) value (gensym "rest"))))
(setf key (mapcar #'(lambda (key)
(etypecase key
(symbol `((,(intern (symbol-name key) :keyword) ,key) nil))
(cons (destructuring-bind (key value) key
(etypecase key
(symbol `((,(intern (symbol-name key) :keyword) ,key) ,value))
(cons `(,key ,value)))))))
key))
`(let (,@(unless (eq rest value) `((,rest ,value)))
,@(loop for ((nil variable) value) in key collect `(,variable ,value)))
,@declarations
(loop (case (first ,rest)
,@(loop for ((key variable) nil) in key
collect `(,key (pop ,rest) (setf ,variable (pop ,rest))))
(t (return))))
,@body))))
(assert (equalp (macroexpand-1 '(destructuring-keys (&key key1 key2) forms (declare (optimize)) (list key1 key2)))
'(let ((key1 nil) (key2 nil))
(declare (optimize))
(loop (case (first forms)
(:key1 (pop forms) (setf key1 (pop forms)))
(:key2 (pop forms) (setf key2 (pop forms))) (t (return))))
(list key1 key2))))
(assert (equalp (macroexpand-1 '(destructuring-keys (&rest rest-forms &key key1 key2) forms (list forms rest-forms key1 key2)))
'(let ((rest-forms forms) (key1 nil) (key2 nil))
(loop (case (first rest-forms)
(:key1 (pop rest-forms) (setf key1 (pop rest-forms)))
(:key2 (pop rest-forms) (setf key2 (pop rest-forms)))
(t (return))))
(list forms rest-forms key1 key2))))
(assert (equalp (subst-if t #'(lambda (x) (and (symbolp x) (null (symbol-package x))))
(macroexpand-1 '(destructuring-keys (&key key1 key2) (some forms) (declare (optimize)) (list key1 key2))))
'(let ((t (some forms)) (key1 nil) (key2 nil))
(declare (optimize))
(loop (case (first t)
(:key1 (pop t) (setf key1 (pop t)))
(:key2 (pop t) (setf key2 (pop t)))
(t (return))))
(list key1 key2))))
(defun plist-difference (plist keys)
(loop for (key value) on plist by #'cddr
unless (member key keys)
collect key and
collect value))
:de.setf.utility