Remove _plGenUpdate field, instead allow Placements to take World arg
This commit is contained in:
+2
-2
@@ -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}
|
||||
|
||||
@@ -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]
|
||||
|
||||
+3
-3
@@ -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
|
||||
|
||||
@@ -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])
|
||||
|
||||
+29
-25
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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"
|
||||
]
|
||||
)
|
||||
)
|
||||
|
||||
Reference in New Issue
Block a user