@@ -1,333 +0,0 @@
1−module Data.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 Data.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)