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)]
| RandPS (State StdGen PSType)
| PutForeground ForegroundShape
| PutWorldUpdate (PlacementSpot -> World -> World)
| PutWorldUpdate (PlacementSpot -> GenWorld -> GenWorld)
| PutNothing
| PutID {_putID :: Int}
| 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 = putTerminalFull f
where
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ accessTerminal (tmpl ^?! plMID . _Just)
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ over gwWorld $ accessTerminal (tmpl ^?! plMID . _Just)
putTerminalFull ::
(Placement -> Placement -> Placement -> Maybe Placement) ->
@@ -39,7 +39,7 @@ putTerminalFull f col mc tm =
defaultSensorWall
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
setids tmpl btpl mcpl 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
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)
--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
PutTrigger cnd -> plNewID (cWorld . lWorld . triggers) cnd w
PutMod mdi -> plNewUpID (cWorld . lWorld . modifications) mdID mdi w
PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w
PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt w = case pt of
PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w
PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
PutButton bt -> plNewUpID (gwWorld . cWorld . lWorld . buttons) btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
PutFlIt itm ->
let i = IM.newKey (w ^. cWorld . lWorld . items)
let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
in ( i
, w
& cWorld . lWorld . floorItems . at i ?~ FlIt p rot
& cWorld . lWorld . items . at i
& gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
& gwWorld . cWorld . lWorld . items . at i
?~ ( itm & itID .~ NInt i
& itLocation .~ OnFloor
)
)
PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID
PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID (gwWorld . cWorld . lWorld . foregroundShapes) fsID
(mvFS p rot fs) 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
PutPPlate pp -> plNewUpID (cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID (gwWorld . cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
RandPS rgn -> evaluateRandPS rgn ps 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 ->
plSlideDoor wl dr eo off (doShift a) (doShift b) w
PutBlock bl wl ps' ->
@@ -119,21 +119,21 @@ placeSpotID' ps pt w = case pt of
wl
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)
PutID i -> (i, w)
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
p@(V2 px py) = _psPos ps
p' = V3 px py 0
rot = _psRot ps
doShift = shiftPointBy (p, rot)
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int, World)
evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w)
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gwWorld . randGen) g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
(evaluatedType, g) = runState rgen (_randGen $ _gwWorld w)
-- this function is the reason for the warning suppression
-- 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))
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
Nothing -> plMachine' wallpoly mc wl
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 =
( mcid
, gw & cWorld . lWorld . machines %~ addMc
& cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
& cWorld . lWorld . items . at itid ?~ itm'
, gw & gwWorld . cWorld . lWorld . machines %~ addMc
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
& gwWorld . cWorld . lWorld . items . at itid ?~ itm'
)
where
itm' =
itm & itID .~ NInt itid
& itLocation .~ OnTurret mcid
itid = IM.newKey $ gw ^. cWorld . lWorld . items
itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
col = _mcColor mc
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. cWorld . lWorld . walls
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
addMc =
IM.insert
@@ -192,16 +193,16 @@ plTurret wallpoly mc wl itm p rot gw =
& 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 =
( mcid
, gw & cWorld . lWorld . machines %~ addMc
& cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
, gw & gwWorld . cWorld . lWorld . machines %~ addMc
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
)
where
col = _mcColor mc
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. cWorld . lWorld . walls
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
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 Data.List
import Dodge.Base
import Dodge.Data.World
import Dodge.Data.GenWorld
import Dodge.Path
import Geometry
import qualified IntMapHelp as IM
@@ -21,24 +21,24 @@ plBlock ::
Block ->
-- | Base Pane
Wall ->
World ->
(Int, World)
GenWorld ->
(Int, GenWorld)
plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
plBlock (p : ps) bl wl w =
(,) blid $
w
& cWorld . lWorld . blocks . at blid
& gwWorld . cWorld . lWorld . blocks . at blid
?~ bl
{ _blID = blid
, _blWallIDs = IS.fromList is
, _blShadows = []
, _blFootprint = p : ps
}
& insertWalls blid wls
& gwWorld %~ insertWalls blid wls
where
blid = IM.newKey $ w ^. cWorld . lWorld . blocks
blid = IM.newKey $ w ^. gwWorld . cWorld . lWorld . blocks
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]
wls =
zipWith
@@ -55,12 +55,12 @@ plLineBlock ::
Point2 ->
-- | End point (symmetric)
Point2 ->
World ->
(Int, World)
GenWorld ->
(Int, GenWorld)
plLineBlock basePane blwidth a b gw =
( 0
, -- , foldr insertWall (insertBlocks gw) listWalls
insertBlocks gw
over gwWorld insertBlocks gw
)
where
depth = blwidth
@@ -72,8 +72,8 @@ plLineBlock basePane blwidth a b gw =
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 $ gw ^. cWorld . lWorld . walls
blid = IM.newKey $ gw ^. cWorld . lWorld . blocks
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
blid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . blocks
insertBlock (i, p) =
insertWalls (i + blid) (makeWallAt p i)
. over
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+11 -11
View File
@@ -4,12 +4,12 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
maybeClearDoorPaths,
) where
import Dodge.Data.GenWorld
import Data.Set (Set)
import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS
import Data.List
import Dodge.Base
import Dodge.Data.World
import Dodge.Default.Door
import Dodge.LevelGen.DoorPane
import Dodge.Path
@@ -27,11 +27,11 @@ plDoor ::
-- | Door positions, closed to open.
-- Bumped out up and down by 9, not widened
[(Point2, Point2)] ->
World ->
(Int, World)
plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
GenWorld ->
(Int, GenWorld)
plDoor col eo cond pss gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
where
drid = IM.newKey $ _doors (_lWorld (_cWorld gw))
drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
addDoor =
IM.insert drid $
defaultDoor
@@ -46,7 +46,7 @@ plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . lWorld . doors %~ ad
, _drObstacleType = eo
}
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
addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps'
@@ -82,12 +82,12 @@ plSlideDoor ::
Float ->
Point2 ->
Point2 ->
World ->
(Int, World)
GenWorld ->
(Int, GenWorld)
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
drid = IM.newKey $ _doors (_lWorld (_cWorld gw))
drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
addDoor =
IM.insert drid $
dr
@@ -103,7 +103,7 @@ plSlideDoor dr wl eo shiftOffset a b gw =
addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs
pairs = rectanglePairs 9 a b
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
--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))
$ \plls plpr ->
Just $
ptCont (PutWorldUpdate (const $ setmount dr plls plpr)) $
ptCont (PutWorldUpdate (const $ over gwWorld $ setmount dr plls plpr)) $
const mpl
setmount pldr plls plpr =
cWorld . lWorld . doors . ix (fromJust $ _plMID pldr) . drMounts