@@ -0,0 +1,333 @@
1+module Yoga.Tree.Zipper where
2+
3+import Prelude
4+import Control.Alt ((<|>))
5+import Control.Comonad.Cofree (head, tail, (:<))
6+import Data.Array (drop, reverse, take, uncons, (!!), (:))
7+import Data.Maybe (Maybe(Just, Nothing))
8+import Yoga.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue)
9+
10+-- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this
11+-- | we store the current `Node`, the sibling nodes that appear before the current
12+-- | node, the sibling nodes that appear after the current node, and a `Array` of
13+-- | `Loc`ations that store the parent node locations up to the root of the three.
14+-- |
15+-- | So, effectively, the `parents` field records the path travelled in the
16+-- | tree to reach the level of the current `Node` starting from the tree's root,
17+-- | and the `before` and `after` fields describe its location in the current
18+-- | level.
19+newtype Loc a = Loc
20+ { node ∷ Tree a
21+ , before ∷ Forest a
22+ , after ∷ Forest a
23+ , parents ∷ Array (Loc a)
24+ }
25+
26+instance eqLoc ∷ Eq a => Eq (Loc a) where
27+ eq (Loc r1) (Loc r2) =
28+ (r1.node == r2.node)
29+ && (r1.before == r2.before)
30+ && (r1.after == r2.after)
31+ && (r1.parents == r2.parents)
32+
33+-- -- Cursor movement
34+-- | Move the cursor to the next sibling.
35+next ∷ ∀ a. Loc a -> Maybe (Loc a)
36+next (Loc r) = case uncons r.after of
37+ Nothing -> Nothing
38+ Just { head: c, tail: cs } ->
39+ Just
40+ $ Loc
41+ { node: c
42+ , before: r.node : r.before
43+ , after: cs
44+ , parents: r.parents
45+ }
46+
47+-- -- | Move the cursor to the previous sibling.
48+prev ∷ ∀ a. Loc a -> Maybe (Loc a)
49+prev (Loc r) = case uncons r.before of
50+ Nothing -> Nothing
51+ Just { head: c, tail: cs } ->
52+ Just
53+ $ Loc
54+ { node: c
55+ , before: cs
56+ , after: r.node : r.after
57+ , parents: r.parents
58+ }
59+
60+-- -- | Move the cursor to the first sibling.
61+first ∷ ∀ a. Loc a -> Loc a
62+first l@(Loc r) = case uncons r.before of
63+ Nothing -> l
64+ Just { head: c, tail: cs } ->
65+ Loc
66+ $
67+ { node: c
68+ , before: []
69+ , after: (reverse cs) <> r.after
70+ , parents: r.parents
71+ }
72+
73+-- -- | Move the cursor to the last sibling.
74+last ∷ ∀ a. Loc a -> Loc a
75+last l@(Loc r) = case uncons (reverse r.after) of
76+ Nothing -> l
77+ Just { head: c, tail: cs } ->
78+ Loc
79+ $
80+ { node: c
81+ , before: cs <> r.before
82+ , after: []
83+ , parents: r.parents
84+ }
85+
86+-- -- | Move the cursor to the parent `Node`.
87+up ∷ ∀ a. Loc a -> Maybe (Loc a)
88+up l@(Loc r) = case uncons r.parents of
89+ Nothing -> Nothing
90+ Just { head: p, tail: ps } ->
91+ Just
92+ $ Loc
93+ { node: (value p) :< (siblings l)
94+ , before: before p
95+ , after: after p
96+ , parents: ps
97+ }
98+
99+-- | Move the cursor to the root of the tree.
100+root ∷ ∀ a. Loc a -> Loc a
101+root l = case up l of
102+ Nothing -> l
103+ Just p -> root p
104+
105+-- | Move the cursor to the first child of the current `Node`.
106+firstChild ∷ ∀ a. Loc a -> Maybe (Loc a)
107+firstChild n = case uncons (children n) of
108+ Nothing -> Nothing
109+ Just { head: c, tail: cs } ->
110+ Just
111+ $ Loc
112+ { node: c
113+ , before: []
114+ , after: cs
115+ , parents: n : (parents n)
116+ }
117+
118+-- | Move the cursor to the first child of the current `Node`.
119+down ∷ ∀ a. Loc a -> Maybe (Loc a)
120+down = firstChild
121+
122+-- | Move the cursor to the last child of the current `Node`.
123+lastChild ∷ ∀ a. Loc a -> Maybe (Loc a)
124+lastChild p = last <$> down p
125+
126+-- | Move the cursor to a specific sibling by it's index.
127+siblingAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
128+siblingAt i l@(Loc r) = case up l of
129+ Nothing -> Nothing
130+ Just p -> case (children p) !! i of
131+ Nothing -> Nothing
132+ Just c ->
133+ let
134+ before' = reverse $ take i (children p)
135+ after' = drop (i + 1) (children p)
136+ in
137+ Just
138+ $ Loc
139+ { node: c
140+ , before: before'
141+ , after: after'
142+ , parents: r.parents
143+ }
144+
145+-- | Move the cursor to a specific child of the current `Node` by it's index.
146+childAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
147+childAt i p = (firstChild p) >>= (siblingAt i)
148+
149+-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
150+-- | current tree.
151+toTree ∷ ∀ a. Loc a -> Tree a
152+toTree = node <<< root
153+
154+-- | Get a `Loc`ation representation from a given `Tree`.
155+fromTree ∷ ∀ a. Tree a -> Loc a
156+fromTree n =
157+ Loc
158+ { node: n
159+ , before: []
160+ , after: []
161+ , parents: []
162+ }
163+
164+-- | Set the `Node` at the current position.
165+setNode ∷ ∀ a. Tree a -> Loc a -> Loc a
166+setNode a (Loc r) =
167+ Loc
168+ { node: a
169+ , before: r.before
170+ , after: r.after
171+ , parents: r.parents
172+ }
173+
174+-- | Set the `Node` at the current position.
175+modifyNode ∷ ∀ a. (Tree a -> Tree a) -> Loc a -> Loc a
176+modifyNode f (Loc r) =
177+ Loc
178+ { node: f r.node
179+ , before: r.before
180+ , after: r.after
181+ , parents: r.parents
182+ }
183+
184+-- | Set the value of the current `Node`.
185+setValue ∷ ∀ a. a -> Loc a -> Loc a
186+setValue a l = setNode (setNodeValue a (node l)) l
187+
188+-- | Modify the value of the current `Node`.
189+modifyValue ∷ ∀ a. (a -> a) -> Loc a -> Loc a
190+modifyValue f l = setNode (modifyNodeValue f (node l)) l
191+
192+-- -- insert and delete nodes
193+-- | Insert a node after the current position, and move cursor to the new node.
194+insertAfter ∷ ∀ a. Tree a -> Loc a -> Loc a
195+insertAfter n l =
196+ Loc
197+ { node: n
198+ , after: after l
199+ , before: (node l) : (before l)
200+ , parents: parents l
201+ }
202+
203+-- | Insert a node before the current position, and move cursor to the new node.
204+insertBefore ∷ ∀ a. Tree a -> Loc a -> Loc a
205+insertBefore n l =
206+ Loc
207+ { node: n
208+ , after: (node l) : (after l)
209+ , before: before l
210+ , parents: parents l
211+ }
212+
213+-- | Insert a node as a child to the current node, and move cursor to the new node.
214+insertChild ∷ ∀ a. Tree a -> Loc a -> Loc a
215+insertChild n l = case down l of
216+ Just c -> insertAfter n c
217+ Nothing ->
218+ Loc
219+ { node: n
220+ , after: []
221+ , before: []
222+ , parents: l : (parents l)
223+ }
224+
225+-- | Delete the node in the current position.
226+delete ∷ ∀ a. Loc a -> Loc a
227+delete l@(Loc r) = case uncons r.after of
228+ Just { head: c, tail: cs } ->
229+ Loc
230+ { node: c
231+ , before: r.before
232+ , after: cs
233+ , parents: r.parents
234+ }
235+ Nothing -> case uncons r.before of
236+ Just { head: c, tail: cs } ->
237+ Loc
238+ { node: c
239+ , before: cs
240+ , after: r.after
241+ , parents: r.parents
242+ }
243+ Nothing -> case uncons r.parents of
244+ Nothing -> l
245+ Just { head: c } ->
246+ Loc
247+ { node: mkTree (value c) []
248+ , before: before c
249+ , after: after c
250+ , parents: parents c
251+ }
252+
253+-- Searches
254+-- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
255+findDownWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
256+findDownWhere predicate loc
257+ | predicate $ value loc = Just loc
258+
259+findDownWhere predicate loc = lookNext <|> lookDown
260+ where
261+ lookNext = next loc >>= findDownWhere predicate
262+
263+ lookDown = down loc >>= findDownWhere predicate
264+
265+-- | Search for the first occurence of the value `a` downwards and to the right.
266+findDown ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
267+findDown a = findDownWhere (_ == a)
268+
269+-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
270+findUpWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
271+findUpWhere predicate loc
272+ | predicate $ value loc = Just loc
273+
274+findUpWhere predicate loc = lookPrev <|> lookUp
275+ where
276+ lookPrev = prev loc >>= findUpWhere predicate
277+
278+ lookUp = up loc >>= findUpWhere predicate
279+
280+-- | Search for the first occurence of the value `a` upwards and to the left,
281+findUp ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
282+findUp a = findUpWhere (_ == a)
283+
284+-- | Search from the root of the mkTree for the first occurrence where the given predicate is truen and return the Loc
285+findFromRootWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
286+findFromRootWhere predicate loc
287+ | predicate $ value loc = Just loc
288+
289+findFromRootWhere predicate loc = findDownWhere predicate $ root loc
290+
291+-- | Search for the first occurence of the value `a` starting from the root of
292+-- | the tree.
293+findFromRoot ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
294+findFromRoot a = findFromRootWhere (_ == a)
295+
296+-- | flattens the Tree into a Array depth first.
297+flattenLocDepthFirst ∷ ∀ a. Loc a -> Array (Loc a)
298+flattenLocDepthFirst loc = loc : (go loc)
299+ where
300+ go ∷ Loc a -> Array (Loc a)
301+ go loc' =
302+ let
303+ downs = goDir loc' down
304+ nexts = goDir loc' next
305+ in
306+ downs <> nexts
307+
308+ goDir ∷ Loc a -> (Loc a -> Maybe (Loc a)) -> Array (Loc a)
309+ goDir loc' dirFn = case (dirFn loc') of
310+ Just l -> l : go l
311+ Nothing -> []
312+
313+-- Setters and Getters
314+node ∷ ∀ a. Loc a -> Tree a
315+node (Loc r) = r.node
316+
317+value ∷ ∀ a. Loc a -> a
318+value = head <<< node
319+
320+before ∷ ∀ a. Loc a -> Forest a
321+before (Loc r) = r.before
322+
323+after ∷ ∀ a. Loc a -> Forest a
324+after (Loc r) = r.after
325+
326+parents ∷ ∀ a. Loc a -> Array (Loc a)
327+parents (Loc r) = r.parents
328+
329+children ∷ ∀ a. Loc a -> Forest a
330+children = tail <<< node
331+
332+siblings ∷ ∀ a. Loc a -> Forest a
333+siblings (Loc r) = (reverse r.before) <> (r.node : r.after)