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

Use placement as continutation

Browse Source
This commit is contained in:
justin
2021-11-13 09:26:20 +00:00
parent b243479759
commit 17c1a2152d
8 changed files with 35 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+3 -3
View File
@@ -55,7 +55,7 @@ doPartialPlacement im rm w = case _rmPartialPmnt rm of
Nothing -> w
Just fi -> case _rmTakeFrom rm of
Nothing -> w
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
Just i -> fst $ fst $ placeSpot (w,rm) (fi (im IM.! i))
doExtendedPlacements :: [Room] -> World -> (IM.IntMap Int, World)
doExtendedPlacements rms w = foldr doExtendedPlacement (IM.empty,w) rms
@@ -65,10 +65,10 @@ doExtendedPlacement rm (im,w) = case _rmExtendedPmnt rm of
Nothing -> (im,w)
Just _ -> case _rmLabel rm of
Nothing -> (im,w)
Just _ -> undefined
Just i -> undefined
doRoomPlacements :: World -> Room -> World
doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPmnts rm
doRoomPlacements w rm = fst $ foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
setupWorldBounds :: World -> World
setupWorldBounds w = w
src/Dodge/LevelGen.hs
+12 -5
View File
@@ -28,13 +28,20 @@ import Control.Monad.State
import Control.Lens
import qualified Data.IntSet as IS
placeSpot :: (World,Room) -> Placement -> (World,Room)
-- when placing a placement, we update the world and the room and assign an id
-- to the placement
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement])
placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
Placement{_plSpot = PSLnk{}} -> placeSpotUsingLink w rm plmnt
Placement{} ->
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i)
newplmnt = plmnt & plMID .~ Just i
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
where
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
in (wr,newplmnt:newplmnts)
-- (placeSpot (w',rm)) (_plIDCont plmnt i)
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
where
@@ -42,11 +49,11 @@ placeSpot (w,rm) plmnt = case plmnt of
where
shift = _rmShift rm
placeSpotUsingLink :: World -> Room -> Placement -> (World, Room)
placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement])
placeSpotUsingLink w rm plmnt = case lnks of
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
[] -> case fallback of
Nothing -> (w,rm)
Nothing -> ((w,rm),[plmnt])
Just plmnt' -> placeSpot (w,rm) plmnt'
where
uselnk lnki = rm & rmLinks %~ deletei lnki
@@ -61,7 +68,7 @@ placeSpotUsingLink w rm plmnt = case lnks of
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room)
placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
placeSpotRoomRand rm i plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
src/Dodge/LevelGen/Data.hs
+11 -4
View File
@@ -9,6 +9,7 @@ import Shape.Data
import Control.Lens
import Control.Monad.State
import System.Random
import Data.Maybe
data PSType = PutCrit {_unPutCrit :: Creature}
| PutMachine Color [Point2] Machine
| PutLS LightSource
@@ -39,8 +40,8 @@ data PlacementSpot
data Placement = Placement
{ _plSpot :: PlacementSpot
, _plType :: PSType
, _plID :: Maybe Int
, _plIDCont :: Int -> Maybe Placement
, _plMID :: Maybe Int
, _plIDCont :: Placement -> Maybe Placement
}
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
@@ -48,6 +49,9 @@ data Placement = Placement
spNoID :: PlacementSpot -> PSType -> Placement
spNoID ps pst = Placement ps pst Nothing (const Nothing)
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
pContID ps pt = Placement ps pt Nothing . intPlPlPl
sPS :: Point2 -> Float -> PSType -> Placement
sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
@@ -67,10 +71,13 @@ jsps0J :: PSType -> Placement -> Maybe Placement
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
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
intPlPlPl :: (Int -> Maybe Placement) -> Placement -> (Maybe Placement)
intPlPlPl f = f . fromJust . _plMID
jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
ps0j :: PSType -> Placement -> Placement
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)
src/Dodge/Placements/Door.hs
+1 -1
View File
@@ -31,7 +31,7 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
switchDoor btpos btrot dra drb col = Placement (PS btpos btrot) (PutButton $ makeSwitch col red id id) Nothing
switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
where
src/Dodge/Placements/Sensor.hs
+1 -1
View File
@@ -15,7 +15,7 @@ import Data.Either
damageSensor
:: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
-> Point2 -> Float -> Placement
damageSensor damF p r = Placement (PS p r) ( PutLS theLS) Nothing
damageSensor damF p r = pContID (PS p r) ( PutLS theLS)
$ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine
{ _mcDraw = sensorSPic
, _mcUpdate = sensorUpdate damF
src/Dodge/Room/Airlock.hs
+5 -5
View File
@@ -27,7 +27,7 @@ airlock0 = defaultRoom
, _rmLinks = lnks
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPmnts =
[Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) Nothing
[pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
$ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
$ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
,spanLightI (V2 (-2) 30) (V2 (-2) 70)
@@ -49,7 +49,7 @@ airlockSimple = defaultRoom
, _rmLinks = lnks
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) Nothing
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps)
]
@@ -78,7 +78,7 @@ airlockZ = defaultRoom
-- ,(V2 40 0,V2 0 40)
-- ]
, _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) Nothing
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps)
, sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall
@@ -118,7 +118,7 @@ airlock90 = defaultRoom
,(V2 40 0,V2 0 40)
]
, _rmPmnts =
[ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) Nothing
[pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
,mountLightV (V2 20 20) (V3 70 70 50)
]
@@ -146,7 +146,7 @@ airlockCrystal = defaultRoom
, _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ]
, _rmPath = [ ]
, _rmPmnts =
[ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) Nothing
[pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss
, crystalLine (V2 0 70) (V2 40 70)
, mountLightV (V2 150 70) (V3 110 70 70)
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -39,7 +39,7 @@ twinSlowDoorRoom w h x = defaultRoom
]
, _rmPath = []
, _rmPmnts =
[ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) Nothing
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
$ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
src/Dodge/Room/Procedural.hs
+1 -1
View File
@@ -237,7 +237,7 @@ centerVaultRoom w h d = do
where
col = dim $ dim $ bright red
theDoor =
[ Placement (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) Nothing
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2)
]