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