diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index a06c261c8..1e0715eb4 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -7,7 +7,7 @@ module Dodge.Annotation import Dodge.UseAll import RandomHelp import Dodge.Tree -import Dodge.Data +--import Dodge.Data import Dodge.Annotation.Data import LensHelp diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index bfe15f725..2bc3c8430 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -37,6 +37,9 @@ layoutLevelFromSeed i seed = do let g = mkStdGen seed let treecluster = evalState initialRoomTree (g,0) --tc <- composeAndLog [0] (\str -> putStrLn str >> appendFile "log/treeCluster" str) treecluster +-- let labts = decomposeTree $ numMetaTree treecluster + let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster + mapM_ (putStrLn . drawTree . fmap show) labts let tc = composeTree treecluster ---- (strs,tc) = composeTree' treecluster ----appendFile "log/TreeCluster" ("Seed: "++ show seed) diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 5b2c72462..54f689aa2 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Dodge.Room.Room where import Data.Tile import Dodge.UseAll diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 862bea790..752eac2ea 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -4,6 +4,11 @@ module Dodge.Tree.Compose ( tToBTree , overwriteLabel , composeTree + , decomposeTree + , numMetaTree + , numSelfTree + , combineTree + , decomposeSelfTree -- , composeTree' , shiftChildren , attachTree @@ -22,11 +27,13 @@ import TreeHelp --import Dodge.Base import LensHelp +import Data.Tuple --import Data.Bifunctor --import Control.Monad.State --import Data.Foldable --import System.Random import Data.Maybe +import Control.Monad.State overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room overwriteLabel i t ts = safeUpdateSingleNode @@ -176,6 +183,29 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts') composeTree :: MetaTree a b -> Tree a composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt) +mtTopLabels :: MetaTree a b -> Tree b +mtTopLabels (MTree lab _ bs) = Node lab (map (mtTopLabels . _mbTree) bs) + +mtUnderLabels :: MetaTree a b -> [Tree b] +mtUnderLabels mt = maybe [] decomposeTree (mt ^? mtTree . nodeMetaTree) + ++ concatMap (mtUnderLabels . _mbTree) (_mtBranches mt) + +decomposeTree :: MetaTree a b -> [Tree b] +decomposeTree mt = mtTopLabels mt : mtUnderLabels mt + +decomposeSelfTree :: SelfTree a -> [Tree a] +decomposeSelfTree st = fmap fst (_unST st) : concatMap (f . snd) (_unST st) + where + f (Left t) = [t] + f (Right st') = decomposeSelfTree st' + +combineTree :: (a -> b) -> MetaTree a b -> SelfTree b +combineTree f mt = case _mtTree mt of + NodeTree t -> ST (Node (_mtLabel mt,Left $ fmap f t) (fmap (_unST . combineTree f . _mbTree) $ _mtBranches mt)) + --NodeTree t -> ST (Node (Left $ fmap f t) _) + NodeMTree mt' -> ST (Node (_mtLabel mt,Right $ combineTree f mt') + $ map (_unST . combineTree f . _mbTree) $ _mtBranches mt) + composeNode :: MetaNode a b -> Tree a composeNode (NodeTree t) = t composeNode (NodeMTree mt) = composeTree mt @@ -203,3 +233,24 @@ toOnward rm = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) | otherwise = Nothing +numSelfTree st = evalState (numSelfTree' st) [0] + +numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int],a)) +numSelfTree' (ST (Node lrt bs)) = do + is <- get + modify (ix 0 +~ 1) + bs' <- mapM (fmap _unST . numSelfTree' . ST) bs + case lrt of + (y,Left t) -> return $ ST (Node ((is,y),Left $ fmap ((_1 %~ (\x -> x:is)) . swap) $ numTraversable t) bs') + (y,Right mt') -> return $ ST (Node ((is,y),Right (evalState (numSelfTree' mt') (0:is))) bs') +-- return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs' + +numMetaTree :: MetaTree a String -> MetaTree a ([Int],String) +numMetaTree mt = evalState (numMetaTree' mt) [0] + +numMetaTree' :: MetaTree a b -> State [Int] (MetaTree a ([Int],b)) +numMetaTree' (MTree lab mn bs) = do + is <- get + modify (ix 0 +~ 1) + bs' <- mapM (mbTree %%~ numMetaTree') bs + return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs' diff --git a/src/Dodge/Tree/Compose/Data.hs b/src/Dodge/Tree/Compose/Data.hs index a983a7f9b..c030da7c5 100644 --- a/src/Dodge/Tree/Compose/Data.hs +++ b/src/Dodge/Tree/Compose/Data.hs @@ -10,6 +10,11 @@ data MetaTree a b = MTree {_mtLabel :: b , _mtTree :: MetaNode a b, _mtBranches data MetaNode a b = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a b} data MetaBranch a b = MBranch {_mbAttach :: a -> Maybe a, _mbTree :: MetaTree a b} +newtype SelfTree a = ST {_unST :: Tree (a,Either (Tree a) (SelfTree a))} + makeLenses ''MetaTree makeLenses ''MetaBranch makeLenses ''MetaNode + +instance Functor (MetaTree a) where + fmap f (MTree b mn bs) = MTree (f b) (mn & nodeMetaTree %~ fmap f) (map (mbTree %~ fmap f) bs)