From f3437adef7c21dbf4eae48c66b26fa4a8679330d Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 29 Sep 2021 01:34:54 +0100 Subject: [PATCH] Working implementation of light change when door opens --- src/Dodge/Data.hs | 1 + src/Dodge/Layout.hs | 2 +- src/Dodge/LevelGen.hs | 70 ++++++++++++++++--------------- src/Dodge/LevelGen/AutoDoor.hs | 5 +-- src/Dodge/LevelGen/Block.hs | 5 ++- src/Dodge/LevelGen/Data.hs | 3 +- src/Dodge/LevelGen/LineBlock.hs | 6 ++- src/Dodge/LevelGen/TriggerDoor.hs | 34 +++++++-------- src/Dodge/LightSources.hs | 7 ++++ src/Dodge/Render/Picture.hs | 1 + src/Dodge/Room/Corridor.hs | 2 +- src/Dodge/Room/LongDoor.hs | 17 +++++--- 12 files changed, 87 insertions(+), 66 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index eae769d4a..451c34535 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -175,6 +175,7 @@ data LightSource = LS , _lsDir :: !Float , _lsRad :: !Float , _lsIntensity :: !Point3 + , _lsPict :: LightSource -> Picture } data TempLightSource = TLS { _tlsPos :: !Point3 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index c92fe7c5d..0aeefbbae 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -43,7 +43,7 @@ generateLevelFromRoomList gr w . setupWorldBounds -- . initializeStaticWalls -- . setupForegroundEdgeVerxs - . flip (foldr placeSpot') plmnts + . flip (foldr $ flip placeSpot') plmnts -- . addRoomPolyDecorations rs -- . addRoomLinkDecorations rs $ w { _walls = wallsFromRooms rs diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 8ecdf0242..31a63828c 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -20,14 +20,15 @@ import Dodge.LevelGen.Data import Geometry import Geometry.Vector3D import Shape -import Picture import qualified IntMapHelp as IM import Control.Monad.State import Control.Lens -placeSpot' :: ((Point2,Float) , Placement) -> World -> World -placeSpot' (shift, plmnt) = placeSpot $ shiftPSBy' shift (_placementSpot plmnt) +placeSpot' :: World -> ((Point2,Float) , Placement) -> World +placeSpot' w (shift, plmnt) = + let (i,w') = placeSpotID (shiftPSBy' shift (_placementSpot plmnt)) w + in maybe w' (curry (placeSpot' w') shift) (_idPlacement plmnt i) shiftPSBy' :: (Point2,Float) @@ -37,25 +38,25 @@ shiftPSBy' (pos,rot) ps = ps & psPos %~ shiftPointBy (pos,rot) & psRot %~ (+ rot) -placeSpot :: PlacementSpot -> World -> World -placeSpot ps w = case _psType ps of +placeSpotID :: PlacementSpot -> World -> (Int, World) +placeSpotID ps w = case _psType ps of PutProp prop -> placeProp prop p rot w PutButton bt -> placeBt bt p rot w PutFlIt itm -> placeFlIt itm p rot w PutCrit cr -> placeCr cr p rot w - PutLS ls dec -> placeLS ls dec p' rot w + PutLS ls -> placeLS ls p' rot w PutPressPlate pp -> placePressPlate pp p rot w - RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w) + RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w) where (evaluatedType, g) = runState rgen (_randGen w) PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w where mapBoth fn (x,y) = (fn x, fn y) - PutDoubleDoor col f a b speed - -> putDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w PutSingleDoor col f a b speed -> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w - PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + PutDoubleDoor col f a b speed + -> (,) 0 $ insertDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w + PutAutoDoor a b -> (,) 0 $ addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w PutBlock{} -> error "messed up block placement somehow" PutBtDoor c bp f a b speed @@ -63,13 +64,13 @@ placeSpot ps w = case _psType ps of (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w PutLineBlock wl width depth a b -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w - PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w + PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls (q:qs) wl) w) where (q:qs) = map (shiftPointBy (p,rot)) ps' rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q]) - PutForeground sh -> w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>) - PutNothing -> w - PutID _ -> w + PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) + PutNothing -> (0,w) + PutID i -> (i, w) --_ -> w where p@(V2 px py) = _psPos ps @@ -113,15 +114,15 @@ addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl }) wls --- TODO make rotation of props sensible placeProp :: Prop -> Point2 -> Float -- ^ Rotation -> World - -> World -placeProp pr p a = over props addProp + -> (Int, World) +placeProp pr p a w = (i, w & props %~ addProp) where + i = IM.newKey $ _props w addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs placePropID @@ -140,9 +141,10 @@ placeBt -> Point2 -> Float -- ^ Rotation -> World - -> World -placeBt bt p rot = over buttons addBT + -> (Int, World) +placeBt bt p rot w = (i , over buttons addBT w) where + i = IM.newKey $ _buttons w addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts {- Creates a floor item at a given point. Assigns an id correctly. -} @@ -151,25 +153,29 @@ placeFlIt -> Point2 -- ^ Position -> Float -- ^ Rotation -> World - -> World -placeFlIt itm p rot = floorItems %~ - \ fis -> IM.insert (IM.newKey fis) + -> (Int, World) +placeFlIt itm p rot w = (i, w & floorItems %~ + \ fis -> IM.insert i (FlIt { _flItPos = p , _flItRot = rot - , _flItID = IM.newKey fis + , _flItID = i , _flIt = itm } ) fis + ) + where + i = IM.newKey $ _floorItems w placePressPlate :: PressPlate -> Point2 -> Float -- ^ Rotation -> World - -> World -placePressPlate pp p rot = over pressPlates addPP + -> (Int, World) +placePressPlate pp p rot w = (i , over pressPlates addPP w) where + i = IM.newKey $ _pressPlates w addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType) @@ -178,23 +184,21 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr) cid = IM.newKey (_creatures w) cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} -placeCr :: Creature -> Point2 -> Float -> World -> World -placeCr crF p rot = over creatures addCr +placeCr :: Creature -> Point2 -> Float -> World -> (Int,World) +placeCr crF p rot w = (i, over creatures addCr w) where + i = IM.newKey $ _creatures w addCr crs = IM.insert (IM.newKey crs) (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) crs -placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World -placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w +placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World) +placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w) where + i = IM.newKey $ _lightSources w startPos = _lsPos ls addLS lss = IM.insert (IM.newKey lss) (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) lss - addDec decs = IM.insert - (IM.newKey decs) - (translate x y $ rotate (negate rot) dec) - decs diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index 8e55e6617..308a01d7a 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -3,8 +3,7 @@ Creation of doors that open when creatures approach them. -} module Dodge.LevelGen.AutoDoor - ( addAutoDoor - ) where + where import Dodge.Data import Dodge.Base import Dodge.Creature.Property @@ -22,6 +21,6 @@ addAutoDoor -> Point2 -- ^ Right point (though the two points should be symmetric) -> World -> World -addAutoDoor a b = putDoubleDoor True (dim yellow) cond a b 3 +addAutoDoor a b = insertDoubleDoor True (dim yellow) cond a b 3 where cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index de509e262..6c20fd121 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -135,8 +135,9 @@ addBlock (p:ps) hp col isSeeThrough degradability w ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" -putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World -putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs +-- TODO add block list to world +putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World) +putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) where pairs = zip (p:ps) (ps ++ [p]) wWithBlock = addBlock (p:ps) i c b is w diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index c4d37b5b4..a237ab317 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -27,7 +27,7 @@ import Control.Lens import Control.Monad.State import System.Random data PSType = PutCrit {_unPutCrit :: Creature} - | PutLS LightSource Picture + | PutLS LightSource | PutButton Button | PutProp Prop | PutFlIt Item @@ -49,6 +49,7 @@ data PlacementSpot = PS , _psRot :: Float , _psType :: PSType } +-- maybe there is a monadic implementation of this? data Placement = Placement { _placementSpot :: PlacementSpot , _idPlacement :: Int -> Maybe Placement diff --git a/src/Dodge/LevelGen/LineBlock.hs b/src/Dodge/LevelGen/LineBlock.hs index c8049807c..411e72402 100644 --- a/src/Dodge/LevelGen/LineBlock.hs +++ b/src/Dodge/LevelGen/LineBlock.hs @@ -19,8 +19,10 @@ putLineBlock -> Point2 -- ^ Start point (symmetric) -> Point2 -- ^ End point (symmetric) -> World - -> World -putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks + -> (Int, World) +putLineBlock basePane blockWidth depth a b w + = (,) 0 + $ removePathsCrossing a b $ foldr insertBlock w listBlocks where d = dist a b rot = argV (b -.- a) diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index 2fc6a255c..e99b5b9f3 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -1,9 +1,9 @@ --{-# LANGUAGE BangPatterns #-} module Dodge.LevelGen.TriggerDoor ( putDoor - , putDoubleDoor , putSingleDoor , addButtonDoor + , insertDoubleDoor ) where import Dodge.Data import Dodge.Base @@ -25,13 +25,14 @@ import Control.Lens import Data.Graph.Inductive hiding ((&)) -- probably don't have to rebuild the entire graph, oh well -addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World +addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World) addButtonDoor c btp btr a b speed w - = over buttons (IM.insert bid bt) + = (,) 0 + . over buttons (IM.insert bid bt) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathGraph newGraph $ set pathGraphP newGraphPairs - $ putDoubleDoor False c cond a b speed w + $ (snd $ putSingleDoor False c cond a b speed w) where bid = IM.newKey $ _buttons w cond w' = BtNoLabel == _btState (_buttons w' IM.! bid) @@ -50,9 +51,8 @@ putDoor -> [(Point2,Point2)] -- ^ Door positions, closed to open. -- Bumped out up and down by 9, not widened -> World - -> World -putDoor col cond pss w = addWalls w - & doors %~ addDoor + -> (Int,World) +putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor) where drid = IM.newKey $ _doors w addDoor = IM.insert drid $ Door' @@ -99,13 +99,6 @@ doorMechanismStepwise nsteps drid wlids pss dr w -- it is not at all clear that the zoning selects the correct walls -putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World -putDoubleDoor isPathable col cond a b speed - = putSingleDoor isPathable col cond a c speed - . putSingleDoor isPathable col cond b c speed - where - c = 0.5 *.* (a +.+ b) - -- TODO think about wall zoning, simplify! doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World doorMechanism drid speed wlidOpCps dr w @@ -129,9 +122,16 @@ doorMechanism drid speed wlidOpCps dr w & walls . ix wlid %~ moveDoorToward speed p & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp)) -putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World -putSingleDoor isPathable col cond a b speed w = addWalls w - & doors %~ addDoor +insertDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World + -> World +insertDoubleDoor isPathable col cond a b speed + = snd . putSingleDoor isPathable col cond a (0.5 *.* (a +.+ b)) speed + . snd . putSingleDoor isPathable col cond b (0.5 *.* (a +.+ b)) speed + +putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World + -> (Int, World) +putSingleDoor isPathable col cond a b speed w = (drid, addWalls w + & doors %~ addDoor) where drid = IM.newKey $ _doors w addDoor = IM.insert drid $ Door' diff --git a/src/Dodge/LightSources.hs b/src/Dodge/LightSources.hs index 7cc1b5469..1ef91f00c 100644 --- a/src/Dodge/LightSources.hs +++ b/src/Dodge/LightSources.hs @@ -8,6 +8,7 @@ module Dodge.LightSources , lampCoverWhen , doubleLampCover , verticalLampCover + , chain ) where import Dodge.Data @@ -26,7 +27,13 @@ colorLightAt col pos i = ,_lsDir = 0 ,_lsRad = 700 ,_lsIntensity = col + ,_lsPict = lightSourcePicture } +lightSourcePicture :: LightSource -> Picture +lightSourcePicture ls = setLayer 1 . translate3 (_lsPos ls) . color col $ circleSolid 3 + where + col = V4 r g b 1 + V3 r g b = _lsIntensity ls lightAt :: Point3 -> Int -> LightSource lightAt = colorLightAt 0.75 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index c8b0d9e52..5a242e8ab 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -30,6 +30,7 @@ worldPictures w = pictures ,concatMapPic (_spPicture . dbArg _prDraw) $ _props w ,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w ,concatMapPic (dbArg _ptDraw) $ _particles w + ,concatMapPic (dbArg _lsPict) $ _lightSources w ,testPic w ,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w ,concatMapPic clDraw $ _clouds w diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index 8bc3c9946..3acfd4701 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -17,7 +17,7 @@ corridor = defaultRoom , _rmLinks = lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks , _rmPS = - [sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50) + [sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) ,sPS (V2 0 0) 0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40) ] , _rmBound = [ rectNSWE 50 30 0 40 ] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index e9a22fe37..cecef581b 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -24,7 +24,7 @@ import Control.Lens import Control.Monad.State import Data.Tree import qualified Data.Map as M ---import qualified Data.IntMap as IM +import qualified Data.IntMap as IM twinSlowDoorRoom :: Int -- ^ Door id @@ -44,19 +44,24 @@ twinSlowDoorRoom drid w h x = defaultRoom [ sPS (V2 0 (h/2)) 0 putLamp , sPS (V2 25 5) 0 putLamp , sPS (V2 (negate 25) 5) 0 putLamp - , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1 - , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1 + , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1 + , Placement (PS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1) + $ \did -> Just $ Placement (PS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0)) + $ \lsid -> Just $ sPS (V2 0 (h-1)) 0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) lampHeight , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red (worldState %~ M.insert (DoorNumOpen drid) True ) (worldState %~ M.insert (DoorNumOpen drid) False) - , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight) - , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCoverWhen drmoving lampHeight ] , _rmBound = ps , _rmName = "twinSlowDoorRoom" } where - drmoving _ = True -- DoorHalfway == _drStatus (_doors w' IM.! drid) + addColorChange lsid drid = over pjUpdate $ chain $ const f + where + f w' | _drStatus (_doors w' IM.! drid) == DoorHalfway + = w' & lightSources . ix lsid . lsIntensity .~ V3 8 0 0 + | otherwise = w' & lightSources . ix lsid . lsIntensity .~ 0.7 + drmoving i w' = DoorHalfway == _drStatus (_doors w' IM.! i) lampHeight = 41 ps = [rectNSWE h 0 (-w) w