Add new "composing" tree functions

src/Dodge/Tree/Compose.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {-| Combining and composing trees of trees.  -}
 module Dodge.Tree.Compose
     ( expandTree
@@ -13,19 +14,19 @@ module Dodge.Tree.Compose
 import Dodge.Tree.Compose.Data
 import Dodge.Tree.Polymorphic
 import Dodge.Base
+import LensHelp
 
 import Data.Maybe
 import Data.Tree
-import Control.Lens
 import Data.Tree.Lens
 --import Data.Bifunctor
 
 expandTree :: CompTree a -> Tree a
-expandTree (Node root extChildren) = case root of
+expandTree (Node rt extChildren) = case rt of
     Node (UseAll x)     _   -> Node x (map expandTree extChildren)
     Node (UseSome is x) _   -> Node x (map (expandTree . \i -> extChildren !! i) is)
-    Node (UseNone _)    _   -> fmap _unCompose root
-    Node (UseLabel _ _) _   -> fmap _unCompose root
+    Node (UseNone _)    _   -> fmap _unCompose rt
+    Node (UseLabel _ _) _   -> fmap _unCompose rt
     Node (PassDown x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
     Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
             $ map (:[]) extChildren ++ repeat []
@@ -64,13 +65,20 @@ 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 $ undefined
+--cTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+--cTree (Node (_,t) ch) = shiftChildren $ foldr g' (fdsa t) (map cTree ch)
 
-g :: (a-> Maybe a, Tree a) -> Tree ([Tree a],a) -> [Tree ([Tree a],a)]
-g (f,t) = updateSingleNode (isJust . f . snd) (root . _2 %~ g)
+cTree' :: Tree (a -> Maybe a, Tree a) -> Tree a
+cTree' (Node (_,t) ts) = cTree t ts
+
+cTree :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
+cTree 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 ) )
   where
-    g x = fromMaybe x (f x)
+    upf = (t ^?! root . _1)
+    g x = fromMaybe x (upf x)
 
 shiftChildren :: Tree ([Tree a],a) -> Tree a
 shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')

src/Dodge/Tree/Polymorphic.hs

@@ -18,9 +18,12 @@ module Dodge.Tree.Polymorphic
     , addToTrunk
     , inorderNumberTree
     , updateSingleNode
+    , safeUpdateSingleNode
     ) where
 import Dodge.RandomHelp
 
+import Data.Maybe
+import Data.Tree.Lens
 import Data.Tree
 import Control.Monad.State
 import System.Random
@@ -92,6 +95,9 @@ updateSingleNode f update t@(Node x ts)
   where
     updateChildren = map (Node x) (subMap (updateSingleNode f update) ts)
 
+safeUpdateSingleNode :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a
+safeUpdateSingleNode f g t = fromMaybe t $ listToMaybe $ updateSingleNode f g t
+
 subMap :: (a -> [a]) -> [a] -> [[a]]
 subMap f (x:xs) = (f x <&> (: xs)) ++ ( (x :) <$> subMap f xs ) 
 subMap _ [] = []