Split trigger door module, improve trigger door shadows

src/Dodge/LevelGen.hs

@@ -7,6 +7,8 @@ module Dodge.LevelGen
     , checkWalls
     , nubWalls
     , pairsToGraph
+    , makeButton
+    , makeSwitch
     )
     where
 
@@ -19,6 +21,8 @@ import Dodge.LevelGen.Block
 import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.AutoDoor
+import Dodge.LevelGen.TriggerDoor
+import Dodge.LevelGen.Switch
 
 import Geometry
 import Picture
@@ -127,171 +131,9 @@ instance Shiftable PlacementSpot where
     rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
 
 
-makeButton :: Color -> (World -> World) -> Button
-makeButton c eff = Button
-    { _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
-    , _btPos = (0,0)
-    , _btRot = 0
-    , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
---                                . set (buttons . ix (_btID b) . btPict) 
---                                      (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
---                                . set (buttons . ix (_btID b) . btState) BtNoLabel
---                                . set (buttons . ix (_btID b) . btEvent) (\b -> return)
-                                . soundOnce 1 $ w
-    , _btID = 0
-    , _btText = "Button"
-    --, _btText = "Button"
-    , _btState = BtOff
-    }
-    where
-        turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
-        onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
-
-makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
-makeSwitch c effOn effOff = Button
-    { _btPict = offPict
-    , _btPos = (0,0)
-    , _btRot = 0
-    , _btEvent = flipSwitch
-    , _btID = 0
-    , _btText = "Switch"
-    , _btState = BtOff
-    }
-    where 
-        flipSwitch b w = switchEffect b . soundOnce 1 $ w
-        switchEffect b = case _btState b of
-                            BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
-                            BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
-        offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
-                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
-                                  ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
-                                 ]
-        onPict  = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
-                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
-                                  ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
-                                 ]
-        turnOn :: Button -> Button
-        turnOn bt = bt {_btState = BtOn, _btPict = onPict}
-        turnOff :: Button -> Button
-        turnOff bt = bt {_btState = BtOff, _btPict = offPict}
           
 
 
--- probably don't have to rebuild the entire graph, oh well
-addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
-addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) 
-                                $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
-                                $ set pathGraph newGraph
-                                $ set pathGraph' newGraphPairs
-                                $ addTriggerDoor c cond a b w
-    where bid = newKey $ _buttons w
-          cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
-          bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
-          (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) 
-                                                   $ _pathGraph' w
-          newGraph = pairsToGraph dist newGraphPairs
-          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-          eff w' = over pathGraph' (removedPairs ++) 
-                   . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
-          f (x,y) = (x,y,dist x y)
-
-addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
-addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) 
-                                $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
-                                $ set pathGraph newGraph
-                                $ set pathGraph' newGraphPairs
-                                $ addTriggerDoor c cond a b w
-    where bid = newKey $ _buttons w
-          cond w = BtOn == (_btState $ _buttons w IM.! bid)
-          bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
-          (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) 
-                                                   $ _pathGraph' w
-          newGraph = pairsToGraph dist newGraphPairs
-          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-          openDoor w' = over pathGraph' (removedPairs ++) 
-                        . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
-          f (x,y) = (x,y,dist x y)
-          closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
-                        . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
-
-addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
-addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
-
-triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
-    where i = newKey wls
-          is = [i..]
-
-mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
-mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
-                               xs
-                               [ [pld,hwd]
-                               , [hwd,hwu]
-                               , [hwu,plu]
-                               , [plu,pld]
-                               , [pru,hwu]
-                               , [hwu,hwd]
-                               , [hwd,prd]
-                               , [prd,pru]
-                               ]
-                               [ [plld,pld]
-                               , [pld,plu]
-                               , [plu,pllu]
-                               , [pllu,plld]
-                               , [prru,pru]
-                               , [pru,prd]
-                               , [prd,prrd]
-                               , [prrd,prru]
-                               ]
-    where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
-          hw = 0.5 *.* (pl +.+ pr)
-          perp = 20 *.* normalizeV (pl -.- pr)
-          --perp = pl -.- hw
-          plu = pl +.+ norm
-          pld = pl -.- norm
-          pru = pr +.+ norm
-          prd = pr -.- norm
-          hwu = hw +.+ norm
-          hwd = hw -.- norm
-          pllu = plu +.+ perp
-          plld = pld +.+ perp
-          prru = pru -.- perp
-          prrd = prd -.- perp
-          addSound (x:xs) = f x : xs
-          f wl = over doorMech g wl
-          g dm w | dist wp pld > 2 && dist wp hwd > 2 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
-                                                                    $ dm w
-                 | otherwise = dm w
-            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
-
-triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
-triggerDoorPane c cond n [a,b] [a',b'] = Door
-    { _wlLine = [a,b]
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = c
-    , _wlDraw = Nothing
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
---    , _doorLine = [a,b,a',b']
-    }
-    where 
-        dm w | cond w    = flip (foldr changeZonedWall) zoneps
-                           $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
-             | otherwise = flip (foldr changeZonedWall') zoneps
-                           $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
-        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
-               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
-        openDoor :: Wall -> Wall
-        openDoor wl = case _wlLine wl of
-                        ((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a' pa, mvPointToward b' pb]}
-        closeDoor :: Wall -> Wall
-        closeDoor wl = case _wlLine wl of
-                        ((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a pa, mvPointToward b pb]}
-        changeZonedWall (!x,!y) 
-              = over wallsZone $ adjustIMZone openDoor x y n
-        changeZonedWall' (!x,!y) 
-              = over wallsZone $ adjustIMZone closeDoor x y n
 
 putWindowBlock :: Point2 -> Point2 -> World -> World
 putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns

src/Dodge/LevelGen/Switch.hs

@@ -0,0 +1,61 @@
+module Dodge.LevelGen.Switch
+    where
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+
+import Picture
+import Geometry
+
+import qualified Data.IntMap.Strict as IM
+
+import Control.Lens
+
+
+makeButton :: Color -> (World -> World) -> Button
+makeButton c eff = Button
+    { _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    , _btPos = (0,0)
+    , _btRot = 0
+    , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
+--                                . set (buttons . ix (_btID b) . btPict) 
+--                                      (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+--                                . set (buttons . ix (_btID b) . btState) BtNoLabel
+--                                . set (buttons . ix (_btID b) . btEvent) (\b -> return)
+                                . soundOnce 1 $ w
+    , _btID = 0
+    , _btText = "Button"
+    --, _btText = "Button"
+    , _btState = BtOff
+    }
+    where
+        turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
+        onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+
+makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
+makeSwitch c effOn effOff = Button
+    { _btPict = offPict
+    , _btPos = (0,0)
+    , _btRot = 0
+    , _btEvent = flipSwitch
+    , _btID = 0
+    , _btText = "Switch"
+    , _btState = BtOff
+    }
+    where 
+        flipSwitch b w = switchEffect b . soundOnce 1 $ w
+        switchEffect b = case _btState b of
+                            BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
+                            BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
+        offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
+                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
+                                  ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
+                                 ]
+        onPict  = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
+                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
+                                  ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
+                                 ]
+        turnOn :: Button -> Button
+        turnOn bt = bt {_btState = BtOn, _btPict = onPict}
+        turnOff :: Button -> Button
+        turnOff bt = bt {_btState = BtOff, _btPict = offPict}

src/Dodge/LevelGen/TriggerDoor.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE BangPatterns #-}
+module Dodge.LevelGen.TriggerDoor
+    where
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+import Dodge.LevelGen.Switch
+import Dodge.LevelGen.Pathing
+
+import Picture
+import Geometry
+
+import Data.List
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+
+import Control.Lens
+import Control.DeepSeq (deepseq)
+
+import Data.Graph.Inductive hiding ((&))
+import Data.Graph.Inductive.NodeMap
+
+-- probably don't have to rebuild the entire graph, oh well
+addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
+addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) 
+                                $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+                                $ set pathGraph newGraph
+                                $ set pathGraph' newGraphPairs
+                                $ addTriggerDoor c cond a b w
+    where bid = newKey $ _buttons w
+          cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
+          bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
+          (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) 
+                                                   $ _pathGraph' w
+          newGraph = pairsToGraph dist newGraphPairs
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          eff w' = over pathGraph' (removedPairs ++) 
+                   . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+          f (x,y) = (x,y,dist x y)
+
+addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
+addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) 
+                                $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+                                $ set pathGraph newGraph
+                                $ set pathGraph' newGraphPairs
+                                $ addTriggerDoor c cond a b w
+    where bid = newKey $ _buttons w
+          cond w = BtOn == (_btState $ _buttons w IM.! bid)
+          bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
+          (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) 
+                                                   $ _pathGraph' w
+          newGraph = pairsToGraph dist newGraphPairs
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          openDoor w' = over pathGraph' (removedPairs ++) 
+                        . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+          f (x,y) = (x,y,dist x y)
+          closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
+                        . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
+
+addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
+addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
+
+triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
+    where i = newKey wls
+          is = [i..]
+
+mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
+mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
+                               xs
+                               [ [pld,hwd,hw,pl]
+                               , [hwd,hwu]
+                               , [hwu,plu,pl,hw]
+                               , [plu,pld]
+                               , [pru,hwu,hw,pr]
+                               , [hwu,hwd]
+                               , [hwd,prd,pr,hw]
+                               , [prd,pru]
+                               ]
+                               [ [plld,pld,pl,pl]
+                               , [pld,plu]
+                               , [plu,pllu,pl,pl]
+                               , [pllu,plld]
+                               , [prru,pru,pr,pr]
+                               , [pru,prd]
+                               , [prd,prrd,pr,pr]
+                               , [prrd,prru]
+                               ]
+    where norm = 15 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
+          hw = 0.5 *.* (pl +.+ pr)
+          perp = 20 *.* normalizeV (pl -.- pr)
+          --perp = pl -.- hw
+          plu = pl +.+ norm
+          pld = pl -.- norm
+          pru = pr +.+ norm
+          prd = pr -.- norm
+          hwu = hw +.+ norm
+          hwd = hw -.- norm
+          pllu = plu +.+ perp
+          plld = pld +.+ perp
+          prru = pru -.- perp
+          prrd = prd -.- perp
+          addSound (x:xs) = f x : xs
+          f wl = over doorMech g wl
+          g dm w | dist wp pld > 2 && dist wp hwd > 2 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
+                                                                    $ dm w
+                 | otherwise = dm w
+            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
+
+triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
+triggerDoorPane c cond n closedPos openPos = Door
+    { _wlLine = closedPos
+    , _wlID = n
+    , _doorMech = dm
+    , _wlColor = c
+    , _wlDraw = Nothing
+    , _wlSeen = False
+    , _wlIsSeeThrough = False
+--    , _doorLine = [a,b,a',b']
+    }
+    where 
+        a = closedPos !! 0
+        b = closedPos !! 1
+        dm w | cond w    = flip (foldr changeZonedWall) zoneps
+                           $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
+             | otherwise = flip (foldr changeZonedWall') zoneps
+                           $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
+        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
+        mvP !ep !p = mvPointTowardAtSpeed 2 ep p
+        moveToward :: [Point2] -> Wall -> Wall
+        moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
+                           in  deepseq newPs $ w {_wlLine = newPs}
+        openDoor = moveToward openPos
+        closeDoor = moveToward closedPos
+        changeZonedWall (!x,!y) 
+              = over wallsZone $ adjustIMZone openDoor x y n
+        changeZonedWall' (!x,!y) 
+              = over wallsZone $ adjustIMZone closeDoor x y n