BROKEN partial redo of room tree composition

src/Dodge/Tree/Compose.hs

@@ -1,16 +1,16 @@
 {-# LANGUAGE TupleSections #-}
 {-| Combining and composing trees of trees.  -}
 module Dodge.Tree.Compose
-    ( expandTree
-    , singleUseAll
-    , singleUseNone
-    , passUntilUseAll
-    , chainUses
-    , useAllAtEnd
-    , changeToPassDown
-    , overwriteLabel
-    , applyToCompRoot
-    , composeTree
+    ( --expandTree
+    --, singleUseAll
+    --, singleUseNone
+    --, passUntilUseAll
+    --, chainUses
+    --, useAllAtEnd
+    --, changeToPassDown
+    --, overwriteLabel
+    --, applyToCompRoot
+     composeTree
     , composeTree'
     , composeTreeRand
 --    , compTree
@@ -26,49 +26,49 @@ import Data.Foldable
 import System.Random
 import Data.Maybe
 
-expandTree :: CompTree a -> Tree a
-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 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 []
+--expandTree :: CompTree a -> Tree a
+--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 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 []
 
-applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
-applyToCompRoot f = over root (unCompose %~ f)
+--applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
+--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)
-    $ updateSingleNodes islabel update t
-  where
-    islabel (UseLabel j _) | i == j = True
-    islabel _ = False
-    update (Node x _) = Node (f $ _unCompose x) ts
+--overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
+--overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
+--    $ updateSingleNodes islabel update t
+--  where
+--    islabel (UseLabel j _) | i == j = True
+--    islabel _ = False
+--    update (Node x _) = Node (f $ _unCompose x) ts
 
-passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
-passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
-passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts
+--passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
+--passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
+--passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts
 
-chainUses :: [SubCompTree a] -> SubCompTree a
-chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
-chainUses [t] = t
-chainUses []  = error "tried to concatenate an empty list of SubCompTrees"
+--chainUses :: [SubCompTree a] -> SubCompTree a
+--chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
+--chainUses [t] = t
+--chainUses []  = error "tried to concatenate an empty list of SubCompTrees"
 
-singleUseAll :: a -> Tree (ComposingNode a)
-singleUseAll x = Node (UseAll x) []
+--singleUseAll :: a -> Tree (ComposingNode a)
+--singleUseAll x = Node (UseAll x) []
 
-useAllAtEnd :: Tree a -> SubCompTree a
-useAllAtEnd tree = case tree of
-    Node x (t:ts)   -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
-    Node x []       -> Node (UseAll x) []
+--useAllAtEnd :: Tree a -> SubCompTree a
+--useAllAtEnd tree = case tree of
+--    Node x (t:ts)   -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
+--    Node x []       -> Node (UseAll x) []
 
-singleUseNone :: a -> SubCompTree a
-singleUseNone x = Node (UseNone x) []
+--singleUseNone :: a -> SubCompTree a
+--singleUseNone x = Node (UseNone x) []
 
-changeToPassDown :: ComposingNode a -> ComposingNode a
-changeToPassDown x = PassDown (_unCompose x)
+--changeToPassDown :: ComposingNode a -> ComposingNode a
+--changeToPassDown x = PassDown (_unCompose x)
 
 composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
 composeTreeRand (Node (_,t) ts) = attachListR t ts

src/Dodge/Tree/Compose/Data.hs

@@ -10,9 +10,9 @@ data ComposingNode a
     | UseSome   {_composeIndices :: [Int], _unCompose :: a}
     | UseNone   {_unCompose :: a}
     | UseLabel  {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
-type SubCompTree a = Tree (ComposingNode a)
-type CompTree a = Tree (SubCompTree a)
-type LabSubCompTree a = (Tree (ComposingNode a),TreeSubLabelling)
+type SubCompTree a = Tree a
+type CompTree a = Tree (Tree a)
+type LabSubCompTree a = (a -> Maybe ([String],a),Tree a)
 type LabCompTree a = Tree (LabSubCompTree a)
 data TreeSubLabelling = TreeSubLabelling
     { _topLabel :: String
@@ -20,3 +20,4 @@ data TreeSubLabelling = TreeSubLabelling
     }
 makeLenses ''ComposingNode
 makeLenses ''TreeSubLabelling
+