aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--stdlib/source/lux/data/coll/tree/rose.lux41
-rw-r--r--stdlib/source/lux/data/coll/tree/zipper.lux52
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)})))