diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index a395b7b17..5203582fb 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -82,7 +82,6 @@ data World = World , _pathGraph :: ~(Gr Point2 Float) , _pathGraphP :: ~[(Point2,Point2)] , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) - , _savedWorlds :: M.Map SaveSlot World , _menuLayers :: [ScreenLayer] , _worldFlags :: S.Set WorldFlag , _carteDisplay :: !Bool @@ -94,16 +93,17 @@ data World = World , _closeActiveObjects :: [Either FloorItem Button] , _seenLocations :: IM.IntMap (World -> Point2,String) , _selLocation :: Int - , _keyConfig :: KeyConfigSDL - , _config :: Configuration , _sideEffects :: World -> IO World , _inventoryMode :: InventoryMode , _lClickHammer :: HammerPosition , _radDistortion :: [(Point2,Point2,Point2,Float)] - , _gameRooms :: [GameRoom] - , _preloadData :: PreloadData - , _frameClock :: Int , _worldBounds :: Bounds + , _gameRooms :: [GameRoom] + , _keyConfig :: KeyConfigSDL + , _config :: Configuration + , _preloadData :: PreloadData + , _savedWorlds :: M.Map SaveSlot World + , _frameClock :: Int } data SaveSlot = QuicksaveSlot | LevelStartSlot deriving (Eq,Ord) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 1221ec225..2e864bc0f 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -22,6 +22,7 @@ import Dodge.Layout.Tree.Shift import Dodge.Creature import Dodge.LevelGen.Data import Dodge.Item.Weapon.Launcher +import MonadHelp import Control.Lens import Control.Monad.State @@ -34,21 +35,18 @@ initialRoomTree = do let t' = padCorridors struct t = treeFromTrunk [[StartRoom] + ,[SpecificRoom spawnerRoom] ,[Corridor] ,[Corridor] - ,[SpecificRoom $ fmap connectRoom pistolerRoom] ,[Corridor] ,[Corridor] --- ,[Corridor] --- ,[Corridor] --- ,[Corridor] ,[SpecificRoom $ return $ connectRoom lasTunnel ] ,[Corridor] ,[SpecificRoom $ fmap connectRoom slowDoorRoom ] ,[Corridor] ,[Corridor] ,[Corridor] - ,[SpecificRoom roomCCrits] + ,[SpecificRoom $ fmap connectRoom roomCCrits] ,[Corridor] ,[AirlockAno] ,[Corridor] @@ -99,5 +97,7 @@ initialRoomTree = do t' shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t -levx :: RandomGen g => Int -> State g [Room] -levx _ = untilJust initialRoomTree +levx :: RandomGen g => Int -> State g ([Room] , Int) +levx _ = untilJustCount initialRoomTree + + diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index c58198cc4..d8cf7e79c 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -4,34 +4,41 @@ import Dodge.Save import Dodge.Data import Dodge.Data.SoundOrigin import Dodge.Creature ---import Dodge.Zone import Dodge.Floor import Dodge.Layout import Dodge.Story import Dodge.WorldEvent.Cloud import Dodge.SoundLogic import Dodge.SoundLogic.LoadSound ---import Dodge.Creature.Perception import Geometry.Data ---import Shape.Data ---import Dodge.Render.Shape ---import Picture ---import Dodge.GameRoom ---import Geometry +import Dodge.Room.Data import System.Random +import System.Timeout import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import qualified Data.Map as M ---import Control.Lens ---import Data.Maybe +import Control.Monad.State firstWorld :: IO World firstWorld = do -- i <- randomRIO (0,5000) - let i = 2 + let i = 3 putStrLn $ "Seed for level generation: " ++ show ( i :: Int) - return $ generateLevelFromRoomList (levx 1) $ initialWorld {_randGen = mkStdGen i} + let g = mkStdGen i + (roomList,n) <- f g + putStrLn $ "Had to go through "++ show n ++ " random generators" + return $ generateLevelFromRoomList roomList $ initialWorld {_randGen = g} + where + f :: StdGen -> IO ([Room],Int) + f g = do + mayrs <- timeout 10000000 . return $ evalState (levx 1) g + case mayrs of + Nothing -> do + let i = fst $ random g + putStrLn $ "Timeout; trying new seed: " ++ show i + f (mkStdGen i) + Just rs -> return rs initialWorld :: World initialWorld = defaultWorld @@ -58,16 +65,3 @@ initialWorld = defaultWorld testStringInit :: World -> [String] testStringInit _ = [] ---testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _znObjects . _wallsZone --- where --- f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr --- | otherwise = Nothing ---testStringInit _ = [] ---testStringInit w = [show . length $ newSounds w] ---testStringInit w = (show . _crPos $ _creatures w IM.! 0) --- : (map show . _grBound . last $ sortOn _grName grs) --- ++ closeRooms --- where --- closeRooms = map _grName $ filter (pointInOrOnPolygon p . _grBound) grs --- grs = _gameRooms w --- p = _cameraViewFrom w diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 0152ef2f1..b6c93a9e3 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -48,6 +48,7 @@ import Dodge.Default import Sound.Data import Geometry import Geometry.Vector3D +--import Data.Preload import System.Random import Control.Lens diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index c6ac25b45..47bef2223 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Dodge.Layout where import Dodge.Data @@ -27,7 +27,7 @@ import Polyhedra import Polyhedra.Data import Data.List (nubBy) -import Control.Monad.State +--import Control.Monad.State import Control.Lens import System.Random import Data.Tree @@ -37,7 +37,7 @@ import Data.Foldable import qualified Control.Foldl as L import Data.Maybe -generateLevelFromRoomList :: State StdGen [Room] -> World -> World +generateLevelFromRoomList :: [Room] -> World -> World generateLevelFromRoomList gr w = initWallZoning . setupWorldBounds @@ -51,7 +51,7 @@ generateLevelFromRoomList gr w where path = pairsToGraph dist pairPath pairPath = concatMap _rmPath rs - rs = zipWith addTile zs . evalState gr $ _randGen w + rs = zipWith addTile zs gr zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w doRoomPlacements :: World -> Room -> World diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index f03ffc0c7..7aa784480 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -24,14 +24,14 @@ shiftRoomTreeSearchAll -> [[Room]] shiftRoomTreeSearchAll _ Empty = [[]] shiftRoomTreeSearchAll bs (Node r ts :<| tseq) - | roomIsClipping = [] -- this is called too often--might get memoized? - | otherwise = case ts of - [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq - (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls --- = case ts of --- [] | roomIsClipping -> [] +-- | roomIsClipping = [] -- this is called too often--might get memoized? +-- | otherwise = case ts of -- [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq -- (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls + = case ts of + [] | roomIsClipping -> [] + [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq + (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls where convexBounds = map pointsToPoly $ _rmBound r ls = init $ _rmLinks r diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index ca6694f4b..40af424b8 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -12,14 +12,15 @@ import Dodge.Config.Data import Dodge.Config.Update import SDL import SDL.Internal.Numbered -import Dodge.Layout -import Dodge.Floor +--import Dodge.Layout +--import Dodge.Floor import Dodge.Initialisation import Preload.Update import Dodge.Base.Window import Dodge.SoundLogic import Control.Lens +--import Control.Monad.State optionMenu :: ScreenLayer optionMenu = OptionScreen { _scTitle = const "OPTIONS" @@ -159,13 +160,9 @@ pauseMenuOptions = startNewGame :: World -> Maybe World startNewGame w = Just $ w & menuLayers .~ [WaitScreen (const "GENERATING...") 1] - & worldEvents .~ const aNewGame - where - aNewGame :: World - aNewGame = updateFramebufferSize $ generateLevelFromRoomList (levx 1) $ initialWorld - & randGen .~ _randGen w - & config .~ _config w - & preloadData .~ _preloadData w +-- & worldEvents .~ const aNewGame + & sideEffects .~ const (firstWorld <&> keyConfig .~ _keyConfig w <&> config .~ _config w + <&> preloadData .~ _preloadData w) -- this kills save games etc... -- | hacky scodeToChar :: Scancode -> Char diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 9e91735e9..5a6601be8 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -34,26 +34,22 @@ import System.Random import Data.Tree import Data.Bifunctor -roomC :: Float -> Float -> Room -roomC x y = defaultRoom - { _rmPolys = [rectNSWE y 0 0 x] - , _rmLinks = lnks - , _rmPath = pth - , _rmPS = [windowLine (V2 (x/2) 0) (V2 (x/2) (y-60)) - ] - , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] - } - where - lnks = map (first toV2) - [( (x-20, 0),pi) - ,( ( 20, 0),pi) - ,( ( 0, 20),pi/2) - ] - xn = 4 - yn = 4 - yd = (y - 40) / fromIntegral yn - xd = (x - 40) / fromIntegral xn - pth = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn) +roomC :: RandomGen g => Float -> Float -> State g Room +roomC w h = do + wl <- takeOne + [ sPS (V2 0 0) 0 $ PutWall (rectNSWE (h-60) 0 (w/2-10) (w/2+10)) defaultCrystalWall + , windowLine (V2 (w/2) 0) (V2 (w/2) (h-60)) + ] + changeLinkFrom fromCond $ roomRectAutoLinks w h + & rmPS %~ (wl : ) + & rmRandPSs .~ [farside] + where + fromCond (V2 x _,_) = x < w / 2 - 10 + farside = do + x <- state $ randomR (5, w/2 - 20) + y <- state $ randomR (5, h - 70) + a <- state $ randomR (0, 2*pi) + return (V2 x y,a) roomPadCut :: [Point2] -> Point2 -> Room roomPadCut ps p = defaultRoom @@ -355,14 +351,9 @@ weaponRoom = join $ takeOne , weaponLongCorridor ] -roomCCrits :: RandomGen g => State g (Tree (Either Room Room)) -roomCCrits = do - ps <- replicateM 20 $ randInCirc 9 - let plmnts = map (\p -> sPS p 0 randC1) - $ zipWith (+.+) [V2 x y | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps - lamps = [sPS (V2 50 100) 0 putLamp , sPS (V2 175 100) 0 putLamp] - return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200 - +roomCCrits :: RandomGen g => State g Room +roomCCrits = roomC 200 200 + <&> rmPS %~ (replicate 20 (Placement (PSRoomRand 0) randC1 (const Nothing)) ++ ) longRoom :: RandomGen g => State g Room longRoom = do @@ -410,18 +401,16 @@ shootersRoom' = do x1 <- state $ randomR (20,w/3-20) x2 <- state $ randomR (w/3+20,2*w/3-20) x3 <- state $ randomR (2*w/3+20,w-20) - y1 <- state $ randomR (250,550) - y2 <- state $ randomR (250,550) - y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560) + y1 <- state $ randomR (280,550) + y2 <- state $ randomR (280,550) + y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280,560) x4 <- state $ randomR (60,w-60) - y4 <- state $ randomR (40,180) - --p <- takeOne [V2 x1 y1,V2 x2 y2,V2 x3 y3] + y4 <- state $ randomR (40,150) let bln x y = putBlockN (x+25) (x-25) (y+20) (y+10) blv x y = putBlockV (x+25) (x-25) (y+20) (y+10) plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4 - ++ [spanLightI (V2 0 200) (V2 w 200) - , mntLightLnkCond (\(V2 _ y,_) -> y < 50) - , mntLightLnkCond (\(V2 _ y,_) -> y > 550) + ++ [spanLightI (V2 (-10) 200) (V2 (w/2) 200) + ,spanLightI (V2 (w/2) 200) (V2 (w+10) 200) ] toPS x y = return (V2 x y,-0.5*pi) return $ set rmPS plmnts $ roomRectAutoLinks w 600 @@ -460,7 +449,10 @@ pillarGrid = do y <- takeOne ys a <- state $ randomR (0,2*pi) return (V2 (x+gap) y,a) - let plmnts = replicate 30 (mntLightLnkCond (const True)) + cornerRestrict (V2 x y,_) + = (x > 40 && x < h - 40) + || (y > 40 && y < h - 40) + let plmnts = replicate 8 (mntLightLnkCond cornerRestrict) ++ concat [f x y | x<-xs,y<-ys] return $ roomRect w h (max i 2) (max i 2) @@ -480,31 +472,26 @@ pistolerRoom = pillarGrid shootingRange :: RandomGen g => State g (Tree (Either Room Room)) shootingRange = do rm1 <- shootersRoom1 >>= changeLinkTo (\(V2 _ y,_) -> y < 40) - >>= filterLinks (\(V2 _ y,r) -> y > 200 && r /= 0) + >>= changeLinkFrom (\(V2 _ y,r) -> y > 200 && r /= 0) rm2 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) - >>= filterLinks (\(V2 _ y,r) -> y > 200 && r /= 0) + >>= changeLinkFrom (\(V2 _ y,r) -> y > 200 && r /= 0) rm3 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) - >>= filterLinks (\(_,r) -> r == 0) - return $ treeFromPost [Left rm1 - ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20) - ,Left rm2 - ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20) - ] - (Right rm3) + >>= changeLinkFrom (\(_,r) -> r == 0) + return $ treeFromPost + [Left rm1 + ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) + & rmPS %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) + ,Left rm2 + ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) + & rmPS %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) + ] + (Right rm3) spawnerRoom :: RandomGen g => State g (Tree (Either Room Room)) spawnerRoom = do x <- state $ randomR (250,300) y <- state $ randomR (300,400) - wl <- takeOne [sPS (V2 0 0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) - defaultCrystalWall - ,windowLine (V2 (x/2) 0) (V2 (x/2) (y-60)) - ] - let plmnts = [sPS (V2 (x/4) ( y/4)) (pi/2) $ PutCrit spawnerCrit - ,wl - ,sPS (V2 (x/2) ( y-10)) 0 putLamp - ] - let f (V2 lx _,_) = lx < x/2-5 - roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2) + roomWithSpawner <- roomC x y <&> + rmPS %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :) aRoom <- airlock - return $ treeFromTrunk [Left aRoom] roomWithSpawner + return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index afb658087..95bf4370e 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -18,8 +18,8 @@ import System.Random import Control.Monad.State {- | A passage with a switch that opens forward access while closing backwards access. -} airlock :: RandomGen g => State g Room ---airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ] -airlock = takeOne [airlockZ] +airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ] +--airlock = takeOne [airlockZ] {- | Straight airlock -} airlock0 :: Room airlock0 = defaultRoom diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 29c9480b9..56cf80ce0 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -51,6 +51,9 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints thinHighBar :: Float -> Point2 -> Point2 -> Shape thinHighBar = highBar 3 +thinHighBarChain :: Float -> [Point2] -> Shape +thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . loopPairs + thickHighBar :: Float -> Point2 -> Point2 -> Shape thickHighBar = highBar 5 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 747900dec..f1fed2208 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -71,7 +71,10 @@ roomRectAutoLinks :: Float -> Float -> Room roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)) {_rmPS = plmnts} where - plmnts = [mntLightLnkCond (const True)] + plmnts = + [mntLightLnkCond (const True) +-- ,sps0 $ PutForeground $ thinHighBarChain 50 $ rectNSWE y 0 0 x + ] {- Combines two rooms into one room. Mostly involves concatenation. -} combineRooms :: Room -> Room -> Room diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index cc2287c53..6e1681e1d 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -30,7 +30,8 @@ startRoom = do girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2)) treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) - $ roomRectAutoLinks w h & rmPS .~ + $ roomRectAutoLinks w h & rmPS %~ + ( [ fground , mountLightJ (V2 0 (h/3)) (V3 40 (h/3) 70) , tankSquareEmboss4 (dim orange) 50 (h-60) @@ -39,5 +40,6 @@ startRoom = do , lightSensor (V2 (0.8*w) (0.25*h)) 0 , putLasTurret & placementSpot .~ PS (V2 (0.8*w) (0.8*h)) 0 , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) - ] + ] ++ + ) ) diff --git a/src/MonadHelp.hs b/src/MonadHelp.hs new file mode 100644 index 000000000..bfeb2e583 --- /dev/null +++ b/src/MonadHelp.hs @@ -0,0 +1,17 @@ +module MonadHelp where + +untilJust :: Monad m => m (Maybe a) -> m a +untilJust m = go + where + go = do + mayx <- m + maybe go return mayx + +untilJustCount :: Monad m => m (Maybe a) -> m (a, Int) +untilJustCount m = go 0 + where + go i = do + mayx <- m + case mayx of + Nothing -> go (i+1) + Just x -> return (x,i)