Reinstate genworld concept
This commit is contained in:
+7
-2
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+19
-19
@@ -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]
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user