Add functions for composing trees

src/Dodge/Tree/Compose.hs

@@ -11,6 +11,7 @@ module Dodge.Tree.Compose
     , overwriteLabel
     , applyToCompRoot
     , composeTree
+    , composeTree'
     , composeTreeRand
 --    , compTree
     ) where
@@ -19,6 +20,7 @@ import TreeHelp
 import Dodge.Base
 import LensHelp
 
+import Data.Bifunctor
 import Control.Monad.State
 import Data.Foldable
 import System.Random
@@ -84,6 +86,22 @@ newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1
 composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
 composeTree (Node (_,t) ts) = attachList t ts
 
+composeTree' :: Monoid b => Tree (a -> Maybe (b, a), Tree a) -> (b, Tree a)
+composeTree' (Node (_,t) ts) = attachList' t ts
+
+attachList' :: Monoid b => Tree a -> [Tree (a -> Maybe (b, a), Tree a)] -> (b,Tree a)
+attachList' t xs = shiftChildren <$> foldrM newf' (fmap ([],) t) xs
+
+newf' :: Monoid b => Tree (a -> Maybe (b, a),Tree a) -> Tree ([Tree a],a) -> (b , Tree ([Tree a],a))
+newf' t = first (s<>) . msafeUpdateSingleNode (isJust . upf . snd) upt
+  where
+    (s,t') = composeTree' t
+    upf = t ^?! root . _1
+    upt = (root . _2 %%~ g) . (root . _1 .:~ t')
+    g x = fromMaybe (mempty,x) (upf x)
+--    mtf = undefined
+--     ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
+
 attachList :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
 attachList t xs = shiftChildren $ foldr newf (fmap ([],) t) xs