Working implementation of light change when door opens

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
-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

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
-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)

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'