diff --git a/appDodge/Main.hs b/appDodge/Main.hs index f910e606d..6dd312f3d 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -56,7 +56,7 @@ firstWorldLoad theConfig = do SDL.cursorVisible $= False theKeyConfig <- loadKeyConfig pdata <- doPreload >>= applyWorldConfig theConfig - w <- firstWorld + w <- worldFromSeed 0 return $ w & preloadData .~ pdata & keyConfig .~ theKeyConfig & config .~ theConfig diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 5c86da9f8..91d1de763 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -103,22 +103,25 @@ initialRoomTree :: RandomGen g => State g (Tree Room) initialRoomTree = do expandTreeBy id <$> mapM annoToRoomTree initialAnoTree -layoutLevelFromSeed :: Int -> IO [Room] -layoutLevelFromSeed seed = do +layoutLevelFromSeed :: Int -> Int -> IO [Room] +layoutLevelFromSeed i seed = do + let i' = i + 1 putStrLn $ "Generating level with seed " ++ show seed let g = mkStdGen seed let rmtree = inorderNumberTree $ evalState initialRoomTree g - putStrLn "Seed layout: " + putStrLn "Abstract layout: " putStrLn $ compactDrawTree $ fmap (show . snd) rmtree mrs <- positionRooms rmtree case mrs of Just rs -> do - putStrLn $ "Successful generation of level with seed " ++ show seed + putStrLn $ "After " ++ show i' + ++ " attempt(s), Successful generation of level with seed " + ++ show seed return (fmap setLastLinkToUsed rs) Nothing -> do putStr $ "Level generation with seed " ++ show seed ++ " failed: " let (seed',_) = random g - layoutLevelFromSeed seed' + layoutLevelFromSeed i' seed' where setLastLinkToUsed rm = case _rmLinks rm of (_:_) -> rm diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index e002050e8..05bc6da49 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -17,15 +17,9 @@ import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -firstWorld :: IO World -firstWorld = do --- i <- randomRIO (0,5000) - let i = 3 - --putStrLn $ "Seed for level generation: " ++ show ( i :: Int) --- let g = mkStdGen i --- (roomList,n) <- f g --- putStrLn $ "Had to go through "++ show n ++ " random generators" - roomList <- layoutLevelFromSeed i +worldFromSeed :: Int -> IO World +worldFromSeed i = do + roomList <- layoutLevelFromSeed 0 i return $ generateLevelFromRoomList roomList initialWorld -- note this uses a random generator defined elsewhere @@ -43,7 +37,8 @@ initialWorld = defaultWorld , _mousePos = V2 0 0 , _testString = testStringInit , _yourID = 0 - , _worldEvents = saveWorldInEmptySlot LevelStartSlot . soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing + , _worldEvents = saveWorldInEmptySlot LevelStartSlot + . soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]] , _pressPlates = IM.empty , _buttons = IM.empty diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 229939265..78d0ab9a0 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -55,7 +55,8 @@ posRms -> Seq (Tree RoomInt) -> IO (Maybe [Room]) posRms _ _ [] Empty = return $ Just [] -posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) = fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq +posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) + = fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do putStr $ "Trying to place room " ++ show i' ++ ": " tryLinks' (0::Int) (_rmLinks r) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 9d3b1fd45..f6ee09c7b 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -28,17 +28,17 @@ import qualified Data.IntSet as IS placeSpot :: (World,Room) -> Placement -> (World,Room) placeSpot (w,rm) plmnt = case plmnt of - Placement{_placementSpot = PSRoomRand i} + Placement{_plSpot = PSRoomRand i} -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot (w & randGen .~ g,rm) (plmnt & placementSpot .~ uncurry PS ps) - Placement{_placementSpot = PSLnk{}} -> case lnks of + in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) + Placement{_plSpot = PSLnk{}} -> case lnks of ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt) [] -> case fallback of Nothing -> (w,rm) Just plmnt' -> placeSpot (w,rm) plmnt' where uselnk lnki = rm & rmLinks %~ deletei lnki - rps = _placementSpot plmnt + rps = _plSpot plmnt fallback = _psFallback rps test = _psLinkTest rps (lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..] @@ -49,8 +49,8 @@ placeSpot (w,rm) plmnt = case plmnt of invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot) Placement{} -> - let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w - in maybe (w',rm) (placeSpot (w',rm)) (_idPlacement plmnt i) + let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w + in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i) PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt' where @@ -97,6 +97,7 @@ placeSpotID ps pt w = case pt of PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) PutNothing -> (0,w) PutID i -> (i, w) + PutWorldUpdate f -> (0,f ps w) where p@(V2 px py) = _psPos ps p' = V3 px py 0 diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index f5bf08fd5..708935c39 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -25,6 +25,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutDoor Color (World -> Bool) [(Point2,Point2)] | RandPS (State StdGen PSType) | PutForeground Shape + | PutWorldUpdate (PlacementSpot -> World -> World) | PutNothing | PutID { _putID :: Int} -- maybe there is a monadic implementation of this? @@ -34,12 +35,11 @@ data PlacementSpot , _psLinkShift :: (Point2,Float) -> (Point2,Float) , _psFallback :: Maybe Placement } - | PSRoomRand - { _psRoomRandPointNum :: Int } + | PSRoomRand { _psRoomRandPointNum :: Int } data Placement = Placement - { _placementSpot :: PlacementSpot - , _psType :: PSType - , _idPlacement :: Int -> Maybe Placement + { _plSpot :: PlacementSpot + , _plType :: PSType + , _plIDCont :: Int -> Maybe Placement } | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position | RandomPlacement {_unRandomPlacement :: State StdGen Placement} diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 5fbe10d21..d20d32c44 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -18,6 +18,7 @@ import Dodge.Base.Window import Dodge.SoundLogic import Control.Lens +import System.Random optionMenu :: ScreenLayer optionMenu = OptionScreen @@ -159,8 +160,10 @@ pauseMenuOptions = startNewGame :: World -> Maybe World startNewGame w = Just $ w & menuLayers .~ [WaitScreen (const "GENERATING...") 1] - & sideEffects .~ const (firstWorld <&> keyConfig .~ _keyConfig w <&> config .~ _config w + & sideEffects .~ const (worldFromSeed i <&> keyConfig .~ _keyConfig w <&> config .~ _config w <&> preloadData .~ _preloadData w) -- this kills save games etc... + where + i = fst $ random (_randGen w) -- | hacky scodeToChar :: Scancode -> Char diff --git a/src/Dodge/Placements/Wall.hs b/src/Dodge/Placements/Wall.hs index 92d16cc72..95ebeef2c 100644 --- a/src/Dodge/Placements/Wall.hs +++ b/src/Dodge/Placements/Wall.hs @@ -89,7 +89,7 @@ replacePutID -> Room -> Room replacePutID i psts r = - r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts + r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts {- Partition a list by a predicate, apply a zip to those elements that satisfy the predicate, concatenate the new zipped list and the other (unchanged) half. -} @@ -104,7 +104,7 @@ subZipWith f g xs ys = in zipWith g zs ys ++ ws isPutID :: Int -> Placement -> Bool -isPutID i ps = Just i == ps ^? psType . putID +isPutID i ps = Just i == ps ^? plType . putID putBlockRect :: Float -> Float -> Float -> Float -> [Placement] putBlockRect a x b y = diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 74cd87725..bd867f5b1 100644 --- a/src/Dodge/Room/Data.hs +++ b/src/Dodge/Room/Data.hs @@ -31,4 +31,8 @@ data Room = Room , _rmViewpoints :: [Point2] , _rmRandPSs :: [State StdGen (Point2,Float)] } +data RoomPos + = Link (Point2,Float) + | UsedLink (Point2,Float) + | LinkInt Int (Point2,Float) makeLenses ''Room diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 8cedbed5e..37cb291a0 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -81,7 +81,7 @@ lasTunnel = defaultRoom { _rmPolys = polys , _rmBound = polys , _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)] - , _rmPS = [putLasTurret & placementSpot .~ PS (V2 10 240) (1.5*pi) + , _rmPS = [putLasTurret & plSpot .~ PS (V2 10 240) (1.5*pi) , lowWall (rectNSEW 65 40 0 25) , mountLightV (V2 50 10) (V3 40 20 50) ] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 6e1681e1d..7f7129f37 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -38,7 +38,7 @@ startRoom = do , tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 120 , lightSensor (V2 (0.8*w) (0.25*h)) 0 - , putLasTurret & placementSpot .~ PS (V2 (0.8*w) (0.8*h)) 0 + , putLasTurret & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0 , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) ] ++ )