;; clojure.zip -- Functional hierarchical zipper, with navigation, editing, and enumeration.
;; This implementation derived from clojure.zip in Clojure itself.
;;
;; What follows is the header notice from Clojure:
;;
;; Copyright (c) Rich Hickey. All rights reserved.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.zip)
(defn zipper
[branch? children make-node root]
;; TODO missing ^{...} syntax before val to add meta to val.
(with-meta [root nil]
{:zip/branch? branch? :zip/children children :zip/make-node make-node}))
(defn seq-zip
[root]
(zipper seq?
identity
(fn [node children] (with-meta children (meta node)))
root))
(defn vector-zip
[root]
(zipper vector?
seq
(fn [node children] (with-meta (vec children) (meta node)))
root))
(defn xml-zip
[root]
(zipper (complement string?)
(fn [node children]
(assoc node :content (and children (apply vector children))))
root))
(defn node
[loc]
(nth loc 0))
(defn branch?
[loc]
((:zip/branch? (meta loc)) (node loc)))
(defn children
[loc]
(if (branch? loc)
((:zip/children (meta loc)) (node loc))
(throw (ex-info "called children on leaf node" {}))))
(defn make-node
[loc node children]
((:zip/make-node (meta loc)) node children))
(defn path
[loc]
(:pnodes (get loc 1)))
(defn lefts
[loc]
(seq (:l (get loc 1))))
(defn rights
[loc]
(:r (get loc 1)))
(defn down
[loc]
(when (branch? loc)
(let [[node path] loc
[c & cnext :as cs] (children loc)]
(when cs
(with-meta [c {:l []
:pnodes (if path (conj (:pnodes path) node) [node])
:ppath path
:r cnext}]
(meta loc))))))
(defn up
[loc]
(let [[node {l :l, ppath :ppath, pnodes :pnodes, r :r, changed? :changed?, :as path}] loc]
(when pnodes
(let [pnode (peek pnodes)]
(with-meta (if changed?
[(make-node loc pnode (concat l (cons node r)))
(and ppath (assoc ppath :changed? true))]
[pnode ppath])
(meta loc))))))
(defn root
[loc]
(if (= :end (nth loc 1))
(node loc)
(let [p (up loc)]
(if p
(recur p)
(node loc)))))
(defn right
[loc]
(let [[node {l :l [r & rnext :as rs] :r :as path}] loc]
(when (and path rs)
(with-meta [r (assoc path :l (conj l node) :r rnext)] (meta loc)))))
(defn rightmost
[loc]
(let [[node {l :l r :r :as path}] loc]
(if (and path r)
(with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] (meta loc))
loc)))
(defn left
[loc]
(let [[node {l :l r :r :as path}] loc]
(when (and path (seq l))
(with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] (meta loc)))))
(defn leftmost
[loc]
(let [[node {l :l r :r :as path}] loc]
(if (and path (seq l))
(with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] (meta loc))
loc)))
(defn insert-left
[loc item]
(let [[node {l :l :as path}] loc]
(if (nil? path)
(throw (ex-info "Insert at top" {}))
(with-meta [node (assoc path :l (conj l item) :changed? true)] (meta loc)))))
(defn insert-right
[loc item]
(let [[node {r :r :as path}] loc]
(if (nil? path)
(throw (ex-info "Insert at top" {}))
(with-meta [node (assoc path :r (cons item r) :changed? true)] (meta loc)))))
(defn replace
[loc node]
(let [[_ path] loc]
(with-meta [node (assoc path :changed? true)] (meta loc))))
(defn edit
[loc f & args]
(replace loc (apply f (node loc) args)))
(defn insert-child
[loc item]
(replace loc (make-node loc (node loc) (cons item (children loc)))))
(defn append-child
[loc item]
(replace loc (make-node loc (node loc) (concat (children loc) [item]))))
(defn next
[loc]
(if (= :end (nth loc 1))
loc
(or
(and (branch? loc) (down loc))
(right loc)
(loop [p loc]
(if (up p)
(or (right (up p)) (recur (up p)))
[(node p) :end])))))
(defn prev
[loc]
(if-let [lloc (left loc)]
(loop [loc lloc]
(if-let [child (and (branch? loc) (down loc))]
(recur (rightmost child))
loc))
(up loc)))
(defn end?
[loc]
(= :end (nth loc 1)))
(defn remove
[loc]
(let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc]
(if (nil? path)
(throw (ex-info "Remove at top" {}))
(if (pos? (count l))
(loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] (meta loc))]
(if-let [child (and (branch? loc) (down loc))]
(recur (rightmost child))
loc))
(with-meta [(make-node loc (peek pnodes) rs)
(and ppath (assoc ppath :changed? true))]
(meta loc))))))