Remove GenWorld datatype
This commit is contained in:
+1
-6
@@ -1371,7 +1371,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
| PutShape Shape
|
||||
| PutWorldUpdate (PlacementSpot -> World -> World)
|
||||
| PutNothing
|
||||
| PutUsingGenParams (GenWorld -> (GenWorld,PSType))
|
||||
| PutUsingGenParams (World -> (World,PSType))
|
||||
| PutID { _putID :: Int}
|
||||
-- maybe there is a monadic implementation of this?
|
||||
-- add room effect for any placement spot?
|
||||
@@ -1505,10 +1505,6 @@ data RoomPosType
|
||||
| RoomPosLab Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data GenWorld = GenWorld
|
||||
{ _gWorld :: World
|
||||
}
|
||||
|
||||
makeLenses ''CreatureState
|
||||
makeLenses ''Damage
|
||||
makeLenses ''DamageEffect
|
||||
@@ -1588,4 +1584,3 @@ makeLenses ''RoomLink
|
||||
makeLenses ''RoomPos
|
||||
makeLenses ''RoomPosType
|
||||
makeLenses ''RPLinkStatus
|
||||
makeLenses ''GenWorld
|
||||
|
||||
+34
-35
@@ -36,10 +36,10 @@ import Data.Maybe
|
||||
import Data.Function
|
||||
import Control.Monad.State
|
||||
|
||||
generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld
|
||||
generateLevelFromRoomList gr' w = over gWorld initWallZoning
|
||||
. over gWorld randomCompass
|
||||
. over gWorld setupWorldBounds
|
||||
generateLevelFromRoomList :: IM.IntMap Room -> World -> World
|
||||
generateLevelFromRoomList gr' w = initWallZoning
|
||||
. randomCompass
|
||||
. setupWorldBounds
|
||||
. placeWires
|
||||
. doAfterPlacements
|
||||
. doInPlacements
|
||||
@@ -61,26 +61,26 @@ generateLevelFromRoomList gr' w = over gWorld initWallZoning
|
||||
randomCompass :: World -> World
|
||||
randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
|
||||
|
||||
putFloorTiles :: GenWorld -> GenWorld
|
||||
putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw
|
||||
putFloorTiles :: World -> World
|
||||
putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw
|
||||
|
||||
setFloors :: GenWorld -> GenWorld
|
||||
setFloors :: World -> World
|
||||
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 :: GenWorld -> GenWorld
|
||||
setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms $ _gWorld gw
|
||||
setTiles :: World -> World
|
||||
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
|
||||
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
|
||||
t = case _rmMParent r of
|
||||
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
|
||||
|
||||
shuffleRoomPos :: RandomGen g => Room -> State g Room
|
||||
@@ -88,9 +88,8 @@ shuffleRoomPos rm = do
|
||||
newPos <- shuffle $ _rmPos rm
|
||||
return $ rm & rmPos .~ newPos
|
||||
|
||||
placeWires :: GenWorld -> GenWorld
|
||||
placeWires w = w
|
||||
& gWorld .~ foldr placeRoomWires (_gWorld w) (_genRooms $ _gWorld w)
|
||||
placeWires :: World -> World
|
||||
placeWires w = foldr placeRoomWires ( w) (_genRooms w)
|
||||
|
||||
placeRoomWires :: Room -> World -> World
|
||||
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
|
||||
rs = _rmShift rm
|
||||
|
||||
doAfterPlacements :: GenWorld -> GenWorld
|
||||
doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements $ _gWorld gw)
|
||||
doAfterPlacements :: World -> World
|
||||
doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)
|
||||
|
||||
doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld
|
||||
doAfterPlacement :: [(Placement,Int)] -> World -> World
|
||||
doAfterPlacement pmntis gw = gRandify gw $ do
|
||||
(pmnt,i) <- takeOne pmntis
|
||||
let (newgw,rm) = fst $ placeSpot (gw,_genRooms (_gWorld gw) IM.! i) pmnt
|
||||
return $ newgw & gWorld . genRooms . ix i .~ rm
|
||||
let (newgw,rm) = fst $ placeSpot (gw,_genRooms ( gw) IM.! i) pmnt
|
||||
return $ newgw & genRooms . ix i .~ rm
|
||||
|
||||
doInPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
|
||||
doInPlacements :: ( IM.IntMap [Placement],World) -> World
|
||||
doInPlacements (im,w) =
|
||||
let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms $ _gWorld w)
|
||||
in gw & gWorld . genRooms .~ rms
|
||||
let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
|
||||
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
|
||||
where
|
||||
f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i)
|
||||
|
||||
doOutPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld)
|
||||
doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms $ _gWorld w)
|
||||
in (pmnts,gw & gWorld . genRooms .~ rms)
|
||||
doOutPlacements :: World -> ( IM.IntMap [Placement], World)
|
||||
doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w)
|
||||
in (pmnts,gw & genRooms .~ rms)
|
||||
|
||||
doRoomOutPlacements :: (IM.IntMap [Placement], GenWorld)
|
||||
doRoomOutPlacements :: (IM.IntMap [Placement], World)
|
||||
-> Room
|
||||
-> ( (IM.IntMap [Placement], GenWorld) , Room )
|
||||
-> ( (IM.IntMap [Placement], World) , 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 :: GenWorld -> GenWorld
|
||||
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms $ _gWorld gw)
|
||||
in gw' & gWorld . genRooms .~ rms
|
||||
doIndividualPlacements :: World -> World
|
||||
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
|
||||
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
|
||||
|
||||
setupWorldBounds :: World -> World
|
||||
@@ -236,8 +235,8 @@ gameRoomFromRoom rm = GameRoom
|
||||
floorsFromRooms :: [Room] -> [(Point3,Point3)]
|
||||
floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)
|
||||
|
||||
floorsFromGenWorld :: GenWorld -> [(Point3,Point3)]
|
||||
floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms . _gWorld
|
||||
floorsFromGenWorld :: World -> [(Point3,Point3)]
|
||||
floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms
|
||||
|
||||
getTiles :: Floor -> [Tile]
|
||||
getTiles fl = case fl of
|
||||
|
||||
@@ -22,7 +22,7 @@ generateWorldFromSeed :: Int -> IO World
|
||||
generateWorldFromSeed i = do
|
||||
writeFile "attemptedSeeds" ""
|
||||
(roomList,bounds) <- layoutLevelFromSeed 0 i
|
||||
return $ saveLevelStartSlot $ _gWorld (generateLevelFromRoomList roomList
|
||||
return $ saveLevelStartSlot $ (generateLevelFromRoomList roomList
|
||||
initialWorld{_randGen=mkStdGen i})
|
||||
& roomClipping .~ bounds
|
||||
|
||||
|
||||
@@ -18,13 +18,11 @@ import qualified Data.Map.Strict as M
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
|
||||
worldToGenWorld :: IM.IntMap Room -> World -> GenWorld
|
||||
worldToGenWorld rms w = GenWorld
|
||||
{ _gWorld = w & genParams .~ gparams
|
||||
worldToGenWorld :: IM.IntMap Room -> World -> World
|
||||
worldToGenWorld rms w = w & genParams .~ gparams
|
||||
& genRooms .~ rms
|
||||
-- , _gPlacements = IM.empty
|
||||
-- , _gRooms = rms
|
||||
}
|
||||
where
|
||||
gparams = evalState generateGenParams (_randGen w)
|
||||
|
||||
|
||||
@@ -24,7 +24,7 @@ damageSensor
|
||||
damageSensor dt wdth upf ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
|
||||
$ \lsid -> Just $ spNoID ps $ PutUsingGenParams
|
||||
$ \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
|
||||
, _mcSensor = SensorToggleAmount False 0
|
||||
, _mcLSs = [lsid]
|
||||
|
||||
@@ -31,10 +31,10 @@ import Data.Bifunctor
|
||||
|
||||
-- when placing a placement, we update the world and the room and assign an id
|
||||
-- to the placement
|
||||
placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
|
||||
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
pl@Placement{_plGenUpdate = Just f} -> let (gp,pl') = f (_genParams $ _gWorld w) pl
|
||||
in placeSpot (w & gWorld . genParams .~ gp,rm) pl'
|
||||
pl@Placement{_plGenUpdate = Just f} -> let (gp,pl') = f (_genParams w) pl
|
||||
in placeSpot (w & genParams .~ gp,rm) pl'
|
||||
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{} -> placePlainPSSpot w rm plmnt shift
|
||||
@@ -44,15 +44,15 @@ placeSpot (w,rm) plmnt = case plmnt of
|
||||
where
|
||||
shift = _rmShift rm
|
||||
|
||||
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
|
||||
placePickOne i pl rm w = w & gWorld . genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
|
||||
placePickOne :: Int -> Placement -> Room -> World -> World
|
||||
placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
|
||||
|
||||
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement])
|
||||
placeRandomPlacement rplmnt w rm = placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
|
||||
placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement])
|
||||
placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt'
|
||||
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 =
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
newplmnt = plmnt & plMID ?~ i
|
||||
@@ -62,13 +62,13 @@ placePlainPSSpot w rm plmnt shift =
|
||||
in (wr,newplmnt:newplmnts)
|
||||
|
||||
-- this should be tidied up
|
||||
placeSpotUsingLink :: GenWorld
|
||||
placeSpotUsingLink :: World
|
||||
-> Room
|
||||
-> Placement
|
||||
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
-> (RoomPos -> Room -> Room)
|
||||
-> Maybe Placement
|
||||
-> ((GenWorld, Room), [Placement])
|
||||
-> ((World, 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
|
||||
@@ -81,13 +81,13 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
|
||||
Just (ps,rmpos) -> Just ( ps,rmpos:poss)
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
|
||||
-> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
|
||||
-> Placement -> World -> ((World,Room),[Placement])
|
||||
placeSpotRoomRand rm i f plmnt w =
|
||||
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w)
|
||||
in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)
|
||||
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
|
||||
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps)
|
||||
|
||||
-- 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
|
||||
PutTrigger cnd -> plNewID triggers cnd 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
|
||||
PutNothing -> (0,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
|
||||
in placeSpotID ps pt' w'
|
||||
where
|
||||
@@ -119,17 +119,17 @@ placeSpotID ps pt w = case pt of
|
||||
rot = _psRot ps
|
||||
doShift = shiftPointBy (p,rot)
|
||||
|
||||
placeShape :: Shape -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
|
||||
placeShape :: Shape -> Point2 -> Float -> World -> (Int, World)
|
||||
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 rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w)
|
||||
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
|
||||
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen $ _gWorld w)
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
|
||||
placeWallPoly :: [Point2] -> Wall -> GenWorld -> GenWorld
|
||||
placeWallPoly ps wl = gWorld %~ (rmCrossPaths . over walls (addWalls ps wl))
|
||||
placeWallPoly :: [Point2] -> Wall -> World -> World
|
||||
placeWallPoly ps wl = (rmCrossPaths . over walls (addWalls ps wl))
|
||||
where
|
||||
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
|
||||
plNewID :: ALens' World (IM.IntMap a)
|
||||
-> a
|
||||
-> GenWorld
|
||||
-> (Int,GenWorld)
|
||||
plNewID l x w = (i,w & gWorld . l #%~ IM.insert i x)
|
||||
-> World
|
||||
-> (Int,World)
|
||||
plNewID l x w = (i,w & l #%~ IM.insert i x)
|
||||
where
|
||||
i = IM.newKey $ _gWorld w ^# l
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
-- | place an new object into an intmap and update its id
|
||||
plNewUpID :: ALens' World (IM.IntMap a)
|
||||
-> ALens' a Int
|
||||
-> a
|
||||
-> GenWorld
|
||||
-> (Int,GenWorld)
|
||||
plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i))
|
||||
-> World
|
||||
-> (Int,World)
|
||||
plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
|
||||
where
|
||||
i = IM.newKey $ _gWorld w ^# l
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
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 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
|
||||
, gw & gWorld . machines %~ addMc
|
||||
& gWorld . walls %~ placeMachineWalls color wallpoly mcid wlid
|
||||
, gw & machines %~ addMc
|
||||
& walls %~ placeMachineWalls color wallpoly mcid wlid
|
||||
)
|
||||
where
|
||||
w' = _gWorld gw
|
||||
w' = gw
|
||||
mcid = IM.newKey $ _machines w'
|
||||
wlid = IM.newKey $ _walls w'
|
||||
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
||||
|
||||
@@ -54,11 +54,10 @@ addBlock (p:ps) wl hp hps bm w
|
||||
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
|
||||
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
|
||||
|
||||
placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> GenWorld -> (Int,GenWorld)
|
||||
placeBlock poly i wl is bm gw
|
||||
= (0, gw & gWorld .~ foldr (uncurry removePathsCrossing) wWithBlock pairs)
|
||||
placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> World -> (Int,World)
|
||||
placeBlock poly i wl is bm w
|
||||
= (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
|
||||
where
|
||||
w = _gWorld gw
|
||||
pairs = loopPairs poly
|
||||
wWithBlock = addBlock poly wl i is bm w
|
||||
|
||||
@@ -70,13 +69,12 @@ placeLineBlock
|
||||
-> Float -- ^ Block depth
|
||||
-> Point2 -- ^ Start point (symmetric)
|
||||
-> Point2 -- ^ End point (symmetric)
|
||||
-> GenWorld
|
||||
-> (Int, GenWorld)
|
||||
-> World
|
||||
-> (Int, World)
|
||||
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
|
||||
w = _gWorld gw
|
||||
psOnLine = divideLineOddNumPoints blockWidth a b
|
||||
halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
|
||||
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
|
||||
cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
|
||||
linesAt p = loopPairs $ cornersAt p
|
||||
wlid = IM.newKey $ _walls w
|
||||
blid = IM.newKey $ _blocks w
|
||||
wlid = IM.newKey $ _walls gw
|
||||
blid = IM.newKey $ _blocks gw
|
||||
insertBlock i = over blocks $ IM.insert (i+blid) Block
|
||||
{ _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
|
||||
, _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm}
|
||||
|
||||
@@ -21,12 +21,11 @@ plDoor :: Color
|
||||
-> (World -> Bool) -- ^ Opening condition
|
||||
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
|
||||
-- Bumped out up and down by 9, not widened
|
||||
-> GenWorld
|
||||
-> (Int,GenWorld)
|
||||
plDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
|
||||
-> World
|
||||
-> (Int,World)
|
||||
plDoor col cond pss gw = (drid, (addWalls gw & doors %~ addDoor))
|
||||
where
|
||||
w = _gWorld gw
|
||||
drid = IM.newKey $ _doors w
|
||||
drid = IM.newKey $ _doors gw
|
||||
addDoor = IM.insert drid $ Door
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
@@ -38,7 +37,7 @@ plDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
|
||||
, _drClosePos = last pss
|
||||
}
|
||||
nsteps = length pss - 1
|
||||
wlids = take 4 [IM.newKey $ _walls w ..]
|
||||
wlids = take 4 [IM.newKey $ _walls gw ..]
|
||||
wlps' = uncurry (rectanglePairs 9) $ head pss
|
||||
addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps'
|
||||
|
||||
@@ -106,13 +105,12 @@ plSlideDoor
|
||||
-> Point2
|
||||
-> Point2
|
||||
-> Float
|
||||
-> GenWorld
|
||||
-> (Int, GenWorld)
|
||||
-> World
|
||||
-> (Int, World)
|
||||
plSlideDoor isPathable col cond shiftOffset a b speed gw
|
||||
= (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
|
||||
= (drid, (addWalls gw & doors %~ addDoor))
|
||||
where
|
||||
w = _gWorld gw
|
||||
drid = IM.newKey $ _doors w
|
||||
drid = IM.newKey $ _doors gw
|
||||
addDoor = IM.insert drid $ Door
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
@@ -127,7 +125,7 @@ plSlideDoor isPathable col cond shiftOffset a b speed gw
|
||||
pairs = rectanglePairs 9 a b
|
||||
shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
|
||||
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
|
||||
--import Dodge.LevelGen.Pathing
|
||||
--import Data.Graph.Inductive hiding ((&))
|
||||
|
||||
@@ -6,6 +6,6 @@ import System.Random
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
|
||||
gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld
|
||||
gRandify gw mw = let (gw',g) = runState mw (_randGen $ _gWorld gw)
|
||||
in gw' & gWorld . randGen .~ g
|
||||
gRandify :: World -> State StdGen World -> World
|
||||
gRandify gw mw = let (gw',g) = runState mw (_randGen gw)
|
||||
in gw' & randGen .~ g
|
||||
|
||||
Reference in New Issue
Block a user