diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index bd1f39486..91794f2e6 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -520,3 +520,8 @@ evenOddSplit = foldr f ([],[]) dbArg :: (a -> a -> b) -> a -> b {-# INLINE dbArg #-} dbArg f x = f x x + +-- TODO check whether this is simply the reader monad, flipped +dbArgChain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b +dbArgChain f g x = f x . g x + diff --git a/src/Dodge/LightSources/Lamp.hs b/src/Dodge/LightSources/Lamp.hs index 222bcbd61..0cbf12d64 100644 --- a/src/Dodge/LightSources/Lamp.hs +++ b/src/Dodge/LightSources/Lamp.hs @@ -3,18 +3,10 @@ module Dodge.LightSources.Lamp , tLight , lightAt , colorLightAt - , lampCover - , lampCoverWhen - , doubleLampCover - , verticalLampCover - , chain ) where import Dodge.Data import Geometry.Data -import ShapePicture -import Shape -import Geometry import Dodge.Default import Control.Lens @@ -67,99 +59,3 @@ tLight t rmax col (V3 x y z) = TLS | otherwise = Just $ tls & tlsTime -~ 1 -lampCover :: Float -> Prop -lampCover h = ShapeProp - { _pjPos = V2 0 0 - , _pjID = 0 - , _pjRot = 0 - , _pjUpdate = rotateProp 0.15 - , _prDraw = drawLampCover h - , _prToggle = True - } -lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop -lampCoverWhen cond pos h = ShapeProp - { _pjPos = pos - , _pjID = 0 - , _pjRot = 0 - , _pjUpdate = setToggle cond `chain` rotateProp 0.15 - , _prDraw = drawLampCover h - , _prToggle = True - } - -doubleLampCover :: Float -> Prop -doubleLampCover h = ShapeProp - { _pjPos = V2 0 0 - , _pjID = 0 - , _pjRot = 0 - , _pjUpdate = rotateProp 0.15 - , _prDraw = drawDoubleLampCover h - , _prToggle = True - } - --- on the current (27/9/21) version of shadow stencilling, this glitches --- slightly when the shadow rotates towards the screen -verticalLampCover :: Float -> Prop -verticalLampCover h = ShapeProp - { _pjPos = V2 0 0 - , _pjID = 0 - , _pjRot = 0 - , _pjUpdate = rotateProp 0.15 - , _prDraw = drawVerticalLampCover h - , _prToggle = True - } - -rotateProp :: Float -> Prop -> World -> World -rotateProp rotAmount pr w = w - & props . ix (_pjID pr) . pjRot +~ rotAmount - -setToggle :: (World -> Bool) -> Prop -> World -> World -setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w - --- TODO check whether this is simply the reader monad, flipped -chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b -chain f g x = f x . g x - -drawLampCover :: Float -> Prop -> SPic -drawLampCover h pr | not (_prToggle pr) = mempty - | otherwise = - ( translateSHz (h-2.5) . uncurryV translateSHf pos - $ rotateSH a $ mconcat - [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1) - , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2 - , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1) - , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2 - , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)] - ] - , mempty - ) - where - a = _pjRot pr - pos = _pjPos pr - -drawDoubleLampCover :: Float -> Prop -> SPic -drawDoubleLampCover h pr = - ( translateSHz (h-2.5) . uncurryV translateSHf pos - $ rotateSH a $ mconcat - [ upperPrismPoly 5 $ rectNSEW 6 5 6 (-6) - , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6) - , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5] - , upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)] - ] - , mempty - ) - where - a = _pjRot pr - pos = _pjPos pr - -drawVerticalLampCover :: Float -> Prop -> SPic -drawVerticalLampCover h pr = - ( translateSHz h . uncurryV translateSHf pos - $ rotateSHx a $ mconcat - [ - translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5) - ] - , mempty - ) - where - a = _pjRot pr - pos = _pjPos pr diff --git a/src/Dodge/Placement/Instance.hs b/src/Dodge/Placement/Instance.hs index dcc8616ca..079a3cd1e 100644 --- a/src/Dodge/Placement/Instance.hs +++ b/src/Dodge/Placement/Instance.hs @@ -1,15 +1,19 @@ module Dodge.Placement.Instance ( module Dodge.Placement.Instance.Door , module Dodge.Placement.Instance.LightSource + , module Dodge.Placement.Instance.LightSource.Cover , module Dodge.Placement.Instance.Wall , module Dodge.Placement.Instance.Button , module Dodge.Placement.Instance.Turret , module Dodge.Placement.Instance.Sensor , module Dodge.Placement.Instance.Creature + , module Dodge.Placement.Instance.LightSource.Flicker ) where import Dodge.Placement.Instance.Door +import Dodge.Placement.Instance.LightSource.Cover import Dodge.Placement.Instance.LightSource +import Dodge.Placement.Instance.LightSource.Flicker import Dodge.Placement.Instance.Wall import Dodge.Placement.Instance.Button import Dodge.Placement.Instance.Turret diff --git a/src/Dodge/Placement/Instance/LightSource/Cover.hs b/src/Dodge/Placement/Instance/LightSource/Cover.hs new file mode 100644 index 000000000..21fe5eb05 --- /dev/null +++ b/src/Dodge/Placement/Instance/LightSource/Cover.hs @@ -0,0 +1,102 @@ +module Dodge.Placement.Instance.LightSource.Cover where +import Dodge.Data +import Dodge.Base +import Geometry.Data +import ShapePicture +import Shape +import Geometry + +import Control.Lens + +lampCover :: Float -> Prop +lampCover h = ShapeProp + { _pjPos = V2 0 0 + , _pjID = 0 + , _pjRot = 0 + , _pjUpdate = rotateProp 0.15 + , _prDraw = drawLampCover h + , _prToggle = True + } +lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop +lampCoverWhen cond pos h = ShapeProp + { _pjPos = pos + , _pjID = 0 + , _pjRot = 0 + , _pjUpdate = setToggle cond `dbArgChain` rotateProp 0.15 + , _prDraw = drawLampCover h + , _prToggle = True + } + +doubleLampCover :: Float -> Prop +doubleLampCover h = ShapeProp + { _pjPos = V2 0 0 + , _pjID = 0 + , _pjRot = 0 + , _pjUpdate = rotateProp 0.15 + , _prDraw = drawDoubleLampCover h + , _prToggle = True + } + +-- on the current (27/9/21) version of shadow stencilling, this glitches +-- slightly when the shadow rotates towards the screen +verticalLampCover :: Float -> Prop +verticalLampCover h = ShapeProp + { _pjPos = V2 0 0 + , _pjID = 0 + , _pjRot = 0 + , _pjUpdate = rotateProp 0.15 + , _prDraw = drawVerticalLampCover h + , _prToggle = True + } + +rotateProp :: Float -> Prop -> World -> World +rotateProp rotAmount pr w = w + & props . ix (_pjID pr) . pjRot +~ rotAmount + +setToggle :: (World -> Bool) -> Prop -> World -> World +setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w + +drawLampCover :: Float -> Prop -> SPic +drawLampCover h pr | not (_prToggle pr) = mempty + | otherwise = + ( translateSHz (h-2.5) . uncurryV translateSHf pos + $ rotateSH a $ mconcat + [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1) + , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2 + , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1) + , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2 + , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)] + ] + , mempty + ) + where + a = _pjRot pr + pos = _pjPos pr + +drawDoubleLampCover :: Float -> Prop -> SPic +drawDoubleLampCover h pr = + ( translateSHz (h-2.5) . uncurryV translateSHf pos + $ rotateSH a $ mconcat + [ upperPrismPoly 5 $ rectNSEW 6 5 6 (-6) + , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6) + , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5] + , upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)] + ] + , mempty + ) + where + a = _pjRot pr + pos = _pjPos pr + +drawVerticalLampCover :: Float -> Prop -> SPic +drawVerticalLampCover h pr = + ( translateSHz h . uncurryV translateSHf pos + $ rotateSHx a $ mconcat + [ + translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5) + ] + , mempty + ) + where + a = _pjRot pr + pos = _pjPos pr diff --git a/src/Dodge/Placement/Instance/LightSource/Flicker.hs b/src/Dodge/Placement/Instance/LightSource/Flicker.hs new file mode 100644 index 000000000..5c4c3cfed --- /dev/null +++ b/src/Dodge/Placement/Instance/LightSource/Flicker.hs @@ -0,0 +1,33 @@ +module Dodge.Placement.Instance.LightSource.Flicker where +import Dodge.LevelGen.Data +import Dodge.Data +import qualified Data.IntMap.Strict as IM +import Data.Maybe +import Control.Lens +import System.Random +-- Supposes the orginal placement is a light source, adds a flicker +flickerMod :: Placement -> Maybe Placement +flickerMod pl = Just $ sps0 $ PutMod $ ModIDTimerPoint3Bool + { _mdID = 0 + , _mdExternalID = fromJust $ _plMID pl + , _mdUpdate = flickerUpdate + , _mdTimer = 10 + , _mdPoint3 = 0.8 + , _mdBool = True + } + +flickerUpdate :: Modification -> World -> World +flickerUpdate md w + | _mdTimer md > 0 = w & modifications . ix mdid . mdTimer -~ 1 + | otherwise = w & lightSources . ix lsid . lsIntensity .~ mdcol + & modifications . ix mdid + %~ ( (mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not) ) + where + mdcol = _mdPoint3 md + lscol = _lsIntensity $ _lightSources w IM.! lsid + lsid = _mdExternalID md + mdid = _mdID md + timerange + | _mdBool md = (2,10) + | otherwise = (2,30) + (newtime,_) = randomR timerange $ _randGen w diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index a30bdb630..11a0fac01 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -1,9 +1,9 @@ --{-# LANGUAGE TupleSections #-} {- | Rooms containing long doors, probably with a big reveal behind them. -} -module Dodge.Room.LongDoor - where +module Dodge.Room.LongDoor where import Dodge.Data +import Dodge.Base import Dodge.Default.Room import Dodge.LevelGen.Data import Dodge.Placement.Instance @@ -51,7 +51,7 @@ twinSlowDoorRoom w h x = defaultRoom } where wlSpeed = 0.5 - addColorChange lsid drid' = over pjUpdate $ chain $ const f + addColorChange lsid drid' = over pjUpdate $ dbArgChain $ const f where f w' | _drStatus (_doors w' IM.! drid') == DoorHalfway = w' & lightSources . ix lsid . lsIntensity .~ V3 8 0 0 diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 0452a4d07..7a1bf754e 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -24,8 +24,7 @@ import Data.Tree import Control.Monad.State import Control.Lens import System.Random -import Data.Maybe -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM rezBox :: LightSource -> Room rezBox ls = roomRect 40 60 1 1 @@ -54,33 +53,6 @@ wpAdd wp = rmPmnts %~ f f _ = [sPS (V2 15 30) 1 (PutFlIt wp)] g x = x & plIDCont .~ flickerMod --- TODO move this to a sensible place --- Supposes the orginal placement is a light source, adds a flicker -flickerMod :: Placement -> Maybe Placement -flickerMod pl = Just $ sps0 $ PutMod $ ModIDTimerPoint3Bool - { _mdID = 0 - , _mdExternalID = fromJust $ _plMID pl - , _mdUpdate = flickerUpdate - , _mdTimer = 10 - , _mdPoint3 = 0.8 - , _mdBool = True - } - -flickerUpdate :: Modification -> World -> World -flickerUpdate md w - | _mdTimer md > 0 = w & modifications . ix mdid . mdTimer -~ 1 - | otherwise = w & lightSources . ix lsid . lsIntensity .~ mdcol - & modifications . ix mdid - %~ ( (mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not) ) - where - mdcol = _mdPoint3 md - lscol = _lsIntensity $ _lightSources w IM.! lsid - lsid = _mdExternalID md - mdid = _mdID md - timerange - | _mdBool md = (2,10) - | otherwise = (2,30) - (newtime,_) = randomR timerange $ _randGen w rezBoxesThenWeaponRoom :: RandomGen g => State g (Tree (Either Room Room)) rezBoxesThenWeaponRoom = do diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 5c2c364bd..dfaaeb1cf 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -130,7 +130,7 @@ destroyBlock bl w = w wlids = _blWallIDs bl awl = _walls w IM.! IS.findMin wlids pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids - ps = (replicateM 25 $ randInCirc 20) & evalState $ _randGen w + ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w -- | Note the explict use of record syntax. Using lens created a space leak. resetWorldEvents :: World -> World resetWorldEvents w = w {_worldEvents = id}