diff options
| -rw-r--r-- | stdlib/source/lux/data/coll/tree/rose.lux | 41 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/tree/zipper.lux | 52 |
2 files changed, 65 insertions, 28 deletions
diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux index ebd208a83..dc44510d5 100644 --- a/stdlib/source/lux/data/coll/tree/rose.lux +++ b/stdlib/source/lux/data/coll/tree/rose.lux @@ -1,8 +1,9 @@ (;module: lux - (lux (control monad + (lux (control functor + monad eq) - (data (coll [list "" Monad<List>])) + (data (coll [list "L/" Monad<List>])) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]))) @@ -16,7 +17,7 @@ (def: #export (flatten tree) (All [a] (-> (Tree a) (List a))) (#;Cons (get@ #value tree) - (join (map flatten (get@ #children tree))))) + (L/join (L/map flatten (get@ #children tree))))) (def: #export (leaf value) (All [a] (-> a (Tree a))) @@ -32,24 +33,32 @@ (type: #rec Tree-AST [AST (List Tree-AST)]) -(def: (tree^ _) - (-> Unit (Syntax Tree-AST)) - (s;either (s;record (s;seq s;any (s;tuple (s;some (lambda [state] ((tree^ []) state)))))) - (s;seq s;any (:: s;Monad<Syntax> wrap (list))))) +(def: tree^ + (Syntax Tree-AST) + (|> (|>. s;some s;record (s;seq s;any)) + s;rec + s;some + s;record + (s;seq s;any) + s;tuple)) -(syntax: #export (tree type [root (tree^ [])]) +(syntax: #export (tree [root tree^]) {#;doc (doc "Tree literals." - (tree Int 10) - (tree Int {10 [20 - {30 []} - 40]}))} - (wrap (list (` (: (Tree (~ type)) - (~ (loop [[value children] root] - (` {#value (~ value) - #children (list (~@ (map recur children)))})))))))) + (tree Int [10 {20 {} + 30 {} + 40 {}}]))} + (wrap (list (` (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~@ (L/map recur children)))}))))))) ## [Structs] (struct: #export (Eq<Tree> Eq<a>) (All [a] (-> (Eq a) (Eq (Tree a)))) (def: (= tx ty) (and (:: Eq<a> = (get@ #value tx) (get@ #value ty)) (:: (list;Eq<List> (Eq<Tree> Eq<a>)) = (get@ #children tx) (get@ #children ty))))) + +(struct: #export _ (Functor Tree) + (def: (map f fa) + {#value (f (get@ #value fa)) + #children (L/map (map f) + (get@ #children fa))})) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux index 3c443f281..59a4d40ff 100644 --- a/stdlib/source/lux/data/coll/tree/zipper.lux +++ b/stdlib/source/lux/data/coll/tree/zipper.lux @@ -1,8 +1,11 @@ (;module: lux - (lux (data (coll [list "" Monad<List> Fold<List> "List/" Monoid<List>] - (tree [rose #+ Tree]) - [stack #+ Stack])) + (lux (control functor + comonad) + (data (coll [list "L/" Monad<List> Fold<List> Monoid<List>] + (tree [rose #+ Tree "T/" Functor<Tree>]) + [stack #+ Stack]) + [maybe "M/" Monad<Maybe>]) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]))) @@ -71,9 +74,9 @@ (|> parent (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) (lambda [node] - (set@ #rose;children (List/append (list;reverse (get@ #lefts zipper)) - (#;Cons (get@ #node zipper) - (get@ #rights zipper))) + (set@ #rose;children (L/append (list;reverse (get@ #lefts zipper)) + (#;Cons (get@ #node zipper) + (get@ #rights zipper))) node))))))) (def: #export (root zipper) @@ -99,7 +102,7 @@ (def: #export (<all-name> zipper) (All [a] (-> (Zipper a) (Zipper a))) - (fold (lambda [_] <one-name>) zipper (get@ <side> zipper)))] + (L/fold (lambda [_] <one-name>) zipper (get@ <side> zipper)))] [right rightmost #rights #lefts] [left leftmost #lefts #rights] @@ -117,16 +120,18 @@ (All [a] (-> a (Zipper a) (Zipper a))) (update@ [#node #rose;children] (lambda [children] - (#;Cons (rose;tree ($ +0) {value []}) - children)) + (list& (: (Tree ($ +0)) + (rose;tree [value {}])) + children)) zipper)) (def: #export (append-child value zipper) (All [a] (-> a (Zipper a) (Zipper a))) (update@ [#node #rose;children] (lambda [children] - (List/append children - (list (rose;tree ($ +0) {value []})))) + (L/append children + (list (: (Tree ($ +0)) + (rose;tree [value {}]))))) zipper)) (def: #export (remove zipper) @@ -156,7 +161,8 @@ _ (#;Some (|> zipper (update@ <side> (lambda [side] - (#;Cons (rose;tree ($ +0) {value []}) + (#;Cons (: (Tree ($ +0)) + (rose;tree [value {}])) side)))))))] [insert-left #lefts] @@ -190,3 +196,25 @@ _ false)) + +(struct: #export _ (Functor Zipper) + (def: (map f fa) + {#parent (|> fa (get@ #parent) (M/map (map f))) + #lefts (|> fa (get@ #lefts) (L/map (T/map f))) + #rights (|> fa (get@ #rights) (L/map (T/map f))) + #node (T/map f (get@ #node fa))})) + +## (struct: #export _ (CoMonad Zipper) +## (def: functor Functor<Zipper>) + +## (def: unwrap (get@ [#node #rose;value])) + +## (def: (split wa) +## (let [tree-splitter (lambda tree-splitter [tree] +## {#rose;value (from-tree tree) +## #rose;children (L/map tree-splitter +## (get@ #rose;children tree))})] +## {#parent (|> wa (get@ #parent) (M/map split)) +## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) +## #rights (|> wa (get@ #rights) (L/map tree-splitter)) +## #node (|> fa (get@ #node) tree-splitter)}))) |