diff options
Diffstat (limited to 'stdlib/source/library/lux/data/collection/tree')
-rw-r--r-- | stdlib/source/library/lux/data/collection/tree/finger.lux | 108 | ||||
-rw-r--r-- | stdlib/source/library/lux/data/collection/tree/zipper.lux | 318 |
2 files changed, 426 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/data/collection/tree/finger.lux b/stdlib/source/library/lux/data/collection/tree/finger.lux new file mode 100644 index 000000000..a3b1be634 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/tree/finger.lux @@ -0,0 +1,108 @@ +(.module: + [library + [lux #* + [abstract + [predicate (#+ Predicate)] + ["." monoid (#+ Monoid)]] + [data + [collection + ["." list ("#\." monoid)]]] + [type + [abstract (#+ abstract: :abstraction :representation)]]]]) + +(abstract: #export (Tree @ t v) + {#monoid (Monoid t) + #tag t + #root (| v + [(Tree @ t v) (Tree @ t v)])} + + (interface: #export (Builder @ t) + (: (All [v] + (-> t v (Tree @ t v))) + leaf) + (: (All [v] + (-> (Tree @ t v) + (Tree @ t v) + (Tree @ t v))) + branch)) + + (template [<name> <tag> <output>] + [(def: #export <name> + (All [@ t v] (-> (Tree @ t v) <output>)) + (|>> :representation (get@ <tag>)))] + + [tag #tag t] + [root #root (Either v [(Tree @ t v) (Tree @ t v)])] + ) + + (implementation: #export (builder monoid) + (All [t] (Ex [@] (-> (Monoid t) (Builder @ t)))) + + (def: (leaf tag value) + (:abstraction + {#monoid monoid + #tag tag + #root (0 #0 value)})) + + (def: (branch left right) + (:abstraction + {#monoid monoid + #tag (\ monoid compose (..tag left) (..tag right)) + #root (0 #1 [left right])}))) + + (def: #export (value tree) + (All [@ t v] (-> (Tree @ t v) v)) + (case (get@ #root (:representation tree)) + (0 #0 value) + value + + (0 #1 [left right]) + (value left))) + + (def: #export (tags tree) + (All [@ t v] (-> (Tree @ t v) (List t))) + (case (get@ #root (:representation tree)) + (0 #0 value) + (list (get@ #tag (:representation tree))) + + (0 #1 [left right]) + (list\compose (tags left) + (tags right)))) + + (def: #export (values tree) + (All [@ t v] (-> (Tree @ t v) (List v))) + (case (get@ #root (:representation tree)) + (0 #0 value) + (list value) + + (0 #1 [left right]) + (list\compose (values left) + (values right)))) + + (def: #export (search predicate tree) + (All [@ t v] (-> (Predicate t) (Tree @ t v) (Maybe v))) + (let [[monoid tag root] (:representation tree)] + (if (predicate tag) + (let [(^open "tag//.") monoid] + (loop [_tag tag//identity + _node root] + (case _node + (0 #0 value) + (#.Some value) + + (0 #1 [left right]) + (let [shifted_tag (tag//compose _tag (..tag left))] + (if (predicate shifted_tag) + (recur _tag (get@ #root (:representation left))) + (recur shifted_tag (get@ #root (:representation right)))))))) + #.None))) + ) + +(def: #export (found? predicate tree) + (All [@ t v] (-> (Predicate t) (Tree @ t v) Bit)) + (case (..search predicate tree) + (#.Some _) + true + + #.None + false)) diff --git a/stdlib/source/library/lux/data/collection/tree/zipper.lux b/stdlib/source/library/lux/data/collection/tree/zipper.lux new file mode 100644 index 000000000..bb36e3e38 --- /dev/null +++ b/stdlib/source/library/lux/data/collection/tree/zipper.lux @@ -0,0 +1,318 @@ +(.module: + [library + [lux #* + ["@" target] + [abstract + [functor (#+ Functor)] + [comonad (#+ CoMonad)] + [monad (#+ do)] + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." maybe ("#\." monad)] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold monoid)]]]]] + ["." // (#+ Tree) ("#\." functor)]) + +(type: (Family Zipper a) + {#parent (Zipper a) + #lefts (List (Tree a)) + #rights (List (Tree a))}) + +(type: #export (Zipper a) + {#.doc "Tree zippers, for easy navigation and editing of trees."} + {#family (Maybe (Family Zipper a)) + #node (Tree a)}) + +(implementation: #export (equivalence super) + (All [a] + (-> (Equivalence a) + (Equivalence (Zipper a)))) + + (def: (= reference sample) + (let [== ($_ product.equivalence + (maybe.equivalence + ($_ product.equivalence + = + (list.equivalence (//.equivalence super)) + (list.equivalence (//.equivalence super)))) + (//.equivalence super))] + (== reference sample)))) + +(def: #export (zip tree) + (All [a] (-> (Tree a) (Zipper a))) + {#family #.None + #node tree}) + +(def: #export unzip + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node)) + +(def: #export value + (All [a] (-> (Zipper a) a)) + (get@ [#node #//.value])) + +(def: #export set + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #//.value])) + +(def: #export update + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #//.value])) + +(def: children + (All [a] (-> (Zipper a) (List (Tree a)))) + (get@ [#node #//.children])) + +(def: #export leaf? + (All [a] (-> (Zipper a) Bit)) + (|>> ..children list.empty?)) + +(def: #export branch? + (All [a] (-> (Zipper a) Bit)) + (|>> ..leaf? not)) + +(def: #export (start? zipper) + (All [a] (-> (Zipper a) Bit)) + (case (get@ #family zipper) + #.None + true + + _ + false)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (..children zipper) + #.Nil + #.None + + (#.Cons head tail) + (#.Some {#family (#.Some {#parent (set@ [#node #//.children] (list) zipper) + #lefts #.Nil + #rights tail}) + #node head}))) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (do maybe.monad + [family (get@ #family zipper)] + (wrap (let [(^slots [#parent #lefts #rights]) family] + (for {@.old + (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) + (set@ #//.children (list\compose (list.reverse lefts) + (#.Cons (get@ #node zipper) + rights)))) + parent)} + (set@ [#node #//.children] + (list\compose (list.reverse lefts) + (#.Cons (get@ #node zipper) + rights)) + parent)))))) + +(template [<one> <all> <side> <op-side>] + [(def: #export (<one> zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #family zipper) + (#.Some family) + (case (get@ <side> family) + (#.Cons next side') + (#.Some (for {@.old + {#family (#.Some (|> family + (set@ <side> side') + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))) + #node next}} + (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a))) + (function (_ side' zipper) + (|>> (set@ <side> side') + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))))] + {#family (#.Some (move side' zipper family)) + #node next}))) + + #.Nil + #.None) + + #.None + #.None)) + + (def: #export (<all> zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #family zipper) + #.None + #.None + + (#.Some family) + (case (list.reverse (get@ <side> family)) + #.Nil + #.None + + (#.Cons last prevs) + (#.Some (for {@.old {#family (#.Some (|> family + (set@ <side> #.Nil) + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)) + (list\compose prevs))))) + #node last}} + (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a))) + (function (_ prevs zipper) + (|>> (set@ <side> #.Nil) + (update@ <op-side> (|>> (#.Cons (get@ #node zipper)) + (list\compose prevs))))))] + {#family (#.Some (move prevs zipper family)) + #node last}))))))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(def: #export (next zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (..down zipper) + (#.Some forward) + (#.Some forward) + + #.None + (loop [@ zipper] + (case (..right @) + (#.Some forward) + (#.Some forward) + + #.None + (do maybe.monad + [@ (..up @)] + (recur @)))))) + +(def: (bottom zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (..right zipper) + (#.Some forward) + (bottom forward) + + #.None + (case (..down zipper) + (#.Some forward) + (bottom forward) + + #.None + zipper))) + +(def: #export (previous zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (..left zipper) + #.None + (..up zipper) + + (#.Some backward) + (#.Some (case (..down backward) + (#.Some then) + (..bottom then) + + #.None + backward)))) + +(template [<name> <move>] + [(def: #export (<name> zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (<move> zipper) + #.None + #.None + + (#.Some @) + (loop [@ @] + (case (<move> @) + #.None + (#.Some @) + + (#.Some @) + (recur @)))))] + + [end ..next] + [start ..previous] + ) + +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bit)) + (case (..end zipper) + #.None + true + + (#.Some _) + false)) + +(def: #export (interpose value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (|>> (//.branch value) list) + zipper)) + +(def: #export (adopt value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (|>> (#.Cons (//.leaf value))) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (do maybe.monad + [family (get@ #family zipper)] + (case (get@ #lefts family) + #.Nil + (wrap (set@ [#node #//.children] + (get@ #rights family) + (get@ #parent family))) + + (#.Cons next side) + (wrap (|> zipper + (set@ #family (|> family + (set@ #lefts side) + #.Some)) + (set@ #node next)))))) + +(template [<name> <side>] + [(def: #export (<name> value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #family zipper) + #.None + #.None + + (#.Some family) + (#.Some (set@ #family + (#.Some (update@ <side> (|>> (#.Cons (//.leaf value))) family)) + zipper))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(implementation: #export functor + (Functor Zipper) + + (def: (map f (^slots [#family #node])) + {#family (maybe\map (function (_ (^slots [#parent #lefts #rights])) + {#parent (map f parent) + #lefts (list\map (//\map f) lefts) + #rights (list\map (//\map f) rights)}) + family) + #node (//\map f node)})) + +(implementation: #export comonad + (CoMonad Zipper) + + (def: &functor ..functor) + + (def: unwrap (get@ [#node #//.value])) + + (def: (split (^slots [#family #node])) + (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) + (function (tree-splitter tree) + {#//.value (..zip tree) + #//.children (|> tree + (get@ #//.children) + (list\map tree-splitter))}))] + {#family (maybe\map (function (_ (^slots [#parent #lefts #rights])) + {#parent (split parent) + #lefts (list\map tree-splitter lefts) + #rights (list\map tree-splitter rights)}) + family) + #node (tree-splitter node)}))) |