aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/data/collection/tree/zipper.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/data/collection/tree/zipper.lux')
-rw-r--r--stdlib/source/lux/data/collection/tree/zipper.lux285
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)})))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 19:15:25 +0000