Implement moving mounted lights
This commit is contained in:
@@ -28,7 +28,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
| PutTrigger (World -> Bool)
|
||||
| PutLineBlock Wall BlockMaterial Float Float Point2 Point2
|
||||
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
|
||||
| PutSlideDr Bool Color (World -> Bool) Point2 Point2 Float
|
||||
| PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
|
||||
| PutDoor Color (World -> Bool) [(Point2,Point2)]
|
||||
| RandPS (State StdGen PSType)
|
||||
| PutShape Shape
|
||||
|
||||
@@ -16,16 +16,18 @@ import qualified Data.IntMap.Strict as IM
|
||||
|
||||
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
|
||||
putDoubleDoor pathing col cond a b speed
|
||||
= putDoubleDoorThen pathing col cond a b speed (const $ const Nothing)
|
||||
= putDoubleDoorThen pathing col cond 1 a b speed (const $ const Nothing)
|
||||
|
||||
putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
|
||||
-> Point2 -> Point2 -> Float
|
||||
-> Float -> Point2 -> Point2 -> Float
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
putDoubleDoorThen pathing col cond a b speed cont = pt0 (PutSlideDr pathing col cond a half speed)
|
||||
$ \pl1 -> Just $ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing
|
||||
putDoubleDoorThen pathing col cond soff a b speed cont
|
||||
= doorbetween a half
|
||||
$ \pl1 -> Just $ doorbetween b half
|
||||
$ \pl2 -> cont pl1 pl2
|
||||
where
|
||||
doorbetween pa pb = pt0 $ PutSlideDr pathing col cond soff pa pb speed
|
||||
half = 0.5 *.* (a +.+ b)
|
||||
|
||||
putAutoDoor :: Point2 -> Point2 -> Placement
|
||||
@@ -39,8 +41,9 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
|
||||
|
||||
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
|
||||
switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
|
||||
$ \btid -> jsps0J (PutSlideDr False col (cond btid) dra drc 2)
|
||||
$ sps0 (PutSlideDr False col (cond btid) drb drc 2)
|
||||
$ \btid -> jsps0J (doorbetween btid dra drc)
|
||||
$ sps0 (doorbetween btid drb drc)
|
||||
where
|
||||
doorbetween btid a b = PutSlideDr False col (cond btid) 1 a b 2
|
||||
drc = 0.5 *.* (dra +.+ drb)
|
||||
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
|
||||
|
||||
@@ -11,8 +11,44 @@ import Dodge.Default
|
||||
import Dodge.RandomHelp
|
||||
import Color
|
||||
import Shape
|
||||
import ShapePicture
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
|
||||
propLSThen :: (Prop -> World -> World)
|
||||
-> (Prop -> World -> LightSource -> LightSource)
|
||||
-> LightSource
|
||||
-> Prop
|
||||
-> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
|
||||
-> Placement
|
||||
propLSThen propf lsf ls prop cont = pt0 (PutLS $ ls)
|
||||
$ \lspl -> Just $ pt0 (PutProp $ prop & pjUpdate .~ theupdate (fromJust $ _plMID lspl))
|
||||
$ cont lspl
|
||||
where
|
||||
theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
|
||||
|
||||
moveLSThen :: (World -> (Point2,Float))
|
||||
-> Point3 -- ^ light source offset
|
||||
-> Shape
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
|
||||
where
|
||||
propupdate pr w = w
|
||||
& props . ix (_pjID pr) . pjPos .~ fst (posf w)
|
||||
& props . ix (_pjID pr) . pjRot .~ snd (posf w)
|
||||
lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
thels = defaultLS
|
||||
theprop = ShapeProp
|
||||
{ _pjPos = 0
|
||||
, _pjID = 0
|
||||
, _pjRot = 0
|
||||
, _pjUpdate = const id
|
||||
, _prDraw = \pr -> noPic $ uncurryV translateSHf (_pjPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
|
||||
-- | mount a light source on a shape
|
||||
mntLSOn
|
||||
|
||||
@@ -99,8 +99,8 @@ placeSpotID ps pt w = case pt of
|
||||
RandPS rgn -> evaluateRandPS rgn ps w
|
||||
PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w
|
||||
PutCoord cp -> plNewID coordinates (doShift cp) w
|
||||
PutSlideDr pth col f a b spd
|
||||
-> plSlideDoor pth col f (doShift a) (doShift b) spd w
|
||||
PutSlideDr pth col f off a b spd
|
||||
-> plSlideDoor pth col f off (doShift a) (doShift b) spd w
|
||||
PutBlock bm hp hps wl ps'
|
||||
-> placeBlock (map doShift ps') hp wl hps bm w
|
||||
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
|
||||
|
||||
@@ -98,9 +98,18 @@ doorMechanism drid speed wlidOpCps dr w
|
||||
doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
|
||||
|
||||
-- TODO cut pathing if not pathable, reset when opened
|
||||
plSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld
|
||||
plSlideDoor
|
||||
:: Bool
|
||||
-> Color
|
||||
-> (World -> Bool)
|
||||
-> Float
|
||||
-> Point2
|
||||
-> Point2
|
||||
-> Float
|
||||
-> GenWorld
|
||||
-> (Int, GenWorld)
|
||||
plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
|
||||
plSlideDoor isPathable col cond shiftOffset a b speed gw
|
||||
= (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
|
||||
where
|
||||
w = _gWorld gw
|
||||
drid = IM.newKey $ _doors w
|
||||
@@ -117,7 +126,7 @@ plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w
|
||||
addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs
|
||||
pairs = rectanglePairs 9 a b
|
||||
shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
|
||||
shiftLeft = (+.+ (a -.- b +.+ normalizeV (b -.- a)))
|
||||
shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
|
||||
wlids = take 4 [IM.newKey $ _walls w ..]
|
||||
-- old code that may help with pathing
|
||||
--import Dodge.LevelGen.Pathing
|
||||
|
||||
@@ -28,7 +28,7 @@ airlock0 = defaultRoom
|
||||
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
|
||||
, _rmPmnts =
|
||||
[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
|
||||
$ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) 1 (V2 (-1) 20) (V2 41 20) 2
|
||||
$ \_ _ -> Just $ putDoubleDoor False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2
|
||||
,spanLightI (V2 (-2) 30) (V2 (-2) 70)
|
||||
,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
|
||||
|
||||
@@ -22,11 +22,13 @@ import Dodge.LightSource
|
||||
import Picture
|
||||
import Geometry
|
||||
import LensHelp
|
||||
--import Shape
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Data.Tree
|
||||
import System.Random
|
||||
import Control.Monad.State
|
||||
import Data.Maybe
|
||||
--import Data.Tree
|
||||
import qualified Data.IntMap as IM
|
||||
|
||||
@@ -44,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom
|
||||
, _rmPath = []
|
||||
, _rmPmnts =
|
||||
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
|
||||
$ \btid -> jsps0J (PutSlideDr False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
|
||||
$ ps0 (PutSlideDr False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
|
||||
$ \btid -> jsps0J (PutSlideDr False col (cond' btid) 1 (V2 x 1) (V2 x h) wlSpeed)
|
||||
$ ps0 (PutSlideDr False col (cond' btid) 1 (V2 (-x) 1) (V2 (-x) h) wlSpeed)
|
||||
$ \did -> jps0 (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight)))
|
||||
$ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
|
||||
]
|
||||
@@ -117,8 +119,18 @@ addButtonSlowDoor x h rm = do
|
||||
belowH y = (sndV2 . fst) y < h - 40
|
||||
aboveH y = (sndV2 . fst) y > h + 40
|
||||
butDoor _ _ = putLitButOnPos col butPosCond
|
||||
$ \btid -> Just $ putDoubleDoorThen False col (cond' btid) (V2 0 h) (V2 x h) 2
|
||||
$ \dr1 dr2 -> Nothing
|
||||
$ \btid -> Just $ putDoubleDoorThen False col (cond' btid) 30 (V2 0 h) (V2 x h) 2
|
||||
$ \dr1 dr2 -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr1))
|
||||
(V3 15 50 88) (aShape (V2 15 0) (V3 15 50 90))
|
||||
$ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr2))
|
||||
(V3 15 (-50) 88) (aShape (V2 15 0) (V3 15 (-50) 90))
|
||||
$ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr2))
|
||||
(V3 15 50 88) (aShape (V2 15 0) (V3 15 50 90))
|
||||
$ \_ _ -> Just $ moveLSThen (getdoorpos (fromJust $ _plMID dr1))
|
||||
(V3 15 (-50) 88) (aShape (V2 15 0) (V3 15 (-50) 90))
|
||||
$ \_ _ ->Nothing
|
||||
getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
|
||||
in (b, argV (a-.-b))
|
||||
butPosCond (UnusedLink (V2 x' y') a' _) _ | y' < 0.5 * h
|
||||
= Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink))
|
||||
butPosCond _ _ = Nothing
|
||||
@@ -139,10 +151,9 @@ slowDoorRoom = do
|
||||
xs' <- replicateM 5 $ state $ randomR (10,x-10)
|
||||
ys' <- replicateM 5 $ state $ randomR (h+20,y)
|
||||
let crits = zipWith (\p r -> sPS p r randC1) ps rs
|
||||
lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
|
||||
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
|
||||
proom <- southPillarsRoom x y h
|
||||
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources)))
|
||||
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
|
||||
|
||||
slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room)
|
||||
slowDoorRoomRunPast = do
|
||||
|
||||
@@ -254,7 +254,7 @@ centerVaultRoom w h d = do
|
||||
col = dim $ dim $ bright red
|
||||
theDoor =
|
||||
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
|
||||
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
|
||||
$ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 21 0) (V2 0 0) 2)
|
||||
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 (-21) 0) (V2 0 0) 2)
|
||||
$ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 21 0) (V2 0 0) 2)
|
||||
]
|
||||
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
|
||||
|
||||
Reference in New Issue
Block a user