Skip to content

Commit d0ee60e

Browse files
zampinozampino
committed
Add zipper notebook
1 parent 63c2268 commit d0ee60e

File tree

2 files changed

+214
-1
lines changed

2 files changed

+214
-1
lines changed

‎deps.edn

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -40,4 +40,5 @@
4040
"notebooks/images.clj"
4141
"notebooks/semantic.clj"
4242
"notebooks/sicmutils.clj"
43-
"notebooks/rule_30.clj"]}}}}
43+
"notebooks/rule_30.clj"
44+
"notebooks/zipper_with_scars.clj"]}}}}

‎notebooks/zipper_with_scars.clj

Lines changed: 212 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,212 @@
1+
;; # Clojure Zippers with Scars à la Huet
2+
;; _Building scars into clojure zipper library to go up and back down at the previous location._
3+
^{:nextjournal.clerk/visibility :hide-ns}
4+
(ns ^:nextjournal.clerk/no-cache zipper-with-scars
5+
(:require [clojure.zip :as zip]
6+
[arrowic.core :as a]
7+
[nextjournal.clerk :as clerk]
8+
[nextjournal.clerk.viewer :as v]
9+
[clojure.string :as str])
10+
(:import (clojure.lang Seqable)))
11+
12+
;; I recently stumbled into a parsing scenario where a stream of tokens is folded onto a zipper.
13+
;; Some of these tokens would just push a new child at the current location while
14+
;; others would also need to vary the shape some ancestor node. Now the issue with `clojure.zip/up` followed
15+
;; by a `clojure.zip/down` is that it goes back to _the first_ (or leftmost) of the child nodes.
16+
;;
17+
;; Can we build a function to actually _go back_ to the previous lower location
18+
;; without say, storing some left offset while going up or using a non-core zipper library?
19+
;;
20+
;; Mr. Gérard Huet to the rescue here! It turns out
21+
;; the [original zipper paper](http://gallium.inria.fr/~huet/PUBLIC/zip.pdf) has a memo-version of the up and down functions. Let's use Clerk viewers to illustrate how they work.
22+
;;
23+
;; Admittedly, the story with scars is just an excuse to test some animated zipper viewers in Clerk. To that end some machinery follows, unfold at your own peril.
24+
^{::clerk/visibility :fold ::clerk/viewer :hide-result}
25+
(do
26+
(defn loc-seq [zloc]
27+
;; this sorts nodes so that children seqs are displayed in the correct order by arrowic
28+
(try
29+
(doall
30+
(concat
31+
(reverse (take-while some? (next (iterate zip/prev zloc))))
32+
(cons zloc
33+
(take-while (complement zip/end?) (next (iterate zip/next zloc))))))
34+
(catch Throwable e
35+
(throw (ex-info "Cant seq at loc" {:zloc zloc} e)))))
36+
(def ->name (comp :name zip/node))
37+
(defn pnode [zloc] (some-> zloc (get 1) :pnodes peek))
38+
(def empty-graph {:vertices #{} :edges []})
39+
(defn add-v [g zloc] (update g :vertices conj (->name zloc)))
40+
(defn add-e [g zloc]
41+
(let [parent-name (-> zloc pnode :name)]
42+
(cond-> g parent-name (update :edges conj [parent-name (-> zloc zip/node :name)]))))
43+
(defn ->graph [zloc]
44+
(reduce #(-> %1 (add-e %2) (add-v %2))
45+
(assoc empty-graph :current? #{(->name zloc)})
46+
(loc-seq zloc)))
47+
(defn insert-vtx [{:keys [current?]} name]
48+
(doto (a/insert-vertex! name
49+
:font-color "black"
50+
:fill-color (if (current? name) "#ec4899" "#a855f7")
51+
:perimeter-spacing 1 :spacing-bottom 1 :spacing-left 1
52+
:font-size 20 :font-style 1)
53+
(.. getGeometry (setWidth 40))
54+
(.. getGeometry (setHeight 40))))
55+
(defn ->svg [{:as g :keys [vertices edges]}]
56+
(a/as-svg
57+
(a/with-graph (a/create-graph)
58+
(let [vmap (zipmap vertices (map (partial insert-vtx g) vertices))]
59+
(doseq [[v1 v2] edges]
60+
(a/insert-edge! (vmap v1) (vmap v2)
61+
:end-arrow false :rounded true
62+
:stroke-width "3"
63+
:stroke-color "#7c3aed"))))))
64+
65+
(def zipper?
66+
(every-pred vector? (comp #{2} count) (comp map? first)
67+
(comp (some-fn nil? :changed? :ppath :pnodes)
68+
second)))
69+
(def zip-location-viewer
70+
{:transform-fn (comp v/html (v/update-val #(-> % ->graph ->svg)))
71+
:pred zipper?})
72+
73+
(def zip-reel-viewer
74+
{:pred (every-pred zipper? (comp :cut? meta))
75+
:transform-fn (comp :frames meta v/->value)
76+
:render-fn '(fn [frames]
77+
(v/html
78+
(reagent/with-let
79+
[!reel? (reagent/atom false) !idx (reagent/atom 0) !tmr (reagent/atom nil)
80+
stepfn #(swap! !idx inc)]
81+
(cond
82+
(and @!reel? (not @!tmr))
83+
(reset! !tmr (js/setInterval stepfn 500))
84+
(and (not @!reel?) @!tmr)
85+
(do (js/clearInterval @!tmr) (reset! !tmr nil) (reset! !idx 0)))
86+
[:div.flex.items-left
87+
[:div.flex.mr-5 {:style {:font-size "1.5rem"}}
88+
[:div.cursor-pointer {:on-click #(swap! !reel? not)} ({true "⏹" false "▶️"} @!reel?)]]
89+
(v/inspect (frames (as-> (count frames) c (if @!reel? (mod @!idx c) (dec c)))))])))})
90+
91+
(defn reset-reel [zloc] (vary-meta zloc assoc :frames [] :cut? false))
92+
(defn add-frame [zloc] (vary-meta zloc update :frames (fnil conj []) zloc))
93+
(defn cut [zloc] (vary-meta zloc assoc :cut? true))
94+
(defmacro zmov-> [subj & ops]
95+
(list* '-> subj `reset-reel `add-frame
96+
(concat (interpose `add-frame ops) [`add-frame `cut])))
97+
(clerk/add-viewers! [zip-reel-viewer zip-location-viewer]))
98+
^{::clerk/viewer :hide-result}
99+
(def ->zip (partial zip/zipper map? :content #(assoc %1 :content %2)))
100+
^{::clerk/viewer :hide-result}
101+
(defn ->node [name] {:name name})
102+
;; In code cells below, you may read `zmov->` as clojure's own threading macro:
103+
;; the resulting values are the same while metadata is being varied to contain intermediate "frames".
104+
(def tree
105+
(zmov-> (->node 'a)
106+
->zip
107+
(zip/append-child (->node 'b))
108+
(zip/append-child (->node 'c))
109+
zip/down zip/right
110+
(zip/append-child (->node 'd))
111+
(zip/append-child (->node 'e))
112+
(zip/append-child (->node 'f))
113+
zip/up))
114+
115+
;; So given a location
116+
(def loc
117+
(zmov-> tree
118+
zip/down zip/right
119+
zip/down zip/right
120+
zip/right))
121+
122+
;; we'd go up, edit and go back down
123+
(zmov-> loc
124+
zip/up
125+
(zip/edit assoc :name "☹︎︎")
126+
zip/down)
127+
;; losing the position we had. This is the scenario pictured by the author:
128+
129+
;; > When an algorithm has frequent operations which necessitate going up in the tree,
130+
;;and down again at the same position, it is a loss of time (and space, and garbage collecting time, etc)
131+
;;to close the sections in the meantime. It may be advantageous
132+
;;to leave “scars” in the structure allowing direct access to the memorized visited
133+
;;positions. Thus we replace the (non-empty) sections by triples memorizing a tree
134+
;;and its siblings:
135+
;;
136+
;; _**The Zipper** J. Functional Programming 1 (1): 1–000, January 1993_
137+
;;
138+
;; Let's now stick to the rules: reuse Clojure's own data structures while adding a "memorized" functionality.
139+
;; A Scar is a seq that remembers who's left and right of a given point
140+
(deftype Scar [left node right]
141+
Seqable
142+
(seq [_] (concat left (cons node right))))
143+
;; and we're plugging it in the original up and down function definitions:
144+
^{::clerk/visibility :hide ::clerk/viewer :hide-result}
145+
(.addMethod ^clojure.lang.MultiFn print-method Scar (get-method print-method clojure.lang.ISeq))
146+
147+
(defn zip-up-memo [[node path :as loc]]
148+
(let [{:keys [pnodes ppath l r]} path]
149+
(when pnodes
150+
(with-meta [(zip/make-node loc (peek pnodes) (->Scar l node r))
151+
(when ppath (assoc ppath :changed? true))] (meta loc)))))
152+
153+
(defn zip-down-memo [[node path :as loc]]
154+
(when (zip/branch? loc)
155+
(let [children (zip/children loc)]
156+
(with-meta [(.node children)
157+
{:l (.-left children)
158+
:ppath path
159+
:pnodes (if path (conj (:pnodes path) node))
160+
:r (.-right children)}] (meta loc)))))
161+
162+
;; so now we can go up, edit, go back at the previous location
163+
(zmov-> loc
164+
zip-up-memo
165+
(zip/edit assoc :name "☻")
166+
zip-down-memo)
167+
168+
;; same works with repeated applications of memo movements
169+
(zmov-> loc
170+
zip-up-memo
171+
zip-up-memo
172+
(zip/edit assoc :name "☻")
173+
zip-down-memo
174+
zip-down-memo)
175+
176+
;; up and down memo is compatible with other zipper operations
177+
(zmov-> loc
178+
zip-up-memo
179+
(zip/insert-left (->node '▶))
180+
(zip/insert-right (->node '◀))
181+
zip-down-memo)
182+
183+
;; or move away from the remembered position, go back to it, go back memo
184+
(zmov-> loc
185+
zip-up-memo
186+
zip/left
187+
zip/right
188+
zip-down-memo)
189+
190+
;; let's get a final crazy reel.
191+
(zmov-> (->node 'a)
192+
->zip
193+
(zip/append-child (->node 'b))
194+
(zip/append-child (->node 'c))
195+
zip/down
196+
(zip/edit update :name str/capitalize)
197+
zip/right
198+
(zip/append-child (->node 'd))
199+
(zip/append-child (->node 'e))
200+
(zip/insert-child (->node 'f))
201+
zip/down
202+
(zip/insert-child (->node 'g))
203+
(zip/insert-child (->node 'h))
204+
zip/down zip/right zip/remove
205+
zip/remove
206+
zip/remove)
207+
208+
^{::clerk/viewer :hide-result ::clerk/visibility :hide}
209+
(comment
210+
(clerk/clear-cache!)
211+
(macroexpand '(zmov-> tree zip/up zip/down))
212+
*e)

0 commit comments

Comments
 (0)