-
Notifications
You must be signed in to change notification settings - Fork 15
/
Copy pathtcons-tree.lisp
210 lines (185 loc) · 8.38 KB
/
tcons-tree.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
;;;; functions to implement list-based trees
;;;; This software is derived from the SBCL system.
;;;; See the README.SBCL file for more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package :stmx.util)
(enable-#?-syntax)
(declaim (notinline tree-equal-test tree-equal-test-not))
(defun ttree-equal-test-not (x y test-not)
(declare (type function test-not))
(cond ((tconsp x)
(and (tconsp y)
(ttree-equal-test-not (tcar x) (tcar y) test-not)
(ttree-equal-test-not (tcdr x) (tcdr y) test-not)))
((tconsp y) nil)
((not (funcall test-not x y)) t)
(t ())))
(defun ttree-equal-test (x y test)
(declare (type function test))
(cond ((tconsp x)
(and (tconsp y)
(ttree-equal-test (tcar x) (tcar y) test)
(ttree-equal-test (tcdr x) (tcdr y) test)))
((tconsp y) nil)
((funcall test x y) t)
(t ())))
(defun ttree-equal (x y &key (test #'eql testp) (test-not nil notp))
"Return T if X and Y are isomorphic TLIST trees with identical leaves."
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(flet ((to-function (callable)
(etypecase callable
(function callable)
(symbol (fdefinition callable))
(cons (fdefinition callable)))))
(if test-not
(ttree-equal-test-not x y (to-function test-not))
(ttree-equal-test x y (to-function test)))))
(defun copy-ttree (tree)
"Recursively copy trees of TCONSes."
(if (tconsp tree)
(let ((result (tlist (let ((car (tcons-first tree)))
(if (tconsp car)
(copy-ttree car)
car)))))
(loop
for last-cons = result then new-cons
for cdr = (tcons-rest tree) then (tcons-rest cdr)
for car = (if (tconsp cdr)
(tcons-first cdr)
(return (setf (trest last-cons) cdr)))
for new-cons = (tlist (if (tconsp car)
(copy-ttree car)
car))
do (setf (trest last-cons) new-cons))
result)
tree))
#|
;;;; :KEY arg optimization to save funcall of IDENTITY
;;; APPLY-KEY saves us a function call sometimes.
;;; This isn't wrapped in an (EVAL-WHEN (COMPILE EVAL) ..)
;;; because it's used in seq.lisp and sort.lisp.
(defmacro apply-key (key element)
`(if ,key
(funcall ,key ,element)
,element))
;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP))
;;; Use these with the following &KEY args:
(defmacro with-set-keys (funcall)
`(if notp
,(append funcall '(:key key :test-not test-not))
,(append funcall '(:key key :test test))))
(defmacro satisfies-the-test (item elt)
(let ((key-tmp (gensym)))
`(let ((,key-tmp (apply-key key ,elt)))
(cond (testp (funcall test ,item ,key-tmp))
(notp (not (funcall test-not ,item ,key-tmp)))
(t (funcall test ,item ,key-tmp))))))
;;;; substitution of expressions
(defun subst (new old tree &key key (test #'eql testp) (test-not #'eql notp))
"Substitutes new for subtrees matching old."
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
(test (if testp (%coerce-callable-to-fun test) test))
(test-not (if notp (%coerce-callable-to-fun test-not) test-not)))
(declare (type function test test-not))
(labels ((s (subtree)
(cond ((satisfies-the-test old subtree) new)
((atom subtree) subtree)
(t (let ((car (s (car subtree)))
(cdr (s (cdr subtree))))
(if (and (eq car (car subtree))
(eq cdr (cdr subtree)))
subtree
(cons car cdr)))))))
(s tree))))
(defun subst-if (new test tree &key key)
"Substitutes new for subtrees for which test is true."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
(cond ((funcall test (apply-key key subtree)) new)
((atom subtree) subtree)
(t (let ((car (s (car subtree)))
(cdr (s (cdr subtree))))
(if (and (eq car (car subtree))
(eq cdr (cdr subtree)))
subtree
(cons car cdr)))))))
(s tree))))
(defun subst-if-not (new test tree &key key)
"Substitutes new for subtrees for which test is false."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
(cond ((not (funcall test (apply-key key subtree))) new)
((atom subtree) subtree)
(t (let ((car (s (car subtree)))
(cdr (s (cdr subtree))))
(if (and (eq car (car subtree))
(eq cdr (cdr subtree)))
subtree
(cons car cdr)))))))
(s tree))))
(defun nsubst (new old tree &key key (test #'eql testp) (test-not #'eql notp))
"Substitute NEW for subtrees matching OLD."
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
(test (if testp (%coerce-callable-to-fun test) test))
(test-not (if notp (%coerce-callable-to-fun test-not) test-not)))
(declare (type function test test-not))
(labels ((s (subtree)
(cond ((satisfies-the-test old subtree) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
(subtree subtree (cdr subtree)))
((atom subtree)
(if (satisfies-the-test old subtree)
(setf (cdr last) new)))
(if (satisfies-the-test old subtree)
(return (setf (cdr last) new))
(setf (car subtree) (s (car subtree)))))
subtree))))
(s tree))))
(defun nsubst-if (new test tree &key key)
"Substitute NEW for subtrees of TREE for which TEST is true."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
(cond ((funcall test (apply-key key subtree)) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
(subtree subtree (cdr subtree)))
((atom subtree)
(if (funcall test (apply-key key subtree))
(setf (cdr last) new)))
(if (funcall test (apply-key key subtree))
(return (setf (cdr last) new))
(setf (car subtree) (s (car subtree)))))
subtree))))
(s tree))))
(defun nsubst-if-not (new test tree &key key)
"Substitute NEW for subtrees of TREE for which TEST is false."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
(cond ((not (funcall test (apply-key key subtree))) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
(subtree subtree (cdr subtree)))
((atom subtree)
(if (not (funcall test (apply-key key subtree)))
(setf (cdr last) new)))
(if (not (funcall test (apply-key key subtree)))
(return (setf (cdr last) new))
(setf (car subtree) (s (car subtree)))))
subtree))))
(s tree))))
|#