From 024f72da2096ec45fbcdb0a376be7980faec588a Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 2 Jun 2022 20:00:03 +0100 Subject: [PATCH] Remove _plGenUpdate field, instead allow Placements to take World arg --- src/Dodge/Data.hs | 4 +- src/Dodge/Floor.hs | 2 + src/Dodge/Layout.hs | 6 +-- src/Dodge/LevelGen.hs | 4 +- src/Dodge/LevelGen/Data.hs | 54 +++++++++++--------- src/Dodge/Placement/Instance/LightSource.hs | 4 +- src/Dodge/Placement/Instance/Terminal.hs | 9 ++-- src/Dodge/Placement/PlaceSpot.hs | 6 +-- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 4 +- src/Dodge/Placement/Shift.hs | 2 +- src/Dodge/PlacementSpot.hs | 8 +-- src/Dodge/Room/RezBox.hs | 2 +- src/Dodge/Terminal.hs | 2 +- 13 files changed, 54 insertions(+), 53 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 697487d6c..e6847a7be 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1393,8 +1393,8 @@ data Placement { _plSpot :: PlacementSpot , _plType :: PSType , _plMID :: Maybe Int - , _plGenUpdate :: Maybe (GenParams -> Placement -> (GenParams, Placement) ) - , _plIDCont :: Placement -> Maybe Placement +-- , _plGenUpdate :: Maybe (GenParams -> Placement -> (GenParams, Placement) ) + , _plIDCont :: World -> Placement -> Maybe Placement } | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position | RandomPlacement {_unRandomPlacement :: State StdGen Placement} diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index e6a11c63d..0f47c655c 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -27,6 +27,7 @@ import Dodge.Data --import MonadHelp import Data.Tree import LensHelp +import Dodge.RandomHelp --import Color --import Dodge.Wire @@ -49,6 +50,7 @@ initialAnoTree = padSucWithDoors $ treeFromPost , TreeSubLabelling "chaseCrit+armourChaseCrit rectRoom" Nothing) ] -- , [AnoApplyInt 100 healthTest] + , [PassthroughLockKeyLists 23 [(sensorRoomRunPast Electrical, takeOne [STATICMODULE,SPARKGUN] )] itemRooms] , [SpecificRoom ((return . UseAll <$> tanksRoom [] []) <&> (, TreeSubLabelling "empty tanksRoom" Nothing))] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 964765211..d8f539d7c 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -71,7 +71,7 @@ setFloors = putFloorTiles . setTiles -- hence the reverse -- this is not ideal: should do this in some more sensible way setTiles :: World -> World -setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms $ gw +setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw setTile :: Room -> World -> World setTile r gw = case _rmFloor r of @@ -89,7 +89,7 @@ shuffleRoomPos rm = do return $ rm & rmPos .~ newPos placeWires :: World -> World -placeWires w = foldr placeRoomWires ( w) (_genRooms w) +placeWires w = foldr placeRoomWires w (_genRooms w) placeRoomWires :: Room -> World -> World placeRoomWires rm w = IM.foldr ($) w @@ -123,7 +123,7 @@ doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw) doAfterPlacement :: [(Placement,Int)] -> World -> World doAfterPlacement pmntis gw = gRandify gw $ do (pmnt,i) <- takeOne pmntis - let (newgw,rm) = fst $ placeSpot (gw,_genRooms ( gw) IM.! i) pmnt + let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt return $ newgw & genRooms . ix i .~ rm doInPlacements :: ( IM.IntMap [Placement],World) -> World diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 17af67d28..85dd48a90 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -22,8 +22,8 @@ generateWorldFromSeed :: Int -> IO World generateWorldFromSeed i = do writeFile "attemptedSeeds" "" (roomList,bounds) <- layoutLevelFromSeed 0 i - return $ saveLevelStartSlot $ (generateLevelFromRoomList roomList - initialWorld{_randGen=mkStdGen i}) + return $ saveLevelStartSlot + $ generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i} & roomClipping .~ bounds layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly]) diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index a7adaedbd..37129a852 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +--{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.LevelGen.Data where import Dodge.Data @@ -20,28 +20,28 @@ import Data.Maybe spNoID :: PlacementSpot -> PSType -> Placement -spNoID ps pst = Placement ps pst Nothing Nothing (const Nothing) +spNoID ps pst = Placement ps pst Nothing (const . const Nothing) pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement -pContID ps pt = Placement ps pt Nothing Nothing . contToIDCont +pContID ps pt = Placement ps pt Nothing . contToIDCont psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement -psPtCont ps pt = Placement ps pt Nothing Nothing +psPtCont ps pt = Placement ps pt Nothing . const psPt :: PlacementSpot -> PSType -> Placement -psPt ps pt = Placement ps pt Nothing Nothing (const Nothing) +psPt ps pt = Placement ps pt Nothing (const . const Nothing) sPS :: Point2 -> Float -> PSType -> Placement -sPS p a pt = Placement (PS p a) pt Nothing Nothing (const Nothing) +sPS p a pt = Placement (PS p a) pt Nothing (const . const Nothing) sps :: PlacementSpot -> PSType -> Placement -sps ps pt = Placement ps pt Nothing Nothing (const Nothing) +sps ps pt = Placement ps pt Nothing (const . const Nothing) plRRpt :: Int -> PSType -> Placement -plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing Nothing (const Nothing) +plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const . const Nothing) jsps :: Point2 -> Float -> PSType -> Maybe Placement -jsps p a pst = Just $ Placement (PS p a) pst Nothing Nothing $ const Nothing +jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const . const Nothing jsps0 :: PSType -> Maybe Placement jsps0 = Just . sPS (V2 0 0) 0 @@ -50,48 +50,52 @@ sps0 :: PSType -> Placement sps0 = sPS (V2 0 0) 0 jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement -jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing Nothing $ \_ -> Just plm +jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ _ -> Just plm jsps0J :: PSType -> Placement -> Maybe Placement -jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing Nothing $ \_ -> Just plm +jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ _ -> Just plm ps0 :: PSType -> (Int -> Maybe Placement) -> Placement -ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing . contToIDCont +ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement -pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing +pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing . const -contToIDCont :: (Int -> Maybe Placement) -> Placement -> Maybe Placement -contToIDCont f = f . fromJust . _plMID +contToIDCont :: (Int -> Maybe Placement) -> World -> Placement -> Maybe Placement +contToIDCont f _ = f . fromJust . _plMID jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement -jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing Nothing +jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . const jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement -jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing - $ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt +jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing + $ \_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt ps0j :: PSType -> Placement -> Placement -ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing Nothing (const $ Just plmnt) +ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt) psj :: PlacementSpot -> PSType -> Placement -> Placement -psj ps pst plmnt = Placement ps pst Nothing Nothing (const $ Just plmnt) +psj ps pst plmnt = Placement ps pst Nothing (\_ -> const $ Just plmnt) -- the NoShiftCont is necessary when shifting then combining rooms ps0jPushPS :: PSType -> Placement -> Placement -ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing - $ \p -> Just $ plmnt & plSpot .~ _plSpot p +ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing + $ \_ p -> Just $ plmnt & plSpot .~ _plSpot p -- the NoShiftCont is necessary when shifting then combining rooms ps0PushPS :: PSType -> (Placement -> Maybe Placement) -> Placement -ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing - $ \pl -> f pl & _Just . plSpot %~ const (_plSpot pl) +ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing + $ \_ pl -> f pl & _Just . plSpot %~ const (_plSpot pl) + +ps0PushPSw :: PSType -> (World -> Placement -> Maybe Placement) -> Placement +ps0PushPSw pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing + $ \w pl -> f w pl & _Just . plSpot %~ const (_plSpot pl) addPlmnt :: Placement -> Placement -> Placement addPlmnt pl pl2 = case pl2 of (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f) (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp - (Placement ps pt mi up f) -> Placement ps pt mi up (fmap g f) + (Placement ps pt mi f) -> Placement ps pt mi (fmap (fmap g) f) PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet" where g Nothing = Just pl diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index bb9f9b42d..132fe4a8b 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -149,8 +149,8 @@ spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) V2 x y = 0.5 *.* (a +.+ b) spanLS :: LightSource -> Point2 -> Point2 -> Placement -spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing Nothing - $ const $ Just $ sps0 $ PutShape $ thinHighBar h a b +spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing + $ const $ const $ Just $ sps0 $ PutShape $ thinHighBar h a b where V3 _ _ h = _lsPos (_lsParam ls) + 5 V2 x y = 0.5 *.* (a +.+ b) diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index 6a8ba25dd..4a0d56c73 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/src/Dodge/Placement/Instance/Terminal.hs @@ -35,7 +35,9 @@ putTerminal' col mcf = ps0PushPS (PutButton termButton) $ const Nothing putTerminal :: (GenParams -> World -> TerminalParams) -> Placement -putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton termButton) +putTerminal f = ps0PushPSw PutNothing $ \w _ -> Just $ + --plGenUpdate ?~ g $ ps0PushPS (PutButton $ termButton & btTerminalParams .~ f (_genParams w)) + ps0PushPS (PutButton $ termButton & btTerminalParams .~ f (_genParams w)) $ \pl -> Just $ pt0 (PutMachine terminalColor (reverse $ square 10) defaultMachine { _mcDraw = noPic . terminalShape terminalColor , _mcHP = 100 @@ -44,11 +46,6 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton termButton) . makeExplosionAt (_mcPos mc) }) $ const Nothing - where - g gp pl = (gp, - pl & plType . putButton . btTerminalParams .~ f gp - & plGenUpdate .~ Nothing - ) termButton :: Button termButton = Button { _btPict = const mempty diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 1b9137f86..8da22d60a 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -33,8 +33,6 @@ import Data.Bifunctor -- to the 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 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 @@ -56,7 +54,7 @@ placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Plac placePlainPSSpot w rm plmnt shift = let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w newplmnt = plmnt & plMID ?~ i - in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt) + in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt) where recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl in (wr,newplmnt:newplmnts) @@ -129,7 +127,7 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) (evaluatedType, g) = runState rgen (_randGen w) placeWallPoly :: [Point2] -> Wall -> World -> World -placeWallPoly ps wl = (rmCrossPaths . over walls (addWalls ps wl)) +placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl) where rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 92d00027b..580a30f91 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -23,7 +23,7 @@ plDoor :: Color -- Bumped out up and down by 9, not widened -> World -> (Int,World) -plDoor col cond pss gw = (drid, (addWalls gw & doors %~ addDoor)) +plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor) where drid = IM.newKey $ _doors gw addDoor = IM.insert drid $ Door @@ -108,7 +108,7 @@ plSlideDoor -> World -> (Int, World) plSlideDoor isPathable col cond shiftOffset a b speed gw - = (drid, (addWalls gw & doors %~ addDoor)) + = (drid, addWalls gw & doors %~ addDoor) where drid = IM.newKey $ _doors gw addDoor = IM.insert drid $ Door diff --git a/src/Dodge/Placement/Shift.hs b/src/Dodge/Placement/Shift.hs index 084870bbd..8252362e8 100644 --- a/src/Dodge/Placement/Shift.hs +++ b/src/Dodge/Placement/Shift.hs @@ -20,7 +20,7 @@ shiftPlacement shift plmnt = case plmnt of -- slightly messy NoShiftCont, necessary to stop interference with ps0jPushPS Placement {_plSpot = PSNoShiftCont {}} -> plmnt & plSpot %~ shiftPSBy shift Placement {} -> plmnt & plSpot %~ shiftPSBy shift - & plIDCont %~ fmap (fmap $ shiftPlacement shift) + & plIDCont %~ fmap (fmap (fmap $ shiftPlacement shift)) PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p) (fmap (shiftPlacement shift) f) RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 2b5ef484c..b2830a7a2 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -101,7 +101,7 @@ unusedSpotAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink setFallback :: Placement -> Placement -> Placement setFallback fallback = (plSpot . psFallback %~ maybe (Just fallback) Just) - . (plIDCont %~ fmap (fmap $ setFallback fallback) + . (plIDCont %~ fmap (fmap (fmap $ setFallback fallback)) ) unusedOffPathAwayFromLink :: Float -> PlacementSpot @@ -122,9 +122,9 @@ twoRoomPoss :: (RoomPos -> Room -> Bool) -> (RoomPos -> Room -> Bool) -> (PlacementSpot -> PlacementSpot -> Placement) -> Placement -twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing Nothing - $ \pl1 -> Just $ Placement (rprBool cond2) PutNothing Nothing Nothing - $ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2) +twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing + $ \_ pl1 -> Just $ Placement (rprBool cond2) PutNothing Nothing + $ \_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2) --isUnusedLnk :: RoomPos -> Bool --isUnusedLnk rp = case _rpLinkStatus rp of diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index aaca00daa..8b9da4ea6 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -124,4 +124,4 @@ wpAdd wp = rmPmnts %~ f where f (x:xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs f _ = [sPS (V2 15 30) 1 (PutFlIt wp)] - g x = x & plIDCont .~ flickerMod + g x = x & plIDCont .~ const flickerMod diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index 089685793..fa0a346b5 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -131,7 +131,7 @@ doTerminalEffect' s w = fromMaybe (w & badinput) $ do where badinput = hud . hudElement . subInventory . termParams %~ ( (termInput ?~ T.empty) - . (termFutureLines ++.~ [makeColorTermLine red ("^ INVALID INPUT") + . (termFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ] ) )