Mercurial > lasercutter
diff src/clojure/zip.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
line wrap: on
line diff
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 1.2 +++ b/src/clojure/zip.clj Sat Aug 21 06:25:44 2010 -0400 1.3 @@ -0,0 +1,318 @@ 1.4 +; Copyright (c) Rich Hickey. All rights reserved. 1.5 +; The use and distribution terms for this software are covered by the 1.6 +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 1.7 +; which can be found in the file epl-v10.html at the root of this distribution. 1.8 +; By using this software in any fashion, you are agreeing to be bound by 1.9 +; the terms of this license. 1.10 +; You must not remove this notice, or any other, from this software. 1.11 + 1.12 +;functional hierarchical zipper, with navigation, editing and enumeration 1.13 +;see Huet 1.14 + 1.15 +(ns ^{:doc "Functional hierarchical zipper, with navigation, editing, 1.16 + and enumeration. See Huet" 1.17 + :author "Rich Hickey"} 1.18 + clojure.zip 1.19 + (:refer-clojure :exclude (replace remove next))) 1.20 + 1.21 +(defn zipper 1.22 + "Creates a new zipper structure. 1.23 + 1.24 + branch? is a fn that, given a node, returns true if can have 1.25 + children, even if it currently doesn't. 1.26 + 1.27 + children is a fn that, given a branch node, returns a seq of its 1.28 + children. 1.29 + 1.30 + make-node is a fn that, given an existing node and a seq of 1.31 + children, returns a new branch node with the supplied children. 1.32 + root is the root node." 1.33 + {:added "1.0"} 1.34 + [branch? children make-node root] 1.35 + ^{:zip/branch? branch? :zip/children children :zip/make-node make-node} 1.36 + [root nil]) 1.37 + 1.38 +(defn seq-zip 1.39 + "Returns a zipper for nested sequences, given a root sequence" 1.40 + {:added "1.0"} 1.41 + [root] 1.42 + (zipper seq? 1.43 + identity 1.44 + (fn [node children] (with-meta children (meta node))) 1.45 + root)) 1.46 + 1.47 +(defn vector-zip 1.48 + "Returns a zipper for nested vectors, given a root vector" 1.49 + {:added "1.0"} 1.50 + [root] 1.51 + (zipper vector? 1.52 + seq 1.53 + (fn [node children] (with-meta (vec children) (meta node))) 1.54 + root)) 1.55 + 1.56 +(defn xml-zip 1.57 + "Returns a zipper for xml elements (as from xml/parse), 1.58 + given a root element" 1.59 + {:added "1.0"} 1.60 + [root] 1.61 + (zipper (complement string?) 1.62 + (comp seq :content) 1.63 + (fn [node children] 1.64 + (assoc node :content (and children (apply vector children)))) 1.65 + root)) 1.66 + 1.67 +(defn node 1.68 + "Returns the node at loc" 1.69 + {:added "1.0"} 1.70 + [loc] (loc 0)) 1.71 + 1.72 +(defn branch? 1.73 + "Returns true if the node at loc is a branch" 1.74 + {:added "1.0"} 1.75 + [loc] 1.76 + ((:zip/branch? (meta loc)) (node loc))) 1.77 + 1.78 +(defn children 1.79 + "Returns a seq of the children of node at loc, which must be a branch" 1.80 + {:added "1.0"} 1.81 + [loc] 1.82 + (if (branch? loc) 1.83 + ((:zip/children (meta loc)) (node loc)) 1.84 + (throw (Exception. "called children on a leaf node")))) 1.85 + 1.86 +(defn make-node 1.87 + "Returns a new branch node, given an existing node and new 1.88 + children. The loc is only used to supply the constructor." 1.89 + {:added "1.0"} 1.90 + [loc node children] 1.91 + ((:zip/make-node (meta loc)) node children)) 1.92 + 1.93 +(defn path 1.94 + "Returns a seq of nodes leading to this loc" 1.95 + {:added "1.0"} 1.96 + [loc] 1.97 + (:pnodes (loc 1))) 1.98 + 1.99 +(defn lefts 1.100 + "Returns a seq of the left siblings of this loc" 1.101 + {:added "1.0"} 1.102 + [loc] 1.103 + (seq (:l (loc 1)))) 1.104 + 1.105 +(defn rights 1.106 + "Returns a seq of the right siblings of this loc" 1.107 + {:added "1.0"} 1.108 + [loc] 1.109 + (:r (loc 1))) 1.110 + 1.111 + 1.112 +(defn down 1.113 + "Returns the loc of the leftmost child of the node at this loc, or 1.114 + nil if no children" 1.115 + {:added "1.0"} 1.116 + [loc] 1.117 + (when (branch? loc) 1.118 + (let [[node path] loc 1.119 + [c & cnext :as cs] (children loc)] 1.120 + (when cs 1.121 + (with-meta [c {:l [] 1.122 + :pnodes (if path (conj (:pnodes path) node) [node]) 1.123 + :ppath path 1.124 + :r cnext}] (meta loc)))))) 1.125 + 1.126 +(defn up 1.127 + "Returns the loc of the parent of the node at this loc, or nil if at 1.128 + the top" 1.129 + {:added "1.0"} 1.130 + [loc] 1.131 + (let [[node {l :l, ppath :ppath, pnodes :pnodes r :r, changed? :changed?, :as path}] loc] 1.132 + (when pnodes 1.133 + (let [pnode (peek pnodes)] 1.134 + (with-meta (if changed? 1.135 + [(make-node loc pnode (concat l (cons node r))) 1.136 + (and ppath (assoc ppath :changed? true))] 1.137 + [pnode ppath]) 1.138 + (meta loc)))))) 1.139 + 1.140 +(defn root 1.141 + "zips all the way up and returns the root node, reflecting any 1.142 + changes." 1.143 + {:added "1.0"} 1.144 + [loc] 1.145 + (if (= :end (loc 1)) 1.146 + (node loc) 1.147 + (let [p (up loc)] 1.148 + (if p 1.149 + (recur p) 1.150 + (node loc))))) 1.151 + 1.152 +(defn right 1.153 + "Returns the loc of the right sibling of the node at this loc, or nil" 1.154 + {:added "1.0"} 1.155 + [loc] 1.156 + (let [[node {l :l [r & rnext :as rs] :r :as path}] loc] 1.157 + (when (and path rs) 1.158 + (with-meta [r (assoc path :l (conj l node) :r rnext)] (meta loc))))) 1.159 + 1.160 +(defn rightmost 1.161 + "Returns the loc of the rightmost sibling of the node at this loc, or self" 1.162 + {:added "1.0"} 1.163 + [loc] 1.164 + (let [[node {l :l r :r :as path}] loc] 1.165 + (if (and path r) 1.166 + (with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] (meta loc)) 1.167 + loc))) 1.168 + 1.169 +(defn left 1.170 + "Returns the loc of the left sibling of the node at this loc, or nil" 1.171 + {:added "1.0"} 1.172 + [loc] 1.173 + (let [[node {l :l r :r :as path}] loc] 1.174 + (when (and path (seq l)) 1.175 + (with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] (meta loc))))) 1.176 + 1.177 +(defn leftmost 1.178 + "Returns the loc of the leftmost sibling of the node at this loc, or self" 1.179 + {:added "1.0"} 1.180 + [loc] 1.181 + (let [[node {l :l r :r :as path}] loc] 1.182 + (if (and path (seq l)) 1.183 + (with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] (meta loc)) 1.184 + loc))) 1.185 + 1.186 +(defn insert-left 1.187 + "Inserts the item as the left sibling of the node at this loc, 1.188 + without moving" 1.189 + {:added "1.0"} 1.190 + [loc item] 1.191 + (let [[node {l :l :as path}] loc] 1.192 + (if (nil? path) 1.193 + (throw (new Exception "Insert at top")) 1.194 + (with-meta [node (assoc path :l (conj l item) :changed? true)] (meta loc))))) 1.195 + 1.196 +(defn insert-right 1.197 + "Inserts the item as the right sibling of the node at this loc, 1.198 + without moving" 1.199 + {:added "1.0"} 1.200 + [loc item] 1.201 + (let [[node {r :r :as path}] loc] 1.202 + (if (nil? path) 1.203 + (throw (new Exception "Insert at top")) 1.204 + (with-meta [node (assoc path :r (cons item r) :changed? true)] (meta loc))))) 1.205 + 1.206 +(defn replace 1.207 + "Replaces the node at this loc, without moving" 1.208 + {:added "1.0"} 1.209 + [loc node] 1.210 + (let [[_ path] loc] 1.211 + (with-meta [node (assoc path :changed? true)] (meta loc)))) 1.212 + 1.213 +(defn edit 1.214 + "Replaces the node at this loc with the value of (f node args)" 1.215 + {:added "1.0"} 1.216 + [loc f & args] 1.217 + (replace loc (apply f (node loc) args))) 1.218 + 1.219 +(defn insert-child 1.220 + "Inserts the item as the leftmost child of the node at this loc, 1.221 + without moving" 1.222 + {:added "1.0"} 1.223 + [loc item] 1.224 + (replace loc (make-node loc (node loc) (cons item (children loc))))) 1.225 + 1.226 +(defn append-child 1.227 + "Inserts the item as the rightmost child of the node at this loc, 1.228 + without moving" 1.229 + {:added "1.0"} 1.230 + [loc item] 1.231 + (replace loc (make-node loc (node loc) (concat (children loc) [item])))) 1.232 + 1.233 +(defn next 1.234 + "Moves to the next loc in the hierarchy, depth-first. When reaching 1.235 + the end, returns a distinguished loc detectable via end?. If already 1.236 + at the end, stays there." 1.237 + {:added "1.0"} 1.238 + [loc] 1.239 + (if (= :end (loc 1)) 1.240 + loc 1.241 + (or 1.242 + (and (branch? loc) (down loc)) 1.243 + (right loc) 1.244 + (loop [p loc] 1.245 + (if (up p) 1.246 + (or (right (up p)) (recur (up p))) 1.247 + [(node p) :end]))))) 1.248 + 1.249 +(defn prev 1.250 + "Moves to the previous loc in the hierarchy, depth-first. If already 1.251 + at the root, returns nil." 1.252 + {:added "1.0"} 1.253 + [loc] 1.254 + (if-let [lloc (left loc)] 1.255 + (loop [loc lloc] 1.256 + (if-let [child (and (branch? loc) (down loc))] 1.257 + (recur (rightmost child)) 1.258 + loc)) 1.259 + (up loc))) 1.260 + 1.261 +(defn end? 1.262 + "Returns true if loc represents the end of a depth-first walk" 1.263 + {:added "1.0"} 1.264 + [loc] 1.265 + (= :end (loc 1))) 1.266 + 1.267 +(defn remove 1.268 + "Removes the node at loc, returning the loc that would have preceded 1.269 + it in a depth-first walk." 1.270 + {:added "1.0"} 1.271 + [loc] 1.272 + (let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc] 1.273 + (if (nil? path) 1.274 + (throw (new Exception "Remove at top")) 1.275 + (if (pos? (count l)) 1.276 + (loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] (meta loc))] 1.277 + (if-let [child (and (branch? loc) (down loc))] 1.278 + (recur (rightmost child)) 1.279 + loc)) 1.280 + (with-meta [(make-node loc (peek pnodes) rs) 1.281 + (and ppath (assoc ppath :changed? true))] 1.282 + (meta loc)))))) 1.283 + 1.284 +(comment 1.285 + 1.286 +(load-file "/Users/rich/dev/clojure/src/zip.clj") 1.287 +(refer 'zip) 1.288 +(def data '[[a * b] + [c * d]]) 1.289 +(def dz (vector-zip data)) 1.290 + 1.291 +(right (down (right (right (down dz))))) 1.292 +(lefts (right (down (right (right (down dz)))))) 1.293 +(rights (right (down (right (right (down dz)))))) 1.294 +(up (up (right (down (right (right (down dz))))))) 1.295 +(path (right (down (right (right (down dz)))))) 1.296 + 1.297 +(-> dz down right right down right) 1.298 +(-> dz down right right down right (replace '/) root) 1.299 +(-> dz next next (edit str) next next next (replace '/) root) 1.300 +(-> dz next next next next next next next next next remove root) 1.301 +(-> dz next next next next next next next next next remove (insert-right 'e) root) 1.302 +(-> dz next next next next next next next next next remove up (append-child 'e) root) 1.303 + 1.304 +(end? (-> dz next next next next next next next next next remove next)) 1.305 + 1.306 +(-> dz next remove next remove root) 1.307 + 1.308 +(loop [loc dz] 1.309 + (if (end? loc) 1.310 + (root loc) 1.311 + (recur (next (if (= '* (node loc)) 1.312 + (replace loc '/) 1.313 + loc))))) 1.314 + 1.315 +(loop [loc dz] 1.316 + (if (end? loc) 1.317 + (root loc) 1.318 + (recur (next (if (= '* (node loc)) 1.319 + (remove loc) 1.320 + loc))))) 1.321 +)