Mercurial > lasercutter

     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 )
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children