diff options
Diffstat (limited to 'stdlib/source/lux/data/collection/tree/zipper.lux')
-rw-r--r-- | stdlib/source/lux/data/collection/tree/zipper.lux | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux new file mode 100644 index 000000000..bac8961e3 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/zipper.lux @@ -0,0 +1,285 @@ +(.module: + [lux #* + [abstract + functor + comonad + [equivalence (#+ Equivalence)]] + [data + ["." maybe ("#@." monad)] + [collection + ["." list ("#@." functor fold monoid)] + ["." stack (#+ Stack)]]] + ["." macro + ["." code] + ["s" syntax (#+ Syntax syntax:)]]] + ["." // (#+ Tree) ("#@." functor)]) + +(type: #export (Zipper a) + {#.doc "Tree zippers, for easy navigation and editing over trees."} + {#parent (Maybe (Zipper a)) + #lefts (Stack (Tree a)) + #rights (Stack (Tree a)) + #node (Tree a)}) + +(structure: #export (equivalence ,equivalence) + (All [a] + (-> (Equivalence a) + (Equivalence (Zipper a)))) + (def: (= reference sample) + (and (:: (//.equivalence ,equivalence) = + (get@ #node reference) + (get@ #node sample)) + (:: (stack.equivalence (//.equivalence ,equivalence)) = + (get@ #lefts reference) + (get@ #lefts sample)) + (:: (stack.equivalence (//.equivalence ,equivalence)) = + (get@ #rights reference) + (get@ #rights sample)) + (:: (maybe.equivalence (equivalence ,equivalence)) = + (get@ #parent reference) + (get@ #parent sample)) + ))) + +(def: #export (zip tree) + (All [a] (-> (Tree a) (Zipper a))) + {#parent #.None + #lefts stack.empty + #rights stack.empty + #node tree}) + +(def: #export (unzip zipper) + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node zipper)) + +(def: #export (value zipper) + (All [a] (-> (Zipper a) a)) + (|> zipper (get@ [#node #//.value]))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ [#node #//.children]))) + +(def: #export (branch? zipper) + (All [a] (-> (Zipper a) Bit)) + (|> zipper children list.empty? not)) + +(def: #export (leaf? zipper) + (All [a] (-> (Zipper a) Bit)) + (|> zipper branch? not)) + +(def: #export (start? zipper) + (All [a] (-> (Zipper a) Bit)) + (case (get@ #parent zipper) + #.None + #1 + + _ + #0)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (children zipper) + #.Nil + zipper + + (#.Cons head tail) + {#parent (#.Some zipper) + #lefts stack.empty + #rights tail + #node head})) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #parent zipper) + #.None + zipper + + (#.Some parent) + (|> parent + ## TODO: Remove once new-luxc becomes the standard compiler. + (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) + (function (_ node) + (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + node)))) + ## (update@ #node (function (_ node) + ## (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) + ## (#.Cons (get@ #node zipper) + ## (get@ #rights zipper))) + ## node))) + ))) + +(def: #export (start zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [ancestor (..up zipper)] + (if (is? zipper ancestor) + zipper + (start ancestor)))) + +(template [<one> <all> <side> <op-side>] + [(def: #export (<one> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ <side> zipper) + #.Nil + zipper + + (#.Cons next side') + (|> zipper + (update@ <op-side> (function (_ op-side) + (#.Cons (get@ #node zipper) op-side))) + (set@ <side> side') + (set@ #node next)))) + + (def: #export (<all> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (list.reverse (get@ <side> zipper)) + #.Nil + zipper + + (#.Cons last prevs) + (|> zipper + (set@ <side> #.Nil) + (set@ <op-side> (|> (get@ <op-side> zipper) + (#.Cons (get@ #node zipper)) + (list@compose prevs))) + (set@ #node last))))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(def: #export (next zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [forward (..down zipper)] + (if (is? zipper forward) + (loop [zipper zipper] + (let [jump (..right zipper)] + (if (is? zipper jump) + (let [backward (..up zipper)] + (if (is? zipper backward) + zipper + (recur backward))) + jump))) + forward))) + +(def: #export (end zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #rights zipper) + #.Nil + (case (get@ [#node #//.children] zipper) + #.Nil + zipper + + (#.Cons _) + (end (..down zipper))) + + (#.Cons _) + (end (..rightmost zipper)))) + +(def: #export (prev zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [forward (..left zipper)] + (if (is? zipper forward) + (..up zipper) + (case (get@ [#node #//.children] forward) + #.Nil + forward + + (#.Cons _) + (..end (..down forward)))))) + +(def: #export (set value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #//.value] value zipper)) + +(def: #export (update f zipper) + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #//.value] f zipper)) + +(def: #export (prepend-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (function (_ children) + ## TODO: Remove once new-luxc becomes the standard compiler. + (list& (: (Tree ($ 0)) + (//.tree [value {}])) + children) + ## (list& (//.tree [value {}]) + ## children) + ) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (function (_ children) + (list@compose children + ## TODO: Remove once new-luxc becomes the standard compiler. + (list (: (Tree ($ 0)) + (//.tree [value {}]))) + ## (list (//.tree [value {}])) + )) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #lefts zipper) + #.Nil + (case (get@ #parent zipper) + #.None + #.None + + (#.Some next) + (#.Some (|> next + (update@ [#node #//.children] (|>> list.tail (maybe.default (list))))))) + + (#.Cons next side) + (#.Some (|> zipper + (set@ #lefts side) + (set@ #node next))))) + +(template [<name> <side>] + [(def: #export (<name> value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #parent zipper) + #.None + #.None + + _ + (#.Some (|> zipper + (update@ <side> (function (_ side) + ## TODO: Remove once new-luxc becomes the standard compiler. + (#.Cons (: (Tree ($ 0)) + (//.tree [value {}])) + side) + ## (#.Cons (//.tree [value {}]) + ## side) + ))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(structure: #export functor (Functor Zipper) + (def: (map f fa) + {#parent (|> fa (get@ #parent) (maybe@map (map f))) + #lefts (|> fa (get@ #lefts) (list@map (//@map f))) + #rights (|> fa (get@ #rights) (list@map (//@map f))) + #node (//@map f (get@ #node fa))})) + +## TODO: Add again once new-luxc becomes the standard compiler. +## (structure: #export comonad (CoMonad Zipper) +## (def: &functor ..functor) + +## (def: unwrap (get@ [#node #//.value])) + +## (def: (split wa) +## (let [tree-splitter (function (tree-splitter tree) +## {#//.value (zip tree) +## #//.children (list@map tree-splitter +## (get@ #//.children tree))})] +## {#parent (|> wa (get@ #parent) (maybe@map split)) +## #lefts (|> wa (get@ #lefts) (list@map tree-splitter)) +## #rights (|> wa (get@ #rights) (list@map tree-splitter)) +## #node (|> fa (get@ #node) tree-splitter)}))) |