From 3354d108bed6fe35814ffefb371614aa3286074d Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 25 Jul 2022 09:49:55 +0100 Subject: [PATCH] Reinstate genworld concept --- src/Dodge/Data.hs | 9 +++++-- src/Dodge/Default/World.hs | 4 +-- src/Dodge/Layout.hs | 38 ++++++++++++++-------------- src/Dodge/LevelGen.hs | 2 +- src/Dodge/LevelGen/LevelStructure.hs | 10 +++++--- src/Dodge/Placement/PlaceSpot.hs | 36 ++++++++++++++------------ src/Dodge/Randify.hs | 6 ++--- 7 files changed, 58 insertions(+), 47 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index efbbf919c..05a2dc456 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -199,6 +199,11 @@ data Universe = Universe , _uvConfig :: Configuration , _uvTestString :: Universe -> [String] } +data GenWorld = GenWorld + { _gwWorld :: World + , _genPlacements :: IM.IntMap [(Placement,Int)] + , _genRooms :: IM.IntMap Room + } data World = World { _keys :: S.Set Scancode , _mouseButtons :: M.Map MouseButton Bool @@ -290,8 +295,6 @@ data World = World , _hammers :: M.Map WorldHammer HammerPosition , _backspaceTimer :: Int , _genParams :: GenParams - , _genPlacements :: IM.IntMap [(Placement,Int)] - , _genRooms :: IM.IntMap Room , _deathDelay :: Maybe Int , _testFloat :: Float , _lLine :: (Point2,Point2) @@ -497,6 +500,8 @@ makeLenses ''Nozzle makeLenses ''Equipment makeLenses ''ScreenLayer makeLenses ''WorldBeams +makeLenses ''GenWorld + ----- ROOM LENSES makeLenses ''Room diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 8d6794eba..1f1c2e2f3 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -107,8 +107,8 @@ defaultWorld = World , _hammers = defaultWorldHammers , _backspaceTimer = 0 , _genParams = GenParams M.empty - , _genPlacements = IM.empty - , _genRooms = IM.empty +-- , _genPlacements = IM.empty +-- , _genRooms = IM.empty , _deathDelay = Nothing , _testFloat = 0 , _boundBox = square 100 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 0d5e4169b..caf705391 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -31,10 +31,10 @@ import qualified Control.Foldl as L import Data.Maybe import Data.Function -generateLevelFromRoomList :: IM.IntMap Room -> World -> World -generateLevelFromRoomList gr' w = initWallZoning - . randomCompass - . setupWorldBounds +generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld +generateLevelFromRoomList gr' w = over gwWorld initWallZoning + . over gwWorld randomCompass + . over gwWorld setupWorldBounds . doAfterPlacements . doInPlacements . doOutPlacements @@ -57,19 +57,19 @@ generateLevelFromRoomList gr' w = initWallZoning randomCompass :: World -> World randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w) -putFloorTiles :: World -> World -putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw +putFloorTiles :: GenWorld -> GenWorld +putFloorTiles gw = gw & gwWorld . floorTiles .~ floorsFromGenWorld gw -setFloors :: World -> World +setFloors :: GenWorld -> GenWorld setFloors = putFloorTiles . setTiles -- note the order of traversal of the rooms is important -- hence the reverse -- this is not ideal: should do this in some more sensible way -setTiles :: World -> World +setTiles :: GenWorld -> GenWorld setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw -setTile :: Room -> World -> World +setTile :: Room -> GenWorld -> GenWorld setTile r gw = case _rmFloor r of Tiled {} -> gw InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly] @@ -84,43 +84,43 @@ shuffleRoomPos rm = do newPos <- shuffle $ _rmPos rm return $ rm & rmPos .~ newPos -doAfterPlacements :: World -> World +doAfterPlacements :: GenWorld -> GenWorld doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw) -doAfterPlacement :: [(Placement,Int)] -> World -> World +doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld doAfterPlacement pmntis gw = gRandify gw $ do (pmnt,i) <- takeOne pmntis let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt return $ newgw & genRooms . ix i .~ rm -doInPlacements :: ( IM.IntMap [Placement],World) -> World +doInPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld doInPlacements (im,w) = let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w) in gw & genRooms .~ rms -doRoomInPlacements :: IM.IntMap [Placement] -> World -> Room -> (World, Room) +doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room) doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm where f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i) -doOutPlacements :: World -> ( IM.IntMap [Placement], World) +doOutPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld) doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w) in (pmnts,gw & genRooms .~ rms) -doRoomOutPlacements :: (IM.IntMap [Placement], World) +doRoomOutPlacements :: (IM.IntMap [Placement], GenWorld) -> Room - -> ( (IM.IntMap [Placement], World) , Room ) + -> ( (IM.IntMap [Placement], GenWorld) , Room ) doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r where f (OutPlacement pl i) ( (im,w) , rm ) = let ((neww,newrm),plmnts) = placeSpot (w,rm) pl in ((IM.insert i plmnts im, neww) , newrm ) -doIndividualPlacements :: World -> World +doIndividualPlacements :: GenWorld -> GenWorld doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw) in gw' & genRooms .~ rms -doRoomPlacements :: World -> Room -> (World, Room) +doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room) doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm setupWorldBounds :: World -> World @@ -202,7 +202,7 @@ gameRoomFromRoom rm = GameRoom floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift) -floorsFromGenWorld :: World -> [(Point3,Point3)] +floorsFromGenWorld :: GenWorld -> [(Point3,Point3)] floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms getTiles :: Floor -> [Tile] diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index cb8027f4b..ac938347c 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -28,7 +28,7 @@ generateWorldFromSeed i = do (roomList,bounds) <- layoutLevelFromSeed 0 i return -- $ saveLevelStartSlot $ postGenerationProcessing - $ generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i} + $ _gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i}) & roomClipping .~ bounds postGenerationProcessing :: World -> World diff --git a/src/Dodge/LevelGen/LevelStructure.hs b/src/Dodge/LevelGen/LevelStructure.hs index 59dd09e9e..f8afa7423 100644 --- a/src/Dodge/LevelGen/LevelStructure.hs +++ b/src/Dodge/LevelGen/LevelStructure.hs @@ -16,10 +16,12 @@ import qualified IntMapHelp as IM import qualified Data.Map.Strict as M --import Control.Lens -worldToGenWorld :: IM.IntMap Room -> World -> World -worldToGenWorld rms w = w - & genParams .~ evalState generateGenParams (_randGen w) - & genRooms .~ rms +worldToGenWorld :: IM.IntMap Room -> World -> GenWorld +worldToGenWorld rms w = GenWorld + { _gwWorld = w & genParams .~ evalState generateGenParams (_randGen w) + , _genRooms = rms + , _genPlacements = mempty + } generateGenParams :: RandomGen g => State g GenParams generateGenParams = do diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 08ad9de5d..b161bffc6 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -28,7 +28,7 @@ import Data.Bifunctor -- when placing a placement, we update the world and the room and assign an id -- to the placement -placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] ) +placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] ) placeSpot (w,rm) plmnt = case plmnt of Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback @@ -39,31 +39,31 @@ placeSpot (w,rm) plmnt = case plmnt of where shift = _rmShift rm -placePickOne :: Int -> Placement -> Room -> World -> World +placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))] -placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement]) -placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt' +placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement]) +placeRandomPlacement rplmnt w rm = placeSpot (w & gwWorld . randGen .~ g,rm) plmnt' where - (plmnt', g) = runState rplmnt (_randGen w) + (plmnt', g) = runState rplmnt (_randGen (_gwWorld w)) -placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Placement]) +placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement]) placePlainPSSpot w rm plmnt shift = let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w newplmnt = plmnt & plMID ?~ i - in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt) + in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt (_gwWorld w') newplmnt) where recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl in (wr,newplmnt:newplmnts) -- this should be tidied up -placeSpotUsingLink :: World +placeSpotUsingLink :: GenWorld -> Room -> Placement -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> (RoomPos -> Room -> Room) -> Maybe Placement - -> ((World, Room), [Placement]) + -> ((GenWorld, Room), [Placement]) placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) Nothing -> case fallback of @@ -76,14 +76,18 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r Just (ps,rmpos) -> Just ( ps,rmpos:poss) placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) - -> Placement -> World -> ((World,Room),[Placement]) + -> Placement -> GenWorld -> ((GenWorld,Room),[Placement]) placeSpotRoomRand rm i f plmnt w = - let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps) + let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gwWorld w) + in placeSpot (w & gwWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps) + +placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) +placeSpotID ps pt gw = let (i,w) = placeSpotID' ps pt (_gwWorld gw) + in (i,gw & gwWorld .~ w) -- the Int here is some id that is assigned when the placement is placed -placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) -placeSpotID ps pt w = case pt of +placeSpotID' :: PlacementSpot -> PSType -> World -> (Int, World) +placeSpotID' ps pt w = case pt of PutTrigger cnd -> plNewID triggers cnd w PutMod mdi -> plNewUpID modifications mdID mdi w PutProp prp -> plNewUpID props prID (mvProp p rot prp) w @@ -109,7 +113,7 @@ placeSpotID ps pt w = case pt of PutID i -> (i, w) PutWorldUpdate f -> (0, w & f ps) PutUsingGenParams f -> let (w',pt') = f w - in placeSpotID ps pt' w' + in placeSpotID' ps pt' w' where p@(V2 px py) = _psPos ps p' = V3 px py 0 @@ -120,7 +124,7 @@ shiftDec :: Point2 -> Float -> Picture -> Picture shiftDec p r pic = uncurryV translate p $ rotate r pic evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World) -evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) +evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w) where (evaluatedType, g) = runState rgen (_randGen w) diff --git a/src/Dodge/Randify.hs b/src/Dodge/Randify.hs index 01fbe9346..3736ecdb6 100644 --- a/src/Dodge/Randify.hs +++ b/src/Dodge/Randify.hs @@ -6,6 +6,6 @@ import System.Random import Control.Monad.State import Control.Lens -gRandify :: World -> State StdGen World -> World -gRandify gw mw = let (gw',g) = runState mw (_randGen gw) - in gw' & randGen .~ g +gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld +gRandify gw mw = let (gw',g) = runState mw (_randGen $ _gwWorld gw) + in gw' & gwWorld . randGen .~ g