Split autodoor module

src/Dodge/Base.hs

@@ -750,3 +750,13 @@ wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
 
 translateDrawing = translate
 rotateDrawing = rotate
+
+mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
+mvPointTowardAtSpeed speed !ep !p 
+    | dist p ep < speed = ep
+    | otherwise         = p +.+ speed *.* normalizeV (ep -.- p)
+
+mvPointToward :: Point2 -> Point2 -> Point2
+mvPointToward !ep !p | dist p ep < 1 = ep
+                     | otherwise     = p +.+ normalizeV (ep -.- p)
+

src/Dodge/LevelGen.hs

@@ -14,17 +14,17 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.Prototypes
+
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.Pathing
-
 import Dodge.LevelGen.StaticWalls
+import Dodge.LevelGen.AutoDoor
 
 import Geometry
 import Picture
 
 import System.Random
 
-import Control.DeepSeq (deepseq)
 
 import Control.Monad.State
 import Data.List
@@ -293,9 +293,6 @@ triggerDoorPane c cond n [a,b] [a',b'] = Door
         changeZonedWall' (!x,!y) 
               = over wallsZone $ adjustIMZone closeDoor x y n
 
-addAutoDoor :: Point2 -> Point2 -> World -> World
-addAutoDoor a b = over walls (autoDoorAt a b)
-
 putWindowBlock :: Point2 -> Point2 -> World -> World
 putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
     where d = dist a b
@@ -363,113 +360,7 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
                 f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
             in  over walls f w
                                     
-autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
-    where i = newKey wls
-          is = [i..]
 
-mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
-mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
-                               xs
-                               [ True
-                               , False
-                               , True
-                               , True
-                               , False
-                               , True
-                               ]
-                               [ [pld,hwd,hw,pl]
-                               , [hwd,hwu]
-                               , [hwu,plu,pl,hw]
-                               , [pru,hwu,hw,pr]
-                               , [hwu,hwd]
-                               , [hwd,prd,pr,hw]
-                               ]
-                               [ [plld,pld,pl,pl]
-                               , [pld,plu]
-                               , [plu,pllu,pl,pl]
-                               , [prru,pru,pr,pr]
-                               , [pru,prd]
-                               , [prd,prrd,pr,pr]
-                               ]
-    where norm = 15.1 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
-                    -- .1 hack, there was flickering
-          hw = 0.5 *.* (pl +.+ pr)
-          parallel = 20 *.* normalizeV (pl -.- pr)
-          plu = pl +.+ norm
-          pld = pl -.- norm
-          pru = pr +.+ norm
-          prd = pr -.- norm
-          hwu = hw +.+ norm
-          hwd = hw -.- norm
-          pllu = plu +.+ parallel
-          plld = pld +.+ parallel
-          prru = pru -.- parallel
-          prrd = prd -.- parallel
-          addSound (x:xs) = f x : xs
-          f wl = over doorMech g wl
-          g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 
-                                                                    $ dm w
-                 | otherwise = dm w
-            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
-
-mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
-mvPointTowardAtSpeed speed !ep !p 
-    | dist p ep < speed = ep
-    | otherwise         = p +.+ speed *.* normalizeV (ep -.- p)
-
-mvPointToward :: Point2 -> Point2 -> Point2
-mvPointToward !ep !p | dist p ep < 1 = ep
-                     | otherwise     = p +.+ normalizeV (ep -.- p)
-
-drawAutoDoor :: Wall -> Drawing
-drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] 
-        $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
-                   ,color (dark c) $ line [x,y]
-                   ]
-    where 
-        (x:y:_) = _wlLine wl
-        c = _wlColor wl
-        nm = errorNormalizeV 543 (y -.- x)
-        t = 5 *.* nm
-        n = vNormal t
-        n2 = 3 *.* n
-        layer2 | _wlIsSeeThrough wl = 0
-               | isJust $ wl ^? doorMech = 1
-               | otherwise = 2
-
-autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall
-autoDoorPane trigL n castShad closedPos openPos = AutoDoor
-    { _wlLine = closedPos
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = dim $ yellow
-    , _wlDraw = Nothing
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _wlCastShadow = castShad
-    }
-    where 
-        a = closedPos !! 0
-        b = closedPos !! 1
-        dm w | crsNearLine 40 trigL w 
-                         = flip (foldr changeZonedWall) zoneps
-                           $ over walls (IM.adjust openDoor n) w
-             | otherwise = flip (foldr changeZonedWall') zoneps
-                           $ over walls (IM.adjust closeDoor n) w
-        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}
-                            --deepseq ps $ w & wlLine %~ zipWith mvP ps
-        openDoor = moveToward openPos
-        closeDoor = moveToward closedPos
-        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
-               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
-        changeZonedWall (!x,!y) 
-              = over wallsZone $ adjustIMZone openDoor x y n
-        changeZonedWall' (!x,!y) 
-              = over wallsZone $ adjustIMZone closeDoor x y n
 
 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 

src/Dodge/LevelGen/AutoDoor.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE BangPatterns #-}
+module Dodge.LevelGen.AutoDoor
+    where
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+
+import Geometry
+import Picture
+
+import Data.List
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+
+import Control.Lens
+import Control.DeepSeq (deepseq)
+
+addAutoDoor :: Point2 -> Point2 -> World -> World
+addAutoDoor a b = over walls (autoDoorAt a b)
+
+autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
+    where i = newKey wls
+          is = [i..]
+
+mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
+mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
+                               xs
+                               [ True
+                               , False
+                               , True
+                               , True
+                               , False
+                               , True
+                               ]
+                               [ [pld,hwd,hw,pl]
+                               , [hwd,hwu]
+                               , [hwu,plu,pl,hw]
+                               , [pru,hwu,hw,pr]
+                               , [hwu,hwd]
+                               , [hwd,prd,pr,hw]
+                               ]
+                               [ [plld,pld,pl,pl]
+                               , [pld,plu]
+                               , [plu,pllu,pl,pl]
+                               , [prru,pru,pr,pr]
+                               , [pru,prd]
+                               , [prd,prrd,pr,pr]
+                               ]
+    where norm = 15.1 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
+                    -- .1 hack, there was flickering
+          hw = 0.5 *.* (pl +.+ pr)
+          parallel = 20 *.* normalizeV (pl -.- pr)
+          plu = pl +.+ norm
+          pld = pl -.- norm
+          pru = pr +.+ norm
+          prd = pr -.- norm
+          hwu = hw +.+ norm
+          hwd = hw -.- norm
+          pllu = plu +.+ parallel
+          plld = pld +.+ parallel
+          prru = pru -.- parallel
+          prrd = prd -.- parallel
+          addSound (x:xs) = f x : xs
+          f wl = over doorMech g wl
+          g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 
+                                                                    $ dm w
+                 | otherwise = dm w
+            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
+
+drawAutoDoor :: Wall -> Drawing
+drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] 
+        $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
+                   ,color (dark c) $ line [x,y]
+                   ]
+    where 
+        (x:y:_) = _wlLine wl
+        c = _wlColor wl
+        nm = errorNormalizeV 543 (y -.- x)
+        t = 5 *.* nm
+        n = vNormal t
+        n2 = 3 *.* n
+        layer2 | _wlIsSeeThrough wl = 0
+               | isJust $ wl ^? doorMech = 1
+               | otherwise = 2
+
+autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall
+autoDoorPane trigL n castShad closedPos openPos = AutoDoor
+    { _wlLine = closedPos
+    , _wlID = n
+    , _doorMech = dm
+    , _wlColor = dim $ yellow
+    , _wlDraw = Nothing
+    , _wlSeen = False
+    , _wlIsSeeThrough = False
+    , _wlCastShadow = castShad
+    }
+    where 
+        a = closedPos !! 0
+        b = closedPos !! 1
+        dm w | crsNearLine 40 trigL w 
+                         = flip (foldr changeZonedWall) zoneps
+                           $ over walls (IM.adjust openDoor n) w
+             | otherwise = flip (foldr changeZonedWall') zoneps
+                           $ over walls (IM.adjust closeDoor n) w
+        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}
+                            --deepseq ps $ w & wlLine %~ zipWith mvP ps
+        openDoor = moveToward openPos
+        closeDoor = moveToward closedPos
+        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
+        changeZonedWall (!x,!y) 
+              = over wallsZone $ adjustIMZone openDoor x y n
+        changeZonedWall' (!x,!y) 
+              = over wallsZone $ adjustIMZone closeDoor x y n

src/Dodge/LevelGen/Pathing.hs

@@ -0,0 +1,29 @@
+module Dodge.LevelGen.Pathing
+    where
+import Geometry
+
+import Control.Lens
+
+import Dodge.Data
+import Dodge.Base
+
+import Data.Maybe
+import Data.List
+
+import qualified Data.IntMap as IM
+import Data.Graph.Inductive hiding ((&))
+import Data.Graph.Inductive.NodeMap
+
+pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
+pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
+                           pairs' = map (\(x,y)->(x,y,f x y)) pairs
+                       in  undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
+
+removePathsCrossing :: Point2 -> Point2 -> World -> World
+removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
+                            $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+                            w
+    where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          newGraph = pairsToGraph dist pg'
+

src/Dodge/Rooms.hs

@@ -48,7 +48,7 @@ lev1 = do
 --            [randomiseLinks =<< pistolerRoom] 
             [return $ return $ Right deadEndRoom
             ]
-            ++ [roomMiniIntro]
+            ++ [slowDoorRoom]
             ++ [return $ connectRoom corridor
                ,return $ connectRoom door]
 --            ++ [randomiseLinks =<< longRoom]
@@ -711,7 +711,8 @@ slowDoorRoom = do
      xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
      ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
      let crits = zipWith (\p r -> PS p r randC1) ps rs
-         lsources = [PS (x/2,30) 0 basicLS, PS (x/2,y-30) 0 basicLS]
+         --lsources = [PS (x/2,30) 0 basicLS, PS (x/2,y-30) 0 basicLS]
+         lsources = [PS (x/2,y-30) 0 basicLS]
      let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
      let pillarsa = []
      let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)

src/Dodge/Weapons.hs

@@ -109,7 +109,7 @@ autoGun = defaultGun
     , _wpReloadTime = 80
     , _wpReloadState = 0
 --    , _wpFireRate = 6
-    , _wpFireRate = 5
+    , _wpFireRate = 6
     , _wpFireState = 0
     , _wpFire =  autoFireMode
     , _wpSpread = autogunSpread
@@ -383,7 +383,7 @@ hvAutoGun = autoGun
     , _wpReloadState = 0
     , _wpFireRate = 25
     , _wpFireState = 0
-    , _wpFire = rateIncAB 24 12 (torqueBeforeForced 0.1 mkHvBul)
+    , _wpFire = rateIncAB 24 10 (torqueBeforeForced 0.1 mkHvBul)
                                 $torqueAfter  0.2 mkHvBul
     , _wpSpread = autogunSpread
     , _wpRange = 20