Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 292 lines (249 sloc) 9.02 kb
8252c8b4 »
2011-07-17 direct port from Clojure, changed only :added metadata and exception …
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 [branch? children make-node root]
31 ^{:zip/branch? branch? :zip/children children :zip/make-node make-node}
32 [root nil])
33
34 (defn seq-zip
35 "Returns a zipper for nested sequences, given a root sequence"
36 [root]
37 (zipper seq?
38 identity
39 (fn [node children] (with-meta children (meta node)))
40 root))
41
42 (defn vector-zip
43 "Returns a zipper for nested vectors, given a root vector"
44 [root]
45 (zipper vector?
46 seq
47 (fn [node children] (with-meta (vec children) (meta node)))
48 root))
49
50 (defn xml-zip
51 "Returns a zipper for xml elements (as from xml/parse),
52 given a root element"
53 [root]
54 (zipper (complement string?)
55 (comp seq :content)
56 (fn [node children]
57 (assoc node :content (and children (apply vector children))))
58 root))
59
60 (defn node
61 "Returns the node at loc"
62 [loc] (loc 0))
63
64 (defn branch?
65 "Returns true if the node at loc is a branch"
66 [loc]
67 ((:zip/branch? (meta loc)) (node loc)))
68
69 (defn children
70 "Returns a seq of the children of node at loc, which must be a branch"
71 [loc]
72 (if (branch? loc)
73 ((:zip/children (meta loc)) (node loc))
74 (throw "called children on a leaf node")))
75
76 (defn make-node
77 "Returns a new branch node, given an existing node and new
78 children. The loc is only used to supply the constructor."
79 [loc node children]
80 ((:zip/make-node (meta loc)) node children))
81
82 (defn path
83 "Returns a seq of nodes leading to this loc"
84 [loc]
85 (:pnodes (loc 1)))
86
87 (defn lefts
88 "Returns a seq of the left siblings of this loc"
89 [loc]
90 (seq (:l (loc 1))))
91
92 (defn rights
93 "Returns a seq of the right siblings of this loc"
94 [loc]
95 (:r (loc 1)))
96
97
98 (defn down
99 "Returns the loc of the leftmost child of the node at this loc, or
100 nil if no children"
101 [loc]
102 (when (branch? loc)
103 (let [[node path] loc
104 [c & cnext :as cs] (children loc)]
105 (when cs
106 (with-meta [c {:l []
107 :pnodes (if path (conj (:pnodes path) node) [node])
108 :ppath path
109 :r cnext}] (meta loc))))))
110
111 (defn up
112 "Returns the loc of the parent of the node at this loc, or nil if at
113 the top"
114 [loc]
115 (let [[node {l :l, ppath :ppath, pnodes :pnodes r :r, changed? :changed?, :as path}] loc]
116 (when pnodes
117 (let [pnode (peek pnodes)]
118 (with-meta (if changed?
119 [(make-node loc pnode (concat l (cons node r)))
120 (and ppath (assoc ppath :changed? true))]
121 [pnode ppath])
122 (meta loc))))))
123
124 (defn root
125 "zips all the way up and returns the root node, reflecting any
126 changes."
127 [loc]
128 (if (= :end (loc 1))
129 (node loc)
130 (let [p (up loc)]
131 (if p
132 (recur p)
133 (node loc)))))
134
135 (defn right
136 "Returns the loc of the right sibling of the node at this loc, or nil"
137 [loc]
138 (let [[node {l :l [r & rnext :as rs] :r :as path}] loc]
139 (when (and path rs)
140 (with-meta [r (assoc path :l (conj l node) :r rnext)] (meta loc)))))
141
142 (defn rightmost
143 "Returns the loc of the rightmost sibling of the node at this loc, or self"
144 [loc]
145 (let [[node {l :l r :r :as path}] loc]
146 (if (and path r)
147 (with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] (meta loc))
148 loc)))
149
150 (defn left
151 "Returns the loc of the left sibling of the node at this loc, or nil"
152 [loc]
153 (let [[node {l :l r :r :as path}] loc]
154 (when (and path (seq l))
155 (with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] (meta loc)))))
156
157 (defn leftmost
158 "Returns the loc of the leftmost sibling of the node at this loc, or self"
159 [loc]
160 (let [[node {l :l r :r :as path}] loc]
161 (if (and path (seq l))
162 (with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] (meta loc))
163 loc)))
164
165 (defn insert-left
166 "Inserts the item as the left sibling of the node at this loc,
167 without moving"
168 [loc item]
169 (let [[node {l :l :as path}] loc]
170 (if (nil? path)
171 (throw "Insert at top")
172 (with-meta [node (assoc path :l (conj l item) :changed? true)] (meta loc)))))
173
174 (defn insert-right
175 "Inserts the item as the right sibling of the node at this loc,
176 without moving"
177 [loc item]
178 (let [[node {r :r :as path}] loc]
179 (if (nil? path)
180 (throw "Insert at top")
181 (with-meta [node (assoc path :r (cons item r) :changed? true)] (meta loc)))))
182
183 (defn replace
184 "Replaces the node at this loc, without moving"
185 [loc node]
186 (let [[_ path] loc]
187 (with-meta [node (assoc path :changed? true)] (meta loc))))
188
189 (defn edit
190 "Replaces the node at this loc with the value of (f node args)"
191 [loc f & args]
192 (replace loc (apply f (node loc) args)))
193
194 (defn insert-child
195 "Inserts the item as the leftmost child of the node at this loc,
196 without moving"
197 [loc item]
198 (replace loc (make-node loc (node loc) (cons item (children loc)))))
199
200 (defn append-child
201 "Inserts the item as the rightmost child of the node at this loc,
202 without moving"
203 [loc item]
204 (replace loc (make-node loc (node loc) (concat (children loc) [item]))))
205
206 (defn next
207 "Moves to the next loc in the hierarchy, depth-first. When reaching
208 the end, returns a distinguished loc detectable via end?. If already
209 at the end, stays there."
210 [loc]
211 (if (= :end (loc 1))
212 loc
213 (or
214 (and (branch? loc) (down loc))
215 (right loc)
216 (loop [p loc]
217 (if (up p)
218 (or (right (up p)) (recur (up p)))
219 [(node p) :end])))))
220
221 (defn prev
222 "Moves to the previous loc in the hierarchy, depth-first. If already
223 at the root, returns nil."
224 [loc]
225 (if-let [lloc (left loc)]
226 (loop [loc lloc]
227 (if-let [child (and (branch? loc) (down loc))]
228 (recur (rightmost child))
229 loc))
230 (up loc)))
231
232 (defn end?
233 "Returns true if loc represents the end of a depth-first walk"
234 [loc]
235 (= :end (loc 1)))
236
237 (defn remove
238 "Removes the node at loc, returning the loc that would have preceded
239 it in a depth-first walk."
240 [loc]
241 (let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc]
242 (if (nil? path)
243 (throw "Remove at top")
244 (if (pos? (count l))
245 (loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] (meta loc))]
246 (if-let [child (and (branch? loc) (down loc))]
247 (recur (rightmost child))
248 loc))
249 (with-meta [(make-node loc (peek pnodes) rs)
250 (and ppath (assoc ppath :changed? true))]
251 (meta loc))))))
252
253 (comment
254
255 (load-file "/Users/rich/dev/clojure/src/zip.clj")
256 (refer 'zip)
257 (def data '[[a * b] + [c * d]])
258 (def dz (vector-zip data))
259
260 (right (down dz))
261 (right (down (right (right (down dz)))))
262 (lefts (right (down (right (right (down dz))))))
263 (rights (right (down (right (right (down dz))))))
264 (up (up (right (down (right (right (down dz)))))))
265 (path (right (down (right (right (down dz))))))
266
267 (-> dz down right right down right)
268 (-> dz down right right down right (replace '/) root)
269 (-> dz next next (edit str) next next next (replace '/) root)
270 (-> dz next next next next next next next next next remove root)
271 (-> dz next next next next next next next next next remove (insert-right 'e) root)
272 (-> dz next next next next next next next next next remove up (append-child 'e) root)
273
274 (end? (-> dz next next next next next next next next next remove next))
275
276 (-> dz next remove next remove root)
277
278 (loop [loc dz]
279 (if (end? loc)
280 (root loc)
281 (recur (next (if (= '* (node loc))
282 (replace loc '/)
283 loc)))))
284
285 (loop [loc dz]
286 (if (end? loc)
287 (root loc)
288 (recur (next (if (= '* (node loc))
289 (remove loc)
290 loc)))))
291 )
Something went wrong with that request. Please try again.