Split autodoor module

2021-03-06 13:12:18 +01:00
parent e9eed18666
commit 36bccebed9
6 changed files with 164 additions and 115 deletions
@@ -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
@@ -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'
+