Allow for random composition of trees

src/Dodge/Tree/Compose.hs

@@ -10,16 +10,19 @@ module Dodge.Tree.Compose
     , changeToPassDown
     , overwriteLabel
     , applyToCompRoot
+    , composeTree
+    , composeTreeRand
+--    , compTree
     ) where
 import Dodge.Tree.Compose.Data
-import Dodge.Tree.Polymorphic
+import TreeHelp
 import Dodge.Base
 import LensHelp
 
+import Control.Monad.State
+import Data.Foldable
+import System.Random
 import Data.Maybe
-import Data.Tree
-import Data.Tree.Lens
---import Data.Bifunctor
 
 expandTree :: CompTree a -> Tree a
 expandTree (Node rt extChildren) = case rt of
@@ -32,11 +35,11 @@ expandTree (Node rt extChildren) = case rt of
             $ map (:[]) extChildren ++ repeat []
 
 applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
-applyToCompRoot f = applyToRoot (unCompose %~ f)
+applyToCompRoot f = over root (unCompose %~ f)
 
 overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
 overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
-    $ updateSingleNode islabel update t
+    $ updateSingleNodes islabel update t
   where
     islabel (UseLabel j _) | i == j = True
     islabel _ = False
@@ -65,17 +68,27 @@ singleUseNone x = Node (UseNone x) []
 changeToPassDown :: ComposingNode a -> ComposingNode a
 changeToPassDown x = PassDown (_unCompose x)
 
---cTree :: Tree (a -> Maybe a, Tree a) -> Tree a
---cTree (Node (_,t) ch) = shiftChildren $ foldr g' (fdsa t) (map cTree ch)
+composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
+composeTreeRand (Node (_,t) ts) = attachListR t ts
 
-cTree' :: Tree (a -> Maybe a, Tree a) -> Tree a
-cTree' (Node (_,t) ts) = cTree t ts
+attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a)
+attachListR t xs = fmap shiftChildren $ foldrM newfRand (fmap ([],) t) xs
 
-cTree :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
-cTree t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
+newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) 
+    -> State g (Tree ([Tree a],a))
+newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
+  where
+    upf = (t ^?! root . _1)
+    g x = fromMaybe x (upf x)
+
+composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+composeTree (Node (_,t) ts) = attachList t ts
+
+attachList :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
+attachList t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
 
 newf :: Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) -> Tree ([Tree a],a)
-newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ cTree' t ) )
+newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
   where
     upf = (t ^?! root . _1)
     g x = fromMaybe x (upf x)
@@ -83,25 +96,25 @@ newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root .
 shiftChildren :: Tree ([Tree a],a) -> Tree a
 shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 
--- hideous, but it should work
--- the idea is that the fst argument selects (and edits) a node to which all the
--- children are attached
--- the tree is thus built up recursively
-compTree :: Tree (a -> Maybe a, Tree (a,b)) -> Tree b
-compTree (Node (_,t) ch) = attachChildren t $ map (\t' -> (fst $ rootLabel t',compTree t')) ch
-
-chooseAttachNodes :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> [Tree (a,b,[c])]
-chooseAttachNodes (t,z) (Node (x,y,zs) ch) = case t x of
-    Just x' -> Node (x',y,(z:zs)) ch : concatMap (chooseAttachNodes (t,z)) ch
-    Nothing -> concatMap (chooseAttachNodes (t,z)) ch
-
-mAttachToNode :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> Tree (a,b,[c])
-mAttachToNode p t = fromMaybe t $ listToMaybe $ chooseAttachNodes p t
-
-moveToChildren :: Tree (a,b,[Tree b]) -> Tree b
-moveToChildren (Node (_,x,ts) ts') = Node x (map moveToChildren ts' ++ ts)
-
-attachChildren :: Tree (a,b) -> [(a->Maybe a,Tree b)] -> Tree b
-attachChildren t = moveToChildren . foldr mAttachToNode t'
-  where
-    t' = fmap (\(x,y) -> (x,y,[])) t
+---- hideous, but it should work
+---- the idea is that the fst argument selects (and edits) a node to which all the
+---- children are attached
+---- the tree is thus built up recursively
+--compTree :: Tree (a -> Maybe a, Tree (a,b)) -> Tree b
+--compTree (Node (_,t) ch) = attachChildren t $ map (\t' -> (fst $ rootLabel t',compTree t')) ch
+--
+--chooseAttachNodes :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> [Tree (a,b,[c])]
+--chooseAttachNodes (t,z) (Node (x,y,zs) ch) = case t x of
+--    Just x' -> Node (x',y,(z:zs)) ch : concatMap (chooseAttachNodes (t,z)) ch
+--    Nothing -> concatMap (chooseAttachNodes (t,z)) ch
+--
+--mAttachToNode :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> Tree (a,b,[c])
+--mAttachToNode p t = fromMaybe t $ listToMaybe $ chooseAttachNodes p t
+--
+--moveToChildren :: Tree (a,b,[Tree b]) -> Tree b
+--moveToChildren (Node (_,x,ts) ts') = Node x (map moveToChildren ts' ++ ts)
+--
+--attachChildren :: Tree (a,b) -> [(a->Maybe a,Tree b)] -> Tree b
+--attachChildren t = moveToChildren . foldr mAttachToNode t'
+--  where
+--    t' = fmap (\(x,y) -> (x,y,[])) t