Improve logging
This commit is contained in:
+12
-10
@@ -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)
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user