diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index a5816bbd8..6262a6141 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -34,6 +34,9 @@ safeHead :: [a] -> Maybe a safeHead (x:_) = Just x safeHead _ = Nothing +errorHead :: String -> [a] -> a +errorHead _ (x:_) = x +errorHead s [] = error s you :: World -> Creature you w = _creatures w IM.! _yourID w diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 95505c594..12eaadc8b 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -36,7 +36,7 @@ initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk [[AnoApplyInt 0 startRoom] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] - --, [AnoApplyInt 1 lasSensorTurretTest] +-- , [AnoApplyInt 1 lasSensorTurretTest] -- ,[ChainAnos -- [[SetLabel 0 $ return $ roomRectAutoLinks 200 200 -- & rmExtPmnt ?~ triggerSwitchSPicLight (drawSwitchWire red red) @@ -47,12 +47,12 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk -- ] -- ] -- ,[SpecificRoom $ return $ connectRoom lasTunnel ] - ,[SpecificRoom $ fmap singleUseAll slowDoorRoom ] - ,[Corridor] - ,[Corridor] - ,[SpecificRoom $ fmap singleUseAll roomCCrits] - ,[AirlockAno] - ,[Corridor] +-- ,[SpecificRoom $ fmap singleUseAll slowDoorRoom ] +-- ,[Corridor] +-- ,[Corridor] +-- ,[SpecificRoom $ fmap singleUseAll roomCCrits] +-- ,[AirlockAno] +-- ,[Corridor] ------ ,[SpecificRoom roomCCrits] ------ ,[Corridor] ------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 @@ -113,6 +113,7 @@ layoutLevelFromSeed i seed = do ++ " attempt(s), Successful generation of level with seed " ++ show seed --return (fmap setLastLinkToUsed rs) + putStrLn $ show (Prelude.length rs) ++ " rooms in total" return rs Nothing -> do putStr $ "Level generation with seed " ++ show seed ++ " failed: " diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 932823762..f49adf658 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -16,11 +16,14 @@ import Control.Monad.State lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g ItemIdentity ) ] lockRoomKeyItems = [ (lasCenSensEdge, takeOne [Launcher] ) +-- , (const $ fmap singleUseAll slowDoorRoom, return MiniGun) ] itemRooms :: RandomGen g => [(ItemIdentity, State g (SubCompTree Room))] itemRooms = - [ (Launcher , corridorBoss launcherCrit ) ] + [ (Launcher , corridorBoss launcherCrit ) + -- , (MiniGun , join $ takeOne [roomMiniIntro, minigunFakeout] ) + ] corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room) corridorBoss cr = do diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 7db66d297..09b363621 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -32,8 +32,8 @@ import Control.Lens import System.Random --import qualified Data.IntMap.Strict as IM -minigunfakeout :: RandomGen g => State g (SubCompTree Room) -minigunfakeout = do +minigunFakeout :: RandomGen g => State g (SubCompTree Room) +minigunFakeout = do rcol <- rezColor ncor <- state $ randomR (0,2) roomwithmini <- randomiseAllLinks $ roomRectAutoLinks 150 150 diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 73836b134..cd4cf392c 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -11,6 +11,7 @@ module Dodge.Tree.Compose ) where import Dodge.Tree.Compose.Data import Dodge.Tree.Polymorphic +import Dodge.Base import Data.Tree expandTree :: CompTree a -> Tree a @@ -24,7 +25,8 @@ expandTree (Node root extChildren) = case root of $ map (:[]) extChildren ++ repeat [] overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a -overwriteLabel i f t ts = head $ updateSingleNode islabel update t +overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i) + $ updateSingleNode islabel update t where islabel (UseLabel j _) | i == j = True islabel _ = False diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 80ec99a66..eed8fc96c 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -29,16 +29,13 @@ posRms :: [ConvexPoly] -> Seq (Tree RoomInt) -> IO (Maybe [Room]) posRms bounds (parent,_) _ [] st = case st of - Empty -> return $ Just [] + Empty -> return $ Just [parent] Node childi ts :<| tseq -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq -posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do - putStr $ rpns 20 (_rmName cr ++ "-" ++ show i') - ++ rpns 9 (" child " ++ show numChild ) - ++ rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i ) +posRms bounds parenti numChild (t@(Node childi _):ts) tseq = do + printInfo parenti numChild childi tryLinks (0::Int) (init $ _rmLinks parent) where - rpns x s = rightPadNoSquash x ' ' s parent = fst parenti tryLinks _ [] = putStrLn "all links tried" >> return Nothing tryLinks j (l:ls) @@ -48,11 +45,9 @@ posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) (numChild + 1) ts (tseq |> shiftedt) case mayrs of - --Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls Nothing -> do - putStr $ "Backtracking to " ++ rpns 20 (_rmName cr ++ "-" ++ show i') - ++ rpns 9 (" child " ++ show numChild ) - ++ rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i ) + putStr "Backtrack: " + printInfo parenti numChild childi tryLinks (j+1) ls Just rs -> return (Just rs) where @@ -63,6 +58,14 @@ posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do r' = doRoomShift . fst $ rootLabel shiftedt shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t +printInfo :: RoomInt -> Int -> RoomInt -> IO () +printInfo (parentrm,parenti) childn (childrm,childi) = do + putStr $ rpns 20 (_rmName childrm ++ "-" ++ show childi) + ++ rpns 9 (" child " ++ show childn ) + ++ rpns 25 (" of " ++ _rmName parentrm ++ "-" ++ show parenti ) + where + rpns x s = rightPadNoSquash x ' ' s + doLnkEff :: (Point2,Float) -> Room -> Room doLnkEff x rm = case _rmLinkEff rm of (eff:effs) -> eff x $ rm & rmLinkEff .~ effs