Add indexed world modifications, example use in flicker lights

src/Dodge/Data.hs

@@ -70,6 +70,7 @@ data World = World
     , _randGen              :: StdGen
     , _mousePos             :: !Point2
     , _testString           :: World -> [String]
+    , _modifications        :: IM.IntMap Modification
     , _yourID               :: !Int
     , _worldEvents          :: World -> World
     , _pressPlates          :: IM.IntMap PressPlate
@@ -484,6 +485,15 @@ data PjParam = PjParam
     , _pjMaxParam  :: Int
     , _pjDisplayParam :: Int -> String
     }
+data Modification
+    = ModIDTimerPoint3Bool
+        { _mdID     :: Int
+        , _mdExternalID :: Int
+        , _mdUpdate :: Modification -> World -> World
+        , _mdTimer  :: Int
+        , _mdPoint3 :: Point3
+        , _mdBool   :: Bool
+        }
 data Prop 
     = Projectile    
         { _pjPos :: Point2
@@ -792,6 +802,7 @@ makeLenses ''FloorItem
 makeLenses ''Ammo
 makeLenses ''PjParam
 makeLenses ''Prop
+makeLenses ''Modification
 makeLenses ''Particle
 makeLenses ''Wall
 makeLenses ''WallStructure

src/Dodge/Default/World.hs

@@ -26,6 +26,7 @@ defaultWorld = World
     , _cameraRot = 0
     , _cameraZoom = 1
     , _cameraViewFrom = V2 0 0
+    , _modifications = IM.empty
     , _creatures = IM.empty
     , _creaturesZone = Zone IM.empty
     , _creatureGroups = IM.empty

src/Dodge/Initialisation.hs

@@ -31,7 +31,7 @@ initialWorld = defaultWorld
     , _yourID = 0
     , _worldEvents = saveWorldInEmptySlot LevelStartSlot 
         . soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing 
-        . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]]
+        . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-4..5] , y <- [-5,-4..5]]
     , _pressPlates = IM.empty
     , _buttons = IM.empty
     , _toPlaySounds = M.empty

src/Dodge/LevelGen.hs

@@ -7,11 +7,17 @@ import Dodge.Data
 import Dodge.Floor
 import Dodge.Layout
 import Dodge.Initialisation
+import Dodge.RandomHelp
 
 import System.Random
+import Control.Lens
+import Control.Monad.State
 
 generateWorldFromSeed :: Int -> IO World
 generateWorldFromSeed i = do
     roomList <- layoutLevelFromSeed 0 i
-    return $ generateLevelFromRoomList roomList 
+    return $ randomCompass $ generateLevelFromRoomList roomList 
          initialWorld{_randGen=mkStdGen i}
+
+randomCompass :: World -> World
+randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)

src/Dodge/LevelGen/Data.hs

@@ -22,6 +22,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutPressPlate PressPlate
     | PutBlock [Int] Color [Point2]
     | PutCoordinate Point2
+    | PutMod Modification
     | PutTrigger (World -> Bool)
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
@@ -104,8 +105,8 @@ spNoID ps pst = Placement ps pst Nothing (const Nothing)
 pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
 pContID ps pt = Placement ps pt Nothing . intPlPlPl
 
-plCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
+psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
-plCont ps pt = Placement ps pt Nothing
+psPtCont ps pt = Placement ps pt Nothing
 
 sPS :: Point2 -> Float -> PSType -> Placement
 sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)

src/Dodge/Placement/Instance/Button.hs

@@ -14,7 +14,7 @@ import Data.Maybe
 import Control.Lens
 
 triggerSwitchSPic :: (Button -> SPic) -> PlacementSpot -> Placement
-triggerSwitchSPic sdraw ps = plCont ps (PutTrigger (const False))
+triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger (const False))
     $ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff $ trigid tp) (offeff $ trigid tp))) 
                     (const Nothing)
   where
@@ -23,7 +23,7 @@ triggerSwitchSPic sdraw ps = plCont ps (PutTrigger (const False))
     offeff tid = triggers . ix tid .~ const False
 
 triggerSwitchSPicLight :: (Button -> SPic) -> PlacementSpot -> Placement
-triggerSwitchSPicLight sdraw ps = plCont ps (PutTrigger (const False))
+triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger (const False))
     $ \tp -> Just $ pContID fstLnkOut (PutLS thels)
     $ \lsid -> Just 
         $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp))) 
@@ -37,7 +37,7 @@ triggerSwitchSPicLight sdraw ps = plCont ps (PutTrigger (const False))
     offeff lsid tid = eff lsid tid False (V3 0.5 0 0)
 
 triggerSwitch :: Color -> PlacementSpot -> Placement
-triggerSwitch col ps = plCont ps (PutTrigger (const False))
+triggerSwitch col ps = psPtCont ps (PutTrigger (const False))
     $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) 
                     (const Nothing)
   where

src/Dodge/Placement/Instance/LightSource.hs

@@ -101,6 +101,12 @@ unusedLnkToPS rp = case rp of
     UnusedLink p a -> Just $ PS p a
     _ -> Nothing
 
+spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
+spanLSLightI ls h a b = ps0j (PutLS ls {_lsPos = V3 x y h})
+    $ sps0 $ PutForeground $ thinHighBar h a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
 spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
 spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0)
     $ sps0 $ PutForeground $ thinHighBar h a b

src/Dodge/Placement/PlaceSpot.hs

@@ -90,6 +90,7 @@ shiftPSBy (pos,rot) ps = ps
 placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
 placeSpotID ps pt w = case pt of
     PutTrigger cond -> placeNewInto triggers cond w
+    PutMod     modi -> plNewUpID modifications mdID modi w
     PutProp prop    -> plNewUpID props pjID (mvProp p rot prop) w
     PutButton bt    -> plNewUpID buttons btID (mvButton p rot bt) w
     PutFlIt itm     -> plNewUpID floorItems flItID (createFlIt p rot itm) w

src/Dodge/Room/Start.hs

@@ -1,6 +1,7 @@
 module Dodge.Room.Start where
 import Dodge.LevelGen.Data
 import Dodge.Data
+import Dodge.Default
 import Dodge.Layout.Tree.Either
 import Dodge.RandomHelp
 import Dodge.Room.Door
@@ -23,24 +24,63 @@ import Data.Tree
 import Control.Monad.State
 import Control.Lens
 import System.Random
---import qualified Data.IntMap.Strict as IM
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
 
-rezBox :: Room
+rezBox :: LightSource -> Room
-rezBox = roomRect 40 60 1 1 
+rezBox ls = roomRect 40 60 1 1 
-    & rmPmnts .~ [ spanColLightI rezcol 95 (V2 0 1) (V2 40 1) ]
+    & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS ls]
+rezColor :: RandomGen g => State g LightSource
+rezColor = do
+    col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1]
+    h   <- takeOne [30,50,80,90,90,90,90]
+    rad <- takeOne [150,200,200,250,250,300,300,300]
+    return defaultLS
+        { _lsPos = V3 0 0 h
+        , _lsIntensity = col
+        , _lsRad = rad
+        }
 
-rezcol :: Point3
+rezInvBox :: LightSource -> Room
-rezcol = V3 0.0 0.1 0.5
+rezInvBox = (rmLinks %~ reverse) . rezBox
 
-rezInvBox :: Room
+crAdd :: Room -> Room
-rezInvBox = roomRect 40 60 1 1 
+crAdd = rmPmnts %~ (sPS (V2 20 10) (0.5*pi) randC1 :)
-    & rmPmnts .~ [ spanColLightI rezcol 95 (V2 0 59) (V2 40 59) ]
 
-crRezBox :: Room
+wpAdd :: Item -> Room -> Room
-crRezBox = rezInvBox & rmPmnts %~ (sPS (V2 20 50) (1.5*pi) randC1 :)
+wpAdd wp = rmPmnts %~ f
+  where
+    f (x:xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs
+    f _ = [sPS (V2 15 30) 1 (PutFlIt wp)]
+    g x = x & plIDCont .~ flickerMod
 
-wpRezBox :: Item -> Room
+-- TODO move this to a sensible place
-wpRezBox wp = rezInvBox & rmPmnts %~ (sPS (V2 15 30) 1 (PutFlIt wp) :)
+-- Supposes the orginal placement is a light source, adds a flickermod
+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
@@ -49,7 +89,9 @@ rezBoxesThenWeaponRoom = do
     return $ rboxes `appendEitherTree` [wroom]
 
 rezBoxThenWeaponRoom :: RandomGen g => State g (Tree (Either Room Room))
-rezBoxThenWeaponRoom = treeFromTrunk [Left rezBox,Left door] <$> weaponRoom
+rezBoxThenWeaponRoom = do
+    rcol <- rezColor
+    treeFromTrunk [Left $ rezBox rcol,Left door] <$> weaponRoom
 
 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = join $ takeOne 
@@ -63,9 +105,11 @@ rezBoxesWpCrit :: RandomGen g => State g (Tree (Either Room Room))
 rezBoxesWpCrit = do
     w <- state $ randomR (200,400)
     h <- state $ randomR (40,40)
+    thecol <- rezColor
     theweapon <- randBlockBreakWeapon
     let bottomEdgeTest (V2 _ y,_) = y < 1
         bottomLeftTest (V2 x y,_) = y < 1 && x < 21
+        aroom = rezInvBox thecol
     centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$>
             (randomiseOutLinks =<< changeLinkTo bottomLeftTest 
                     ((roomRectAutoLinks w h) {_rmPmnts = []}))
@@ -74,10 +118,10 @@ rezBoxesWpCrit = do
     j <- state $ randomR (i,n-2)
     blcor <- blockedCorridor'
     let rezrooms = map adddoor 
-            $ insertAt i (wpRezBox theweapon) 
+            $ insertAt i (wpAdd theweapon aroom) 
-            $ insertAt j crRezBox 
+            $ insertAt j (crAdd aroom)
-            $ replicate (n-3) rezInvBox
+            $ replicate (n-3) aroom
-    return $ treeFromTrunk [Left rezBox
+    return $ treeFromTrunk [Left $ rezBox thecol
         , Left door
         ] 
         (Node (Left centralRoom) (rezrooms ++ [onwardtree blcor]))
@@ -90,20 +134,21 @@ rezBoxesWp = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (40,40)
     theweapon <- randBlockBreakWeapon
+    thecol <- rezColor
     let bottomEdgeTest (V2 _ y,_) = y < 1
+        aroom = rezInvBox thecol
     centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest 
         ((roomRectAutoLinks w h) {_rmPmnts = []})
     blcor <- blockedCorridor'
     let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom
     let rezrooms = map adddoor 
-            $ wpRezBox theweapon : replicate (n-2) rezInvBox
+            $ wpAdd theweapon aroom : replicate (n-2) aroom
     centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
-    return $ treeFromTrunk [Left rezBox
+    return $ treeFromTrunk [Left $ rezBox thecol
         , Left door
         ] 
         (Node (Left centralRoom') (rezrooms ++ [onwardtree blcor]))
   where
-    --dbox = treeFromPost [Left door] (Left rezInvBox)
     adddoor rm = treeFromPost [Left door] (Left rm)
     onwardtree blcor = treeFromPost [Left door] (Right blcor)
 
@@ -111,17 +156,17 @@ rezBoxes :: RandomGen g => State g (Tree (Either Room Room))
 rezBoxes = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (40,40)
+    thecol <- rezColor
     let bottomEdgeTest (V2 _ y,_) = y < 1
+        dbox = treeFromPost [Left door] (Left $ rezInvBox thecol)
     centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest 
         ((roomRectAutoLinks w h) {_rmPmnts = []})
     let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom
     centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
-    return $ treeFromTrunk [Left rezBox
+    return $ treeFromTrunk [Left $ rezBox thecol
         , Left door
         ] 
         (Node (Left centralRoom') (replicate (n-1) dbox ++ [Node (Right door) []]))
-  where
-    dbox = treeFromPost [Left door] (Left rezInvBox)
 
 startRoom' :: RandomGen g => State g (Tree (Either Room Room))
 startRoom' = do
@@ -137,7 +182,8 @@ startRoom' = do
             , putLasTurret & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
             , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
             ]
-    treeFromPost [Left rezBox, Left door] . Right 
+    thecol <- rezColor
+    treeFromPost [Left $ rezBox thecol, Left door] . Right 
         <$> randomiseOutLinks 
             (shiftRoomBy (V2 (-20) (-20),0) 
             ( roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) 

src/Dodge/Update.hs

@@ -58,6 +58,7 @@ functionalUpdate w = case _menuLayers w of
         . updateDoors
         . resetWorldEvents
         . dbArg _worldEvents
+        . updateModifications
         . updateParticles 
         . updateProjectiles 
         . updateLightSources
@@ -82,6 +83,11 @@ functionalUpdate w = case _menuLayers w of
       where 
         (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
 
+updateModifications :: World -> World
+updateModifications w = foldr f w (_modifications w)
+  where
+    f md = _mdUpdate md md
+
 splinterBlock :: Block -> World -> World
 splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
     & blocks . ix (_blID bl) . blHPs %~ tail