Working implementation of light change when door opens

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

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

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' :: World -> ((Point2,Float) , Placement) -> World
-placeSpot' (shift, plmnt) = placeSpot $ shiftPSBy' shift (_placementSpot plmnt)
+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
+placeSpotID :: PlacementSpot -> World -> (Int, World)
-placeSpot ps w = case _psType ps of
+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 <>)
+    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
-    PutNothing -> w
+    PutNothing -> (0,w)
-    PutID _ -> 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
+    -> (Int, World)
-placeProp pr p a = over props addProp
+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
+    -> (Int, World)
-placeBt bt p rot = over buttons addBT
+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
+    -> (Int, World)
-placeFlIt itm p rot = floorItems %~ 
+placeFlIt itm p rot w = (i, w & floorItems %~ 
-    \ fis -> IM.insert (IM.newKey fis) 
+    \ 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
+    -> (Int, World)
-placePressPlate pp p rot = over pressPlates addPP
+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 :: Creature -> Point2 -> Float -> World -> (Int,World)
-placeCr crF p rot = over creatures addCr
+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 :: LightSource -> Point3 -> Float -> World -> (Int,World)
-placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w
+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

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

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
+-- TODO add block list to world
-putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
+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

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 

src/Dodge/LevelGen/LineBlock.hs

@@ -19,8 +19,10 @@ putLineBlock
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
-    -> World
+    -> (Int, World)
-putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
+putLineBlock basePane blockWidth depth a b w 
+    = (,) 0 
+    $ removePathsCrossing a b $ foldr insertBlock w listBlocks
   where 
     d = dist a b
     rot = argV (b -.- a)

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
+    -> (Int,World)
-putDoor col cond pss w = addWalls w
+putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
-    & 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
+insertDoubleDoor ::  Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
-putSingleDoor isPathable col cond a b speed w = addWalls w 
+    -> World
-    & doors %~ addDoor
+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'

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

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      

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 ]

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