justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Remove GenWorld datatype

Browse Source
This commit is contained in:
justin
2022-06-02 19:06:00 +01:00
parent 35cd213bcf
commit 7c4a853d70
9 changed files with 95 additions and 107 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1 -6
View File
@@ -1371,7 +1371,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutShape Shape | PutShape Shape
| PutWorldUpdate (PlacementSpot -> World -> World) | PutWorldUpdate (PlacementSpot -> World -> World)
| PutNothing | PutNothing
| PutUsingGenParams (GenWorld -> (GenWorld,PSType)) | PutUsingGenParams (World -> (World,PSType))
| PutID { _putID :: Int} | PutID { _putID :: Int}
-- maybe there is a monadic implementation of this? -- maybe there is a monadic implementation of this?
-- add room effect for any placement spot? -- add room effect for any placement spot?
@@ -1505,10 +1505,6 @@ data RoomPosType
| RoomPosLab Int | RoomPosLab Int
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data GenWorld = GenWorld
{ _gWorld :: World
}
makeLenses ''CreatureState makeLenses ''CreatureState
makeLenses ''Damage makeLenses ''Damage
makeLenses ''DamageEffect makeLenses ''DamageEffect
@@ -1588,4 +1584,3 @@ makeLenses ''RoomLink
makeLenses ''RoomPos makeLenses ''RoomPos
makeLenses ''RoomPosType makeLenses ''RoomPosType
makeLenses ''RPLinkStatus makeLenses ''RPLinkStatus
makeLenses ''GenWorld
src/Dodge/Layout.hs
+34 -35
View File
@@ -36,10 +36,10 @@ import Data.Maybe
import Data.Function import Data.Function
import Control.Monad.State import Control.Monad.State
generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld generateLevelFromRoomList :: IM.IntMap Room -> World -> World
generateLevelFromRoomList gr' w = over gWorld initWallZoning generateLevelFromRoomList gr' w = initWallZoning
. over gWorld randomCompass . randomCompass
. over gWorld setupWorldBounds . setupWorldBounds
. placeWires . placeWires
. doAfterPlacements . doAfterPlacements
. doInPlacements . doInPlacements
@@ -61,26 +61,26 @@ generateLevelFromRoomList gr' w = over gWorld initWallZoning
randomCompass :: World -> World randomCompass :: World -> World
randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w) randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
putFloorTiles :: GenWorld -> GenWorld putFloorTiles :: World -> World
putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw
setFloors :: GenWorld -> GenWorld setFloors :: World -> World
setFloors = putFloorTiles . setTiles setFloors = putFloorTiles . setTiles
-- note the order of traversal of the rooms is important -- note the order of traversal of the rooms is important
-- hence the reverse -- hence the reverse
-- this is not ideal: should do this in some more sensible way -- this is not ideal: should do this in some more sensible way
setTiles :: GenWorld -> GenWorld setTiles :: World -> World
setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms $ _gWorld gw setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms $ gw
setTile :: Room -> GenWorld -> GenWorld setTile :: Room -> World -> World
setTile r gw = case _rmFloor r of setTile r gw = case _rmFloor r of
Tiled {} -> gw Tiled {} -> gw
InheritFloor -> gw & gWorld . genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly] InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
where where
t = case _rmMParent r of t = case _rmMParent r of
Nothing -> Tile poly (V2 0 0) (V2 1 0) 16 Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
Just pid -> head $ _tiles $ _rmFloor $ _genRooms (_gWorld gw) IM.! pid Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
shuffleRoomPos :: RandomGen g => Room -> State g Room shuffleRoomPos :: RandomGen g => Room -> State g Room
@@ -88,9 +88,8 @@ shuffleRoomPos rm = do
newPos <- shuffle $ _rmPos rm newPos <- shuffle $ _rmPos rm
return $ rm & rmPos .~ newPos return $ rm & rmPos .~ newPos
placeWires :: GenWorld -> GenWorld placeWires :: World -> World
placeWires w = w placeWires w = foldr placeRoomWires ( w) (_genRooms w)
& gWorld .~ foldr placeRoomWires (_gWorld w) (_genRooms $ _gWorld w)
placeRoomWires :: Room -> World -> World placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w placeRoomWires rm w = IM.foldr ($) w
@@ -118,43 +117,43 @@ placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape
rightpleftq x = isRHS rmcen p x && isLHS rmcen q x rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
rs = _rmShift rm rs = _rmShift rm
doAfterPlacements :: GenWorld -> GenWorld doAfterPlacements :: World -> World
doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements $ _gWorld gw) doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)
doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld doAfterPlacement :: [(Placement,Int)] -> World -> World
doAfterPlacement pmntis gw = gRandify gw $ do doAfterPlacement pmntis gw = gRandify gw $ do
(pmnt,i) <- takeOne pmntis (pmnt,i) <- takeOne pmntis
let (newgw,rm) = fst $ placeSpot (gw,_genRooms (_gWorld gw) IM.! i) pmnt let (newgw,rm) = fst $ placeSpot (gw,_genRooms ( gw) IM.! i) pmnt
return $ newgw & gWorld . genRooms . ix i .~ rm return $ newgw & genRooms . ix i .~ rm
doInPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld doInPlacements :: ( IM.IntMap [Placement],World) -> World
doInPlacements (im,w) = doInPlacements (im,w) =
let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms $ _gWorld w) let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
in gw & gWorld . genRooms .~ rms in gw & genRooms .~ rms
doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room) doRoomInPlacements :: IM.IntMap [Placement] -> World -> Room -> (World, Room)
doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm
where where
f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i) f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i)
doOutPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld) doOutPlacements :: World -> ( IM.IntMap [Placement], World)
doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms $ _gWorld w) doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w)
in (pmnts,gw & gWorld . genRooms .~ rms) in (pmnts,gw & genRooms .~ rms)
doRoomOutPlacements :: (IM.IntMap [Placement], GenWorld) doRoomOutPlacements :: (IM.IntMap [Placement], World)
-> Room -> Room
-> ( (IM.IntMap [Placement], GenWorld) , Room ) -> ( (IM.IntMap [Placement], World) , Room )
doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r
where where
f (OutPlacement pl i) ( (im,w) , rm ) = f (OutPlacement pl i) ( (im,w) , rm ) =
let ((neww,newrm),plmnts) = placeSpot (w,rm) pl let ((neww,newrm),plmnts) = placeSpot (w,rm) pl
in ((IM.insert i plmnts im, neww) , newrm ) in ((IM.insert i plmnts im, neww) , newrm )
doIndividualPlacements :: GenWorld -> GenWorld doIndividualPlacements :: World -> World
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms $ _gWorld gw) doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
in gw' & gWorld . genRooms .~ rms in gw' & genRooms .~ rms
doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room) doRoomPlacements :: World -> Room -> (World, Room)
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
setupWorldBounds :: World -> World setupWorldBounds :: World -> World
@@ -236,8 +235,8 @@ gameRoomFromRoom rm = GameRoom
floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift) floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)
floorsFromGenWorld :: GenWorld -> [(Point3,Point3)] floorsFromGenWorld :: World -> [(Point3,Point3)]
floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms . _gWorld floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms
getTiles :: Floor -> [Tile] getTiles :: Floor -> [Tile]
getTiles fl = case fl of getTiles fl = case fl of
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -22,7 +22,7 @@ generateWorldFromSeed :: Int -> IO World
generateWorldFromSeed i = do generateWorldFromSeed i = do
writeFile "attemptedSeeds" "" writeFile "attemptedSeeds" ""
(roomList,bounds) <- layoutLevelFromSeed 0 i (roomList,bounds) <- layoutLevelFromSeed 0 i
return $ saveLevelStartSlot $ _gWorld (generateLevelFromRoomList roomList return $ saveLevelStartSlot $ (generateLevelFromRoomList roomList
initialWorld{_randGen=mkStdGen i}) initialWorld{_randGen=mkStdGen i})
& roomClipping .~ bounds & roomClipping .~ bounds
src/Dodge/LevelGen/LevelStructure.hs
+2 -4
View File
@@ -18,13 +18,11 @@ import qualified Data.Map.Strict as M
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
worldToGenWorld :: IM.IntMap Room -> World -> GenWorld worldToGenWorld :: IM.IntMap Room -> World -> World
worldToGenWorld rms w = GenWorld worldToGenWorld rms w = w & genParams .~ gparams
{ _gWorld = w & genParams .~ gparams
& genRooms .~ rms & genRooms .~ rms
-- , _gPlacements = IM.empty -- , _gPlacements = IM.empty
-- , _gRooms = rms -- , _gRooms = rms
}
where where
gparams = evalState generateGenParams (_randGen w) gparams = evalState generateGenParams (_randGen w)
src/Dodge/Placement/Instance/Sensor.hs
+1 -1
View File
@@ -24,7 +24,7 @@ damageSensor
damageSensor dt wdth upf ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) damageSensor dt wdth upf ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
$ \lsid -> Just $ spNoID ps $ PutUsingGenParams $ \lsid -> Just $ spNoID ps $ PutUsingGenParams
$ \gw -> (,) gw $ PutMachine yellow (reverse $ square wdth) defaultMachine $ \gw -> (,) gw $ PutMachine yellow (reverse $ square wdth) defaultMachine
{ _mcDraw = sensorSPic wdth $ _sensorCoding (_genParams $ _gWorld gw) M.! dt { _mcDraw = sensorSPic wdth $ _sensorCoding (_genParams gw) M.! dt
, _mcUpdate = \mc -> upf mc . sensorUpdate dt mc , _mcUpdate = \mc -> upf mc . sensorUpdate dt mc
, _mcSensor = SensorToggleAmount False 0 , _mcSensor = SensorToggleAmount False 0
, _mcLSs = [lsid] , _mcLSs = [lsid]
src/Dodge/Placement/PlaceSpot.hs
+35 -35
View File
@@ -31,10 +31,10 @@ import Data.Bifunctor
-- when placing a placement, we update the world and the room and assign an id -- when placing a placement, we update the world and the room and assign an id
-- to the placement -- to the placement
placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] ) placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of placeSpot (w,rm) plmnt = case plmnt of
pl@Placement{_plGenUpdate = Just f} -> let (gp,pl') = f (_genParams $ _gWorld w) pl pl@Placement{_plGenUpdate = Just f} -> let (gp,pl') = f (_genParams w) pl
in placeSpot (w & gWorld . genParams .~ gp,rm) pl' in placeSpot (w & genParams .~ gp,rm) pl'
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
Placement{} -> placePlainPSSpot w rm plmnt shift Placement{} -> placePlainPSSpot w rm plmnt shift
@@ -44,15 +44,15 @@ placeSpot (w,rm) plmnt = case plmnt of
where where
shift = _rmShift rm shift = _rmShift rm
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld placePickOne :: Int -> Placement -> Room -> World -> World
placePickOne i pl rm w = w & gWorld . genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))] placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement]) placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement])
placeRandomPlacement rplmnt w rm = placeSpot (w & gWorld . randGen .~ g,rm) plmnt' placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt'
where where
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w) (plmnt', g) = runState rplmnt (_randGen w)
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement]) placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Placement])
placePlainPSSpot w rm plmnt shift = placePlainPSSpot w rm plmnt shift =
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i newplmnt = plmnt & plMID ?~ i
@@ -62,13 +62,13 @@ placePlainPSSpot w rm plmnt shift =
in (wr,newplmnt:newplmnts) in (wr,newplmnt:newplmnts)
-- this should be tidied up -- this should be tidied up
placeSpotUsingLink :: GenWorld placeSpotUsingLink :: World
-> Room -> Room
-> Placement -> Placement
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Room) -> (RoomPos -> Room -> Room)
-> Maybe Placement -> Maybe Placement
-> ((GenWorld, Room), [Placement]) -> ((World, Room), [Placement])
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of 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) Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
Nothing -> case fallback of Nothing -> case fallback of
@@ -81,13 +81,13 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
Just (ps,rmpos) -> Just ( ps,rmpos:poss) Just (ps,rmpos) -> Just ( ps,rmpos:poss)
placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
-> Placement -> GenWorld -> ((GenWorld,Room),[Placement]) -> Placement -> World -> ((World,Room),[Placement])
placeSpotRoomRand rm i f plmnt w = placeSpotRoomRand rm i f plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w) let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps) in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps)
-- the Int here is some id that is assigned when the placement is placed -- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of placeSpotID ps pt w = case pt of
PutTrigger cnd -> plNewID triggers cnd w PutTrigger cnd -> plNewID triggers cnd w
PutMod mdi -> plNewUpID modifications mdID mdi w PutMod mdi -> plNewUpID modifications mdID mdi w
@@ -110,7 +110,7 @@ placeSpotID ps pt w = case pt of
PutShape sh -> placeShape sh p rot w PutShape sh -> placeShape sh p rot w
PutNothing -> (0,w) PutNothing -> (0,w)
PutID i -> (i, w) PutID i -> (i, w)
PutWorldUpdate f -> (0,w & gWorld %~ f ps) PutWorldUpdate f -> (0,w & f ps)
PutUsingGenParams f -> let (w',pt') = f w PutUsingGenParams f -> let (w',pt') = f w
in placeSpotID ps pt' w' in placeSpotID ps pt' w'
where where
@@ -119,17 +119,17 @@ placeSpotID ps pt w = case pt of
rot = _psRot ps rot = _psRot ps
doShift = shiftPointBy (p,rot) doShift = shiftPointBy (p,rot)
placeShape :: Shape -> Point2 -> Float -> GenWorld -> (Int, GenWorld) placeShape :: Shape -> Point2 -> Float -> World -> (Int, World)
placeShape sh p rot w = placeShape sh p rot w =
(0, w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) (0, w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int,GenWorld) evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w) evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
where where
(evaluatedType, g) = runState rgen (_randGen $ _gWorld w) (evaluatedType, g) = runState rgen (_randGen w)
placeWallPoly :: [Point2] -> Wall -> GenWorld -> GenWorld placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly ps wl = gWorld %~ (rmCrossPaths . over walls (addWalls ps wl)) placeWallPoly ps wl = (rmCrossPaths . over walls (addWalls ps wl))
where where
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
@@ -148,21 +148,21 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
-- new index as well -- new index as well
plNewID :: ALens' World (IM.IntMap a) plNewID :: ALens' World (IM.IntMap a)
-> a -> a
-> GenWorld -> World
-> (Int,GenWorld) -> (Int,World)
plNewID l x w = (i,w & gWorld . l #%~ IM.insert i x) plNewID l x w = (i,w & l #%~ IM.insert i x)
where where
i = IM.newKey $ _gWorld w ^# l i = IM.newKey $ w ^# l
-- | place an new object into an intmap and update its id -- | place an new object into an intmap and update its id
plNewUpID :: ALens' World (IM.IntMap a) plNewUpID :: ALens' World (IM.IntMap a)
-> ALens' a Int -> ALens' a Int
-> a -> a
-> GenWorld -> World
-> (Int,GenWorld) -> (Int,World)
plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i)) plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
where where
i = IM.newKey $ _gWorld w ^# l i = IM.newKey $ w ^# l
mvProp :: Point2 -> Float -> Prop -> Prop mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
@@ -180,13 +180,13 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
mvCr :: Point2 -> Float -> Creature -> Creature mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot} mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
plMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int,GenWorld) plMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
plMachine color wallpoly mc p rot gw = (mcid plMachine color wallpoly mc p rot gw = (mcid
, gw & gWorld . machines %~ addMc , gw & machines %~ addMc
& gWorld . walls %~ placeMachineWalls color wallpoly mcid wlid & walls %~ placeMachineWalls color wallpoly mcid wlid
) )
where where
w' = _gWorld gw w' = gw
mcid = IM.newKey $ _machines w' mcid = IM.newKey $ _machines w'
wlid = IM.newKey $ _walls w' wlid = IM.newKey $ _walls w'
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
src/Dodge/Placement/PlaceSpot/Block.hs
+8 -10
View File
@@ -54,11 +54,10 @@ addBlock (p:ps) wl hp hps bm w
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> GenWorld -> (Int,GenWorld) placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> World -> (Int,World)
placeBlock poly i wl is bm gw placeBlock poly i wl is bm w
= (0, gw & gWorld .~ foldr (uncurry removePathsCrossing) wWithBlock pairs) = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
where where
w = _gWorld gw
pairs = loopPairs poly pairs = loopPairs poly
wWithBlock = addBlock poly wl i is bm w wWithBlock = addBlock poly wl i is bm w
@@ -70,13 +69,12 @@ placeLineBlock
-> Float -- ^ Block depth -> Float -- ^ Block depth
-> Point2 -- ^ Start point (symmetric) -> Point2 -- ^ Start point (symmetric)
-> Point2 -- ^ End point (symmetric) -> Point2 -- ^ End point (symmetric)
-> GenWorld -> World
-> (Int, GenWorld) -> (Int, World)
placeLineBlock basePane bm blockWidth depth a b gw = ( 0 placeLineBlock basePane bm blockWidth depth a b gw = ( 0
, gw & gWorld .~ removePathsCrossing a b (foldr insertWall (insertBlocks w) listWalls) , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
) )
where where
w = _gWorld gw
psOnLine = divideLineOddNumPoints blockWidth a b psOnLine = divideLineOddNumPoints blockWidth a b
halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1) halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
blockCenPs = snd $ evenOddSplit psOnLine blockCenPs = snd $ evenOddSplit psOnLine
@@ -85,8 +83,8 @@ placeLineBlock basePane bm blockWidth depth a b gw = ( 0
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
linesAt p = loopPairs $ cornersAt p linesAt p = loopPairs $ cornersAt p
wlid = IM.newKey $ _walls w wlid = IM.newKey $ _walls gw
blid = IM.newKey $ _blocks w blid = IM.newKey $ _blocks gw
insertBlock i = over blocks $ IM.insert (i+blid) Block insertBlock i = over blocks $ IM.insert (i+blid) Block
{ _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
, _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm} , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm}
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+10 -12
View File
@@ -21,12 +21,11 @@ plDoor :: Color
-> (World -> Bool) -- ^ Opening condition -> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ Door positions, closed to open. -> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened -- Bumped out up and down by 9, not widened
-> GenWorld -> World
-> (Int,GenWorld) -> (Int,World)
plDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor)) plDoor col cond pss gw = (drid, (addWalls gw & doors %~ addDoor))
where where
w = _gWorld gw drid = IM.newKey $ _doors gw
drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door addDoor = IM.insert drid $ Door
{ _drID = drid { _drID = drid
, _drWallIDs = IS.fromList wlids , _drWallIDs = IS.fromList wlids
@@ -38,7 +37,7 @@ plDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
, _drClosePos = last pss , _drClosePos = last pss
} }
nsteps = length pss - 1 nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls w ..] wlids = take 4 [IM.newKey $ _walls gw ..]
wlps' = uncurry (rectanglePairs 9) $ head pss wlps' = uncurry (rectanglePairs 9) $ head pss
addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps' addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps'
@@ -106,13 +105,12 @@ plSlideDoor
-> Point2 -> Point2
-> Point2 -> Point2
-> Float -> Float
-> GenWorld -> World
-> (Int, GenWorld) -> (Int, World)
plSlideDoor isPathable col cond shiftOffset a b speed gw plSlideDoor isPathable col cond shiftOffset a b speed gw
= (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor)) = (drid, (addWalls gw & doors %~ addDoor))
where where
w = _gWorld gw drid = IM.newKey $ _doors gw
drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door addDoor = IM.insert drid $ Door
{ _drID = drid { _drID = drid
, _drWallIDs = IS.fromList wlids , _drWallIDs = IS.fromList wlids
@@ -127,7 +125,7 @@ plSlideDoor isPathable col cond shiftOffset a b speed gw
pairs = rectanglePairs 9 a b pairs = rectanglePairs 9 a b
shiftedPairs = map (bimap shiftLeft shiftLeft) pairs shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
wlids = take 4 [IM.newKey $ _walls w ..] wlids = take 4 [IM.newKey $ _walls gw ..]
-- old code that may help with pathing -- old code that may help with pathing
--import Dodge.LevelGen.Pathing --import Dodge.LevelGen.Pathing
--import Data.Graph.Inductive hiding ((&)) --import Data.Graph.Inductive hiding ((&))
src/Dodge/Randify.hs
+3 -3
View File
@@ -6,6 +6,6 @@ import System.Random
import Control.Monad.State import Control.Monad.State
import Control.Lens import Control.Lens
gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld gRandify :: World -> State StdGen World -> World
gRandify gw mw = let (gw',g) = runState mw (_randGen $ _gWorld gw) gRandify gw mw = let (gw',g) = runState mw (_randGen gw)
in gw' & gWorld . randGen .~ g in gw' & randGen .~ g