Mercurial > lasercutter

comparison src/clojure/zip.clj @ 10:ef7dbbd6452c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
added clojure source goodness
author Robert McIntyre <rlm@mit.edu>
date Sat, 21 Aug 2010 06:25:44 -0400
parents
children
comparison
equal deleted inserted replaced
9:35cf337adfcf 10:ef7dbbd6452c
1 ; Copyright (c) Rich Hickey. All rights reserved.
2 ; The use and distribution terms for this software are covered by the
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 ; which can be found in the file epl-v10.html at the root of this distribution.
5 ; By using this software in any fashion, you are agreeing to be bound by
6 ; the terms of this license.
7 ; You must not remove this notice, or any other, from this software.
8
9 ;functional hierarchical zipper, with navigation, editing and enumeration
10 ;see Huet
11
12 (ns ^{:doc "Functional hierarchical zipper, with navigation, editing,
13 and enumeration. See Huet"
14 :author "Rich Hickey"}
15 clojure.zip
16 (:refer-clojure :exclude (replace remove next)))
17
18 (defn zipper
19 "Creates a new zipper structure.
20
21 branch? is a fn that, given a node, returns true if can have
22 children, even if it currently doesn't.
23
24 children is a fn that, given a branch node, returns a seq of its
25 children.
26
27 make-node is a fn that, given an existing node and a seq of
28 children, returns a new branch node with the supplied children.
29 root is the root node."
30 {:added "1.0"}
31 [branch? children make-node root]
32 ^{:zip/branch? branch? :zip/children children :zip/make-node make-node}
33 [root nil])
34
35 (defn seq-zip
36 "Returns a zipper for nested sequences, given a root sequence"
37 {:added "1.0"}
38 [root]
39 (zipper seq?
40 identity
41 (fn [node children] (with-meta children (meta node)))
42 root))
43
44 (defn vector-zip
45 "Returns a zipper for nested vectors, given a root vector"
46 {:added "1.0"}
47 [root]
48 (zipper vector?
49 seq
50 (fn [node children] (with-meta (vec children) (meta node)))
51 root))
52
53 (defn xml-zip
54 "Returns a zipper for xml elements (as from xml/parse),
55 given a root element"
56 {:added "1.0"}
57 [root]
58 (zipper (complement string?)
59 (comp seq :content)
60 (fn [node children]
61 (assoc node :content (and children (apply vector children))))
62 root))
63
64 (defn node
65 "Returns the node at loc"
66 {:added "1.0"}
67 [loc] (loc 0))
68
69 (defn branch?
70 "Returns true if the node at loc is a branch"
71 {:added "1.0"}
72 [loc]
73 ((:zip/branch? (meta loc)) (node loc)))
74
75 (defn children
76 "Returns a seq of the children of node at loc, which must be a branch"
77 {:added "1.0"}
78 [loc]
79 (if (branch? loc)
80 ((:zip/children (meta loc)) (node loc))
81 (throw (Exception. "called children on a leaf node"))))
82
83 (defn make-node
84 "Returns a new branch node, given an existing node and new
85 children. The loc is only used to supply the constructor."
86 {:added "1.0"}
87 [loc node children]
88 ((:zip/make-node (meta loc)) node children))
89
90 (defn path
91 "Returns a seq of nodes leading to this loc"
92 {:added "1.0"}
93 [loc]
94 (:pnodes (loc 1)))
95
96 (defn lefts
97 "Returns a seq of the left siblings of this loc"
98 {:added "1.0"}
99 [loc]
100 (seq (:l (loc 1))))
101
102 (defn rights
103 "Returns a seq of the right siblings of this loc"
104 {:added "1.0"}
105 [loc]
106 (:r (loc 1)))
107
108
109 (defn down
110 "Returns the loc of the leftmost child of the node at this loc, or
111 nil if no children"
112 {:added "1.0"}
113 [loc]
114 (when (branch? loc)
115 (let [[node path] loc
116 [c & cnext :as cs] (children loc)]
117 (when cs
118 (with-meta [c {:l []
119 :pnodes (if path (conj (:pnodes path) node) [node])
120 :ppath path
121 :r cnext}] (meta loc))))))
122
123 (defn up
124 "Returns the loc of the parent of the node at this loc, or nil if at
125 the top"
126 {:added "1.0"}
127 [loc]
128 (let [[node {l :l, ppath :ppath, pnodes :pnodes r :r, changed? :changed?, :as path}] loc]
129 (when pnodes
130 (let [pnode (peek pnodes)]
131 (with-meta (if changed?
132 [(make-node loc pnode (concat l (cons node r)))
133 (and ppath (assoc ppath :changed? true))]
134 [pnode ppath])
135 (meta loc))))))
136
137 (defn root
138 "zips all the way up and returns the root node, reflecting any
139 changes."
140 {:added "1.0"}
141 [loc]
142 (if (= :end (loc 1))
143 (node loc)
144 (let [p (up loc)]
145 (if p
146 (recur p)
147 (node loc)))))
148
149 (defn right
150 "Returns the loc of the right sibling of the node at this loc, or nil"
151 {:added "1.0"}
152 [loc]
153 (let [[node {l :l [r & rnext :as rs] :r :as path}] loc]
154 (when (and path rs)
155 (with-meta [r (assoc path :l (conj l node) :r rnext)] (meta loc)))))
156
157 (defn rightmost
158 "Returns the loc of the rightmost sibling of the node at this loc, or self"
159 {:added "1.0"}
160 [loc]
161 (let [[node {l :l r :r :as path}] loc]
162 (if (and path r)
163 (with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] (meta loc))
164 loc)))
165
166 (defn left
167 "Returns the loc of the left sibling of the node at this loc, or nil"
168 {:added "1.0"}
169 [loc]
170 (let [[node {l :l r :r :as path}] loc]
171 (when (and path (seq l))
172 (with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] (meta loc)))))
173
174 (defn leftmost
175 "Returns the loc of the leftmost sibling of the node at this loc, or self"
176 {:added "1.0"}
177 [loc]
178 (let [[node {l :l r :r :as path}] loc]
179 (if (and path (seq l))
180 (with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] (meta loc))
181 loc)))
182
183 (defn insert-left
184 "Inserts the item as the left sibling of the node at this loc,
185 without moving"
186 {:added "1.0"}
187 [loc item]
188 (let [[node {l :l :as path}] loc]
189 (if (nil? path)
190 (throw (new Exception "Insert at top"))
191 (with-meta [node (assoc path :l (conj l item) :changed? true)] (meta loc)))))
192
193 (defn insert-right
194 "Inserts the item as the right sibling of the node at this loc,
195 without moving"
196 {:added "1.0"}
197 [loc item]
198 (let [[node {r :r :as path}] loc]
199 (if (nil? path)
200 (throw (new Exception "Insert at top"))
201 (with-meta [node (assoc path :r (cons item r) :changed? true)] (meta loc)))))
202
203 (defn replace
204 "Replaces the node at this loc, without moving"
205 {:added "1.0"}
206 [loc node]
207 (let [[_ path] loc]
208 (with-meta [node (assoc path :changed? true)] (meta loc))))
209
210 (defn edit
211 "Replaces the node at this loc with the value of (f node args)"
212 {:added "1.0"}
213 [loc f & args]
214 (replace loc (apply f (node loc) args)))
215
216 (defn insert-child
217 "Inserts the item as the leftmost child of the node at this loc,
218 without moving"
219 {:added "1.0"}
220 [loc item]
221 (replace loc (make-node loc (node loc) (cons item (children loc)))))
222
223 (defn append-child
224 "Inserts the item as the rightmost child of the node at this loc,
225 without moving"
226 {:added "1.0"}
227 [loc item]
228 (replace loc (make-node loc (node loc) (concat (children loc) [item]))))
229
230 (defn next
231 "Moves to the next loc in the hierarchy, depth-first. When reaching
232 the end, returns a distinguished loc detectable via end?. If already
233 at the end, stays there."
234 {:added "1.0"}
235 [loc]
236 (if (= :end (loc 1))
237 loc
238 (or
239 (and (branch? loc) (down loc))
240 (right loc)
241 (loop [p loc]
242 (if (up p)
243 (or (right (up p)) (recur (up p)))
244 [(node p) :end])))))
245
246 (defn prev
247 "Moves to the previous loc in the hierarchy, depth-first. If already
248 at the root, returns nil."
249 {:added "1.0"}
250 [loc]
251 (if-let [lloc (left loc)]
252 (loop [loc lloc]
253 (if-let [child (and (branch? loc) (down loc))]
254 (recur (rightmost child))
255 loc))
256 (up loc)))
257
258 (defn end?
259 "Returns true if loc represents the end of a depth-first walk"
260 {:added "1.0"}
261 [loc]
262 (= :end (loc 1)))
263
264 (defn remove
265 "Removes the node at loc, returning the loc that would have preceded
266 it in a depth-first walk."
267 {:added "1.0"}
268 [loc]
269 (let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc]
270 (if (nil? path)
271 (throw (new Exception "Remove at top"))
272 (if (pos? (count l))
273 (loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] (meta loc))]
274 (if-let [child (and (branch? loc) (down loc))]
275 (recur (rightmost child))
276 loc))
277 (with-meta [(make-node loc (peek pnodes) rs)
278 (and ppath (assoc ppath :changed? true))]
279 (meta loc))))))
280
281 (comment
282
283 (load-file "/Users/rich/dev/clojure/src/zip.clj")
284 (refer 'zip)
285 (def data '[[a * b] + [c * d]])
286 (def dz (vector-zip data))
287
288 (right (down (right (right (down dz)))))
289 (lefts (right (down (right (right (down dz))))))
290 (rights (right (down (right (right (down dz))))))
291 (up (up (right (down (right (right (down dz)))))))
292 (path (right (down (right (right (down dz))))))
293
294 (-> dz down right right down right)
295 (-> dz down right right down right (replace '/) root)
296 (-> dz next next (edit str) next next next (replace '/) root)
297 (-> dz next next next next next next next next next remove root)
298 (-> dz next next next next next next next next next remove (insert-right 'e) root)
299 (-> dz next next next next next next next next next remove up (append-child 'e) root)
300
301 (end? (-> dz next next next next next next next next next remove next))
302
303 (-> dz next remove next remove root)
304
305 (loop [loc dz]
306 (if (end? loc)
307 (root loc)
308 (recur (next (if (= '* (node loc))
309 (replace loc '/)
310 loc)))))
311
312 (loop [loc dz]
313 (if (end? loc)
314 (root loc)
315 (recur (next (if (= '* (node loc))
316 (remove loc)
317 loc)))))
318 )