diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index fee8a273c..2fc225cd4 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -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 diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index ffc2e8e6b..3dfcdc8a7 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -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 diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index ac699782c..06995ab21 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 6676b4203..f03d50054 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 1cb33f5bd..7c9ad2377 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -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 diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 3dfb9d95c..68961caab 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -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) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index c4448c22b..69edfdbe5 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index ab4936499..60df1c808 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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