diff --git a/src/Dodge/Data/GenWorld.hs b/src/Dodge/Data/GenWorld.hs index 5683aab5e..df375b0c5 100644 --- a/src/Dodge/Data/GenWorld.hs +++ b/src/Dodge/Data/GenWorld.hs @@ -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]} diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index 22ac43912..de9d8854c 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/src/Dodge/Placement/Instance/Terminal.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 2f8e99aa0..0e461beb3 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -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}) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index c06ee7d1d..ebe486395 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 4c498e58b..c07036db8 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -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 diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 4c2f3e450..1f4879204 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -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