Simplify MetaTrees

src/Dodge/Annotation.hs

@@ -31,6 +31,6 @@ annoToRoomTree an = case an of
         ii <- randomitemidentity
         keyroom <- fromJust $ lookup ii ks
         return $ MTree ("PassthroughLockKeyLists-"++show ii) 
-            (MTree "RassThroughLockKeyLists" lr [MBranch "" (toLabel i) keyroom])
+            (NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch "" (toLabel i) keyroom])
             []
 

src/Dodge/LevelGen.hs

@@ -36,7 +36,8 @@ layoutLevelFromSeed i seed = do
     appendFile "log/attemptedSeeds" $ show seed ++ "\n"
     let g = mkStdGen seed
     let treecluster = evalState initialRoomTree (g,0)
-    tc <- composeAndLog [0] (\str -> putStrLn str >> appendFile "log/treeCluster" str) treecluster
+    --tc <- composeAndLog [0] (\str -> putStrLn str >> appendFile "log/treeCluster" str) treecluster
+    let tc = composeTree treecluster
     ----    (strs,tc) = composeTree' treecluster
     ----appendFile "log/TreeCluster" ("Seed: "++ show seed)
     ----mapM_ (appendFile "log/treeCluster" . ('\n':))  strs

src/Dodge/Room/Room.hs

@@ -126,8 +126,7 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
 roomMiniIntro :: RandomGen g => State g (MetaTree Room)
 roomMiniIntro = do
     midroom <- join $ takeOne [miniTree2] --,glassLesson]
-    rToOnward "roomMiniIntro" 
+    rToOnward "roomMiniIntro" midroom
-        midroom
 
 roomCenterPillar :: RandomGen g => State g Room
 roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) 

src/Dodge/Tree/Compose.hs

@@ -4,11 +4,11 @@ module Dodge.Tree.Compose
     ( tToBTree
     , overwriteLabel
     , composeTree
-    , composeTree'
+--    , composeTree'
     , shiftChildren
     , attachTree
-    , composeTreeRand
+--    , composeTreeRand
-    , composeAndLog
+--    , composeAndLog
     , toOnward
     , attachOnward
 --    , cmpToMT
@@ -77,46 +77,46 @@ overwriteLabel i t ts = safeUpdateSingleNode
 --changeTo :: ComposingNode a -> ComposingNode a
 --changeTo x =  (_unCompose x)
 
-composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
+--composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
-composeTreeRand (Node (_,t) ts) = attachListR t ts
+--composeTreeRand (Node (_,t) ts) = attachListR t ts
 
-attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a)
+--attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a)
-attachListR t xs = shiftChildren <$> foldrM newfRand (fmap ([],) t) xs
+--attachListR t xs = shiftChildren <$> foldrM newfRand (fmap ([],) t) xs
 
-newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) 
+--newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) 
-    -> State g (Tree ([Tree a],a))
+--    -> State g (Tree ([Tree a],a))
-newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
+--newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
-  where
+--  where
-    upf = t ^?! root . _1
+--    upf = t ^?! root . _1
-    g x = fromMaybe x (upf x)
+--    g x = fromMaybe x (upf x)
 
-composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+--composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
-composeTree (Node (_,t) ts) = attachList t ts
+--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
 
-composeTree' :: Monoid b => Tree (a -> Maybe (b, a), Tree a) -> (b, Tree a)
+--attachList' :: Monoid b => Tree a -> [Tree (a -> Maybe (b, a), Tree a)] -> (b,Tree a)
-composeTree' (Node (_,t) ts) = attachList' t ts
+--attachList' t xs = shiftChildren <$> foldrM newf' (fmap ([],) t) xs
 
-attachList' :: Monoid b => Tree a -> [Tree (a -> Maybe (b, a), Tree a)] -> (b,Tree a)
+----newf' :: Monoid b => Tree (a -> Maybe (b, a),Tree a) -> Tree ([Tree a],a) -> (b , Tree ([Tree a],a))
-attachList' t xs = shiftChildren <$> foldrM newf' (fmap ([],) t) xs
+----newf' t = first (s<>) . msafeUpdateSingleNode (isJust . upf . snd) upt
-
+----  where
-newf' :: Monoid b => Tree (a -> Maybe (b, a),Tree a) -> Tree ([Tree a],a) -> (b , Tree ([Tree a],a))
+----    (s,t') = composeTree' t
-newf' t = first (s<>) . msafeUpdateSingleNode (isJust . upf . snd) upt
+----    upf = t ^?! root . _1
-  where
+----    upt = (root . _2 %%~ g) . (root . _1 .:~ t')
-    (s,t') = composeTree' t
+----    g x = fromMaybe (mempty,x) (upf x)
-    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 :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
-attachList t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
+--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 :: 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 .:~ composeTree t ) )
+--newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
-  where
+--  where
-    upf = t ^?! root . _1
+--    upf = t ^?! root . _1
-    g x = fromMaybe x (upf x)
+--    g x = fromMaybe x (upf x)
 
 attachTree :: (a -> Maybe a) -> Tree a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
 attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ t ) )
@@ -149,50 +149,66 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 --  where
 --    t' = fmap (\(x,y) -> (x,y,[])) t
 
-logMB :: MetaBranch a -> Tree String
+--logMB :: MetaBranch a -> Tree String
-logMB (MBranch str _ mt) = root ++.~ (str ++ ":") $ logMT mt
+--logMB (MBranch str _ mt) = root ++.~ (str ++ ":") $ logMT mt
+--
+--logMT :: MetaTree a -> Tree String
+--logMT mt = case mt of
+--    MTree str (NodeMTree  brs -> Node ("M:"++str) $ map logMB brs
+--    BTree str _ brs -> Node str $ map logMT brs
 
-logMT :: MetaTree a -> Tree String
+--composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
-logMT mt = case mt of
+--composeAndSubLog is dolog mt = case mt of
-    MTree str _ brs -> Node ("M:"++str) $ map logMB brs
+--    MTree{} -> do
-    BTree str _ brs -> Node str $ map logMT brs
+--        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
+--        rt <- composeAndLog (0:is) dolog $ _mtTree mt
+--        brs <- mapM (\(_,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
+--            $ zip [(0::Int)..] $ _mtBranches mt
+--        return $ attachList rt $ map pure brs
+--    bt -> do
+--        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
+--        dolog $ drawTree $ logMT mt
+--        brs <- mapM (composeAndSubLog is dolog) (_btBranches bt)
+--        return $ Node (_btValue bt) brs
 
-composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
+--composeAndLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndSubLog is dolog mt = case mt of
+--composeAndLog is dolog mt = case mt of
-    MTree{} -> do
+--    MTree{} -> do
-        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
+--        dolog $ drawTree $ logMT mt
-        rt <- composeAndLog (0:is) dolog $ _mtTree mt
+--        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
-        brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
+--        rt <- composeAndLog (0:is) dolog $ _mtTree mt
-            $ zip [0..] $ _mtBranches mt
+--        brs <- mapM (\(_,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
-        return $ attachList rt $ map pure brs
+--            $ zip [(0::Int)..] $ _mtBranches mt
-    bt -> do
+--        return $ attachList rt $ map pure brs
-        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
+--    BTree{} -> do
-        dolog $ drawTree $ logMT mt
+--        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
-        brs <- mapM (composeAndSubLog is dolog) (_btBranches bt)
+--        dolog $ drawTree $ logMT mt
-        return $ Node (_btValue bt) brs
+--        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
+--        return $ Node (_btValue mt) brs
+
+composeTree :: MetaTree a -> Tree a
+composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
+
+composeNode :: MetaNode a -> Tree a
+composeNode (NodeTree t) = t
+composeNode (NodeMTree mt) = composeTree mt
+
+attachList' :: Tree a -> [MetaBranch a] -> Tree a
+attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
+
+attachBranch :: MetaBranch a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
+attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) 
+    ( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) )
+  where
+    upf = _mbAttach mb
+    g x = fromMaybe x (upf x)
 
-composeAndLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndLog is dolog mt = case mt of
-    MTree{} -> do
-        dolog $ drawTree $ logMT mt
-        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
-        rt <- composeAndLog (0:is) dolog $ _mtTree mt
-        brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
-            $ zip [0..] $ _mtBranches mt
-        return $ attachList rt $ map pure brs
-    BTree{} -> do
-        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
-        dolog $ drawTree $ logMT mt
-        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
-        return $ Node (_btValue mt) brs
 
 tToBTree :: Tree Room -> MetaTree Room
-tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts
+tToBTree t = MTree "" (NodeTree t) []
 
 attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
-attachOnward t1 t2 = case t1 of
+attachOnward t1 t2 = t1 & mtBranches .:~ MBranch "Onward" toOnward t2
-    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward t2
-    BTree {} -> MTree (mRootLabel t1 ++ "-" ++ mRootLabel t2) t1 [MBranch "Onward" toOnward t2]
 
 toOnward :: Room -> Maybe Room
 toOnward rm

src/Dodge/Tree/Compose/Data.hs

@@ -8,13 +8,9 @@ data MetaBranch a
     = MBranch {_mbLabel :: String, _mbAttach :: a -> Maybe a, _mbTree :: MetaTree a}
 
 data MetaTree a
-    = MTree {_mtLabel :: String , _mtTree :: MetaTree a , _mtBranches :: [MetaBranch a] }
+    = MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] }
-    | BTree {_btLabel :: String , _btValue :: a ,         _btBranches :: [MetaTree a] }
+--    | BTree {_btLabel :: String , _btValue :: a ,         _btBranches :: [MetaTree a] }
-
+data MetaNode a = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a}
-mRootLabel :: MetaTree a -> String
-mRootLabel mt = case mt of
-    MTree {} -> _mtLabel mt
-    BTree {} -> _btLabel mt
 
 --type CompTree a = Tree (Tree a)
 type LabTree a = (a -> Maybe ([String],a),Tree a)
@@ -26,4 +22,5 @@ data TreeSubLabelling = TreeSubLabelling
 makeLenses ''TreeSubLabelling
 makeLenses ''MetaTree
 makeLenses ''MetaBranch
+makeLenses ''MetaNode
 

src/Dodge/UseAll.hs

@@ -19,7 +19,7 @@ toLabel i rm
     | otherwise = Nothing
 
 rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room)
-rToOnward s t = return $ MTree s (tToBTree t) []
+rToOnward s t = return $ tToBTree t & mtLabel .~ s
 
 cleatOnward :: Room -> Room
 cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster