From d17f83928a4d9cf721b6115938ba1ca59a08a341 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 13 Jun 2022 19:44:47 +0100 Subject: [PATCH] Improve logging --- src/Dodge/LevelGen.hs | 22 ++++--- src/Dodge/Tree/Compose.hs | 131 -------------------------------------- 2 files changed, 12 insertions(+), 141 deletions(-) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 70201b970..b71a714aa 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -32,36 +32,38 @@ generateWorldFromSeed i = do layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly]) layoutLevelFromSeed i seed = do let i' = i + 1 - putStrLn $ "Generating level with seed " ++ show seed - appendFile "log/attemptedSeeds" $ show seed ++ "\n" + putStrLnAppend "log/attemptedSeeds" $ "Generating level with seed " ++ show seed + appendFile "log/attemptedSeeds" "\n" let g = mkStdGen seed let treecluster = evalState initialRoomTree (g,0) let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster - mapM_ ((\str -> putStrLn str >> appendFile "log/treeCluster" str) . smallDrawTree . fmap showIntsString) - labts + appendFile "log/treeCluster" ("Seed: "++ show seed ++ "\n") + mapM_ (putStrLnAppend "log/treeCluster" . smallDrawTree . fmap showIntsString) labts let tc = composeTree treecluster let rmtree = inorderNumberTree tc putStrLn "Room layout (compact): " putStrLn $ compactDrawTree $ fmap (show . snd) rmtree let nameshow (r,rid) = _rmName r ++ "-" ++ show rid appendFile "log/aGeneratedRoomLayout" ("Seed: "++ show seed) - appendFile "log/aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree - putStrLn "Layout with room names (also written to log/aGeneratedRoomLayout):" - putStrLn $ smallDrawTree $ fmap nameshow rmtree + putStrLnAppend "log/aGeneratedRoomLayout" "Layout with room names:" + putStrLnAppend "log/aGeneratedRoomLayout" $ smallDrawTree $ fmap nameshow rmtree mrs <- positionRoomsFromTree rmtree case mrs of Just (PosRooms bounds rs) -> do - putStrLn $ "After " ++ show i' + putStrLnAppend "log/attemptedSeeds" $ "After " ++ show i' ++ " attempt(s), Successful generation of level with seed " ++ show seed --return (fmap setLastLinkToUsed rs) - putStrLn $ show (Prelude.length rs) ++ " rooms in total" + putStrLnAppend "log/attemptedSeeds" $ show (Prelude.length rs) ++ " rooms in total" return (IM.fromList $ map reversePair rs , bounds) Nothing -> do - putStr $ "Level generation with seed " ++ show seed ++ " failed: " + putStrLnAppend "log/attemptedSeeds" $ "Level generation with seed " ++ show seed ++ " failed: " let (seed',_) = random g layoutLevelFromSeed i' seed' +putStrLnAppend :: FilePath -> String -> IO () +putStrLnAppend fp str = appendFile fp (str ++ "\n") >> putStrLn str + reversePair :: (a,b) -> (b,a) reversePair (a,b) = (b,a) diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 8943e96df..8a2fb9cef 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -43,77 +43,6 @@ overwriteLabel i t ts = safeUpdateSingleNode ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing)) t ---overwriteLabel :: Int -> (a -> ComposingNode a) -> Tree a -> [Tree a] -> Tree 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 (Node (useAll x) _) ts' = Node ( x) ts' ---passUntiluseAll (Node cn ts) ts' = Node ( (_unCompose cn)) $ map (`passUntiluseAll` ts') ts - ---chainUses :: [Tree a] -> Tree a ---chainUses (t:s:ts) = chainUses (passUntiluseAll t [s]:ts) ---chainUses [t] = t ---chainUses [] = error "tried to concatenate an empty list of Trees" - ---pure :: a -> Tree (ComposingNode a) ---pure x = Node (useAll x) [] - ---useAllAtEnd :: Tree a -> Tree a ---useAllAtEnd tree = case tree of --- Node x (t:ts) -> Node ( x) (useAllAtEnd t : map (fmap UseNone) ts) --- Node x [] -> Node (useAll x) [] - ---pure :: a -> Tree a ---pure x = Node (UseNone x) [] - ---changeTo :: ComposingNode a -> ComposingNode a ---changeTo x = (_unCompose x) - ---composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a) ---composeTreeRand (Node (_,t) ts) = attachListR t ts - ---attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a) ---attachListR t xs = shiftChildren <$> foldrM newfRand (fmap ([],) t) xs - ---newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) --- -> State g (Tree ([Tree a],a)) ---newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) ) --- where --- upf = t ^?! root . _1 --- g x = fromMaybe x (upf x) - ---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 --- ---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 ) ) --- where --- upf = t ^?! root . _1 --- 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 ) ) where @@ -122,66 +51,6 @@ attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) shiftChildren :: Tree ([Tree a],a) -> Tree a shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts') ----- hideous, but it should work ----- the idea is that the fst argument selects (and edits) a node to which all the ----- children are attached ----- the tree is thus built up recursively ---compTree :: Tree (a -> Maybe a, Tree (a,b)) -> Tree b ---compTree (Node (_,t) ch) = attachChildren t $ map (\t' -> (fst $ rootLabel t',compTree t')) ch --- ---chooseAttachNodes :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> [Tree (a,b,[c])] ---chooseAttachNodes (t,z) (Node (x,y,zs) ch) = case t x of --- Just x' -> Node (x',y,(z:zs)) ch : concatMap (chooseAttachNodes (t,z)) ch --- Nothing -> concatMap (chooseAttachNodes (t,z)) ch --- ---mAttachToNode :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> Tree (a,b,[c]) ---mAttachToNode p t = fromMaybe t $ listToMaybe $ chooseAttachNodes p t --- ---moveToChildren :: Tree (a,b,[Tree b]) -> Tree b ---moveToChildren (Node (_,x,ts) ts') = Node x (map moveToChildren ts' ++ ts) --- ---attachChildren :: Tree (a,b) -> [(a->Maybe a,Tree b)] -> Tree b ---attachChildren t = moveToChildren . foldr mAttachToNode t' --- where --- t' = fmap (\(x,y) -> (x,y,[])) t - ---logMB :: MetaBranch a -> Tree String ---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 - ---composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a) ---composeAndSubLog is dolog mt = case mt of --- MTree{} -> do --- 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 - ---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 (\(_,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) --- $ zip [(0::Int)..] $ _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 - composeTree :: MetaTree a b -> Tree a composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)