Reorganisation of light source placements and fittings

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
+

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

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

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

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

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

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

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}