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

Allow for placements to use/update the full GenWorld

Browse Source
This commit is contained in:
justin
2025-09-23 10:41:09 +01:00
parent 5ee78ceffc
commit a9ecd7de2e
6 changed files with 65 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/GenWorld.hs
+1 -1
View File
@@ -56,7 +56,7 @@ data PSType
| PutDoor Color EdgeObstacle WdBl [(Point2, Point2)] | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)]
| RandPS (State StdGen PSType) | RandPS (State StdGen PSType)
| PutForeground ForegroundShape | PutForeground ForegroundShape
| PutWorldUpdate (PlacementSpot -> World -> World) | PutWorldUpdate (PlacementSpot -> GenWorld -> GenWorld)
| PutNothing | PutNothing
| PutID {_putID :: Int} | PutID {_putID :: Int}
| PutChasm {_putChasmPoly :: [Point2]} | PutChasm {_putChasmPoly :: [Point2]}
src/Dodge/Placement/Instance/Terminal.hs
+2 -2
View File
@@ -17,7 +17,7 @@ import LensHelp
putTerminalImediateAccess :: Color -> Machine -> Terminal -> Placement putTerminalImediateAccess :: Color -> Machine -> Terminal -> Placement
putTerminalImediateAccess = putTerminalFull f putTerminalImediateAccess = putTerminalFull f
where where
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ accessTerminal (tmpl ^?! plMID . _Just) f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ over gwWorld $ accessTerminal (tmpl ^?! plMID . _Just)
putTerminalFull :: putTerminalFull ::
(Placement -> Placement -> Placement -> Maybe Placement) -> (Placement -> Placement -> Placement -> Maybe Placement) ->
@@ -39,7 +39,7 @@ putTerminalFull f col mc tm =
defaultSensorWall defaultSensorWall
Nothing Nothing
) )
$ \mcpl -> Just $ pt0 (PutWorldUpdate $ const (setids tmpl btpl mcpl)) (\_ -> f tmpl btpl mcpl) $ \mcpl -> Just $ pt0 (PutWorldUpdate $ const $ over gwWorld $ (setids tmpl btpl mcpl)) (\_ -> f tmpl btpl mcpl)
where where
setids tmpl btpl mcpl w = setids tmpl btpl mcpl w =
w w
src/Dodge/Placement/PlaceSpot.hs
+38 -37
View File
@@ -78,38 +78,38 @@ placeSpotRoomRand rm i f plmnt w =
let (ps, g) = runState (_rmRandPSs rm !! i) $ w ^. gwWorld . randGen let (ps, g) = runState (_rmRandPSs rm !! i) $ w ^. gwWorld . randGen
in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps) in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps)
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) --placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt gw = --placeSpotID ps pt gw =
let (i, w) = placeSpotID' ps pt (_gwWorld gw) -- let (i, w) = placeSpotID' ps pt (_gwWorld gw)
in (i, gw & gwWorld .~ w) -- in (i, gw & gwWorld .~ w)
-- 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 -> World -> (Int, World) placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID' ps pt w = case pt of placeSpotID ps pt w = case pt of
PutTrigger cnd -> plNewID (cWorld . lWorld . triggers) cnd w PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w
PutMod mdi -> plNewUpID (cWorld . lWorld . modifications) mdID mdi w PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w PutButton bt -> plNewUpID (gwWorld . cWorld . lWorld . buttons) btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
PutFlIt itm -> PutFlIt itm ->
let i = IM.newKey (w ^. cWorld . lWorld . items) let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
in ( i in ( i
, w , w
& cWorld . lWorld . floorItems . at i ?~ FlIt p rot & gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
& cWorld . lWorld . items . at i & gwWorld . cWorld . lWorld . items . at i
?~ ( itm & itID .~ NInt i ?~ ( itm & itID .~ NInt i
& itLocation .~ OnFloor & itLocation .~ OnFloor
) )
) )
PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID PutForeground fs -> plNewUpID (gwWorld . cWorld . lWorld . foregroundShapes) fsID
(mvFS p rot fs) w (mvFS p rot fs) w
PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
PutLS ls -> plNewUpID (cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID (cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w PutPPlate pp -> plNewUpID (gwWorld . cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
RandPS rgn -> evaluateRandPS rgn ps w RandPS rgn -> evaluateRandPS rgn ps w
PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
PutCoord cp -> plNewID coordinates (doShift cp) w PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
PutSlideDr wl dr eo off a b -> PutSlideDr wl dr eo off a b ->
plSlideDoor wl dr eo off (doShift a) (doShift b) w plSlideDoor wl dr eo off (doShift a) (doShift b) w
PutBlock bl wl ps' -> PutBlock bl wl ps' ->
@@ -119,21 +119,21 @@ placeSpotID' ps pt w = case pt of
wl wl
w w
PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
PutWall qs wl -> (0, placeWallPoly (map doShift qs) wl w) PutWall qs wl -> (0, over gwWorld (placeWallPoly (map doShift qs) wl) w)
PutNothing -> (0, w) PutNothing -> (0, w)
PutID i -> (i, w) PutID i -> (i, w)
PutWorldUpdate f -> (0, w & f ps) PutWorldUpdate f -> (0, w & f ps)
PutChasm ps' -> (0, w & cWorld . chasms .:~ map doShift ps') PutChasm ps' -> (0, w & gwWorld . cWorld . chasms .:~ map doShift ps')
where where
p@(V2 px py) = _psPos ps p@(V2 px py) = _psPos ps
p' = V3 px py 0 p' = V3 px py 0
rot = _psRot ps rot = _psRot ps
doShift = shiftPointBy (p, rot) doShift = shiftPointBy (p, rot)
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int, World) evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w) evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gwWorld . randGen) g w)
where where
(evaluatedType, g) = runState rgen (_randGen w) (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w)
-- this function is the reason for the warning suppression -- this function is the reason for the warning suppression
-- remove the warning suppression if it changes -- remove the warning suppression if it changes
@@ -164,26 +164,27 @@ mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a)) mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
plMachine :: plMachine ::
[Point2] -> Machine -> Wall -> Maybe Item -> Point2 -> Float -> World -> (Int, World) [Point2] -> Machine -> Wall -> Maybe Item -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
plMachine wallpoly mc wl = \case plMachine wallpoly mc wl = \case
Nothing -> plMachine' wallpoly mc wl Nothing -> plMachine' wallpoly mc wl
Just itm -> plTurret wallpoly mc wl itm Just itm -> plTurret wallpoly mc wl itm
plTurret :: [Point2] -> Machine -> Wall -> Item -> Point2 -> Float -> World -> (Int, World) plTurret :: [Point2] -> Machine -> Wall -> Item -> Point2 -> Float -> GenWorld
-> (Int, GenWorld)
plTurret wallpoly mc wl itm p rot gw = plTurret wallpoly mc wl itm p rot gw =
( mcid ( mcid
, gw & cWorld . lWorld . machines %~ addMc , gw & gwWorld . cWorld . lWorld . machines %~ addMc
& cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
& cWorld . lWorld . items . at itid ?~ itm' & gwWorld . cWorld . lWorld . items . at itid ?~ itm'
) )
where where
itm' = itm' =
itm & itID .~ NInt itid itm & itID .~ NInt itid
& itLocation .~ OnTurret mcid & itLocation .~ OnTurret mcid
itid = IM.newKey $ gw ^. cWorld . lWorld . items itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
col = _mcColor mc col = _mcColor mc
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. cWorld . lWorld . walls wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
addMc = addMc =
IM.insert IM.insert
@@ -192,16 +193,16 @@ plTurret wallpoly mc wl itm p rot gw =
& mcType . mctTurret . tuWeapon .~ itid & mcType . mctTurret . tuWeapon .~ itid
) )
plMachine' :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int, World) plMachine' :: [Point2] -> Machine -> Wall -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
plMachine' wallpoly mc wl p rot gw = plMachine' wallpoly mc wl p rot gw =
( mcid ( mcid
, gw & cWorld . lWorld . machines %~ addMc , gw & gwWorld . cWorld . lWorld . machines %~ addMc
& cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
) )
where where
col = _mcColor mc col = _mcColor mc
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. cWorld . lWorld . walls wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}) addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids})
src/Dodge/Placement/PlaceSpot/Block.hs
+12 -12
View File
@@ -10,7 +10,7 @@ import Control.Lens
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Data.List import Data.List
import Dodge.Base import Dodge.Base
import Dodge.Data.World import Dodge.Data.GenWorld
import Dodge.Path import Dodge.Path
import Geometry import Geometry
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
@@ -21,24 +21,24 @@ plBlock ::
Block -> Block ->
-- | Base Pane -- | Base Pane
Wall -> Wall ->
World -> GenWorld ->
(Int, World) (Int, GenWorld)
plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
plBlock (p : ps) bl wl w = plBlock (p : ps) bl wl w =
(,) blid $ (,) blid $
w w
& cWorld . lWorld . blocks . at blid & gwWorld . cWorld . lWorld . blocks . at blid
?~ bl ?~ bl
{ _blID = blid { _blID = blid
, _blWallIDs = IS.fromList is , _blWallIDs = IS.fromList is
, _blShadows = [] , _blShadows = []
, _blFootprint = p : ps , _blFootprint = p : ps
} }
& insertWalls blid wls & gwWorld %~ insertWalls blid wls
where where
blid = IM.newKey $ w ^. cWorld . lWorld . blocks blid = IM.newKey $ w ^. gwWorld . cWorld . lWorld . blocks
lns = zip (p : ps) (ps ++ [p]) lns = zip (p : ps) (ps ++ [p])
i = IM.newKey $ w ^. cWorld . lWorld . walls i = IM.newKey $ w ^. gwWorld . cWorld . lWorld . walls
is = [i .. i + length lns -1] is = [i .. i + length lns -1]
wls = wls =
zipWith zipWith
@@ -55,12 +55,12 @@ plLineBlock ::
Point2 -> Point2 ->
-- | End point (symmetric) -- | End point (symmetric)
Point2 -> Point2 ->
World -> GenWorld ->
(Int, World) (Int, GenWorld)
plLineBlock basePane blwidth a b gw = plLineBlock basePane blwidth a b gw =
( 0 ( 0
, -- , foldr insertWall (insertBlocks gw) listWalls , -- , foldr insertWall (insertBlocks gw) listWalls
insertBlocks gw over gwWorld insertBlocks gw
) )
where where
depth = blwidth depth = blwidth
@@ -72,8 +72,8 @@ plLineBlock basePane blwidth a b gw =
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 $ gw ^. cWorld . lWorld . walls wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
blid = IM.newKey $ gw ^. cWorld . lWorld . blocks blid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . blocks
insertBlock (i, p) = insertBlock (i, p) =
insertWalls (i + blid) (makeWallAt p i) insertWalls (i + blid) (makeWallAt p i)
. over . over
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+11 -11
View File
@@ -4,12 +4,12 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
maybeClearDoorPaths, maybeClearDoorPaths,
) where ) where
import Dodge.Data.GenWorld
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Graph.Inductive as FGL import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Data.List import Data.List
import Dodge.Base import Dodge.Base
import Dodge.Data.World
import Dodge.Default.Door import Dodge.Default.Door
import Dodge.LevelGen.DoorPane import Dodge.LevelGen.DoorPane
import Dodge.Path import Dodge.Path
@@ -27,11 +27,11 @@ plDoor ::
-- | Door positions, closed to open. -- | Door positions, closed to open.
-- Bumped out up and down by 9, not widened -- Bumped out up and down by 9, not widened
[(Point2, Point2)] -> [(Point2, Point2)] ->
World -> GenWorld ->
(Int, World) (Int, GenWorld)
plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls plDoor col eo cond pss gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
where where
drid = IM.newKey $ _doors (_lWorld (_cWorld gw)) drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
addDoor = addDoor =
IM.insert drid $ IM.insert drid $
defaultDoor defaultDoor
@@ -46,7 +46,7 @@ plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . lWorld . doors %~ ad
, _drObstacleType = eo , _drObstacleType = eo
} }
nsteps = length pss - 1 nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld gw)) ..] wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..]
wlps' = uncurry (rectanglePairs 9) $ head pss wlps' = uncurry (rectanglePairs 9) $ head pss
addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps' addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps'
@@ -82,12 +82,12 @@ plSlideDoor ::
Float -> Float ->
Point2 -> Point2 ->
Point2 -> Point2 ->
World -> GenWorld ->
(Int, World) (Int, GenWorld)
plSlideDoor dr wl eo shiftOffset a b gw = plSlideDoor dr wl eo shiftOffset a b gw =
(drid, addDoorWalls $ gw & cWorld . lWorld . doors %~ addDoor) (drid, over gwWorld addDoorWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor)
where where
drid = IM.newKey $ _doors (_lWorld (_cWorld gw)) drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
addDoor = addDoor =
IM.insert drid $ IM.insert drid $
dr dr
@@ -103,7 +103,7 @@ plSlideDoor dr wl eo shiftOffset a b gw =
addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs
pairs = rectanglePairs 9 a b pairs = rectanglePairs 9 a b
shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld gw)) ..] wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..]
-- old code that may help with pathing -- old code that may help with pathing
--import Dodge.LevelGen.Pathing --import Dodge.LevelGen.Pathing
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -120,7 +120,7 @@ addButtonSlowDoor x h rm = do
(aShape (V2 15 0) (V3 15 xoff 90)) (aShape (V2 15 0) (V3 15 xoff 90))
$ \plls plpr -> $ \plls plpr ->
Just $ Just $
ptCont (PutWorldUpdate (const $ setmount dr plls plpr)) $ ptCont (PutWorldUpdate (const $ over gwWorld $ setmount dr plls plpr)) $
const mpl const mpl
setmount pldr plls plpr = setmount pldr plls plpr =
cWorld . lWorld . doors . ix (fromJust $ _plMID pldr) . drMounts cWorld . lWorld . doors . ix (fromJust $ _plMID pldr) . drMounts