aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/data/collection/tree/zipper.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/library/lux/data/collection/tree/zipper.lux')
-rw-r--r--stdlib/source/library/lux/data/collection/tree/zipper.lux318
1 files changed, 318 insertions, 0 deletions
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)})))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 11:02:48 +0000