Cleanup: broken pathfinding

2021-11-16 18:05:47 +00:00
parent cb8cbe03a4
commit ebe9ad6b90
42 changed files with 491 additions and 301 deletions
@@ -0,0 +1,108 @@
+{- | Creation, update and destruction of destructible walls.  -}
+module Dodge.Placement.PlaceSpot.Block 
+    ( placeBlock
+    , placeLineBlock
+    )
+    where
+import Dodge.Data
+import Dodge.Path
+import Dodge.Base
+import Dodge.Zone
+import Dodge.Default.Wall
+import Geometry
+import qualified IntMapHelp as IM
+import Color
+
+import Control.Lens
+import Data.List
+import qualified Data.IntSet as IS
+
+addBlock 
+    :: [Point2]     -- ^ Block polygon
+    -> Int          -- ^ First layer of health
+    -> Color 
+    -> Opacity         -- ^ Is the block see through?
+    -> [Int]        -- ^ Extra layers of health
+    -> World 
+    -> World
+addBlock (p:ps) hp col opacity hps w 
+    | hp <= 0 && null hps = w
+    | hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (tail hps) w
+    | otherwise = w
+        & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
+        & walls  %~ IM.union panes
+        & blocks %~ IM.insert blid (Block {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[]})
+  where 
+    blid = IM.newKey $ _blocks w
+    lns = zip (p:ps) (ps ++ [p])
+    i = IM.newKey $ _walls w
+    is = [i.. i + length lns-1]
+    panes = IM.fromList $ zipWith 
+        (\j (a,b) -> (,) j defaultWall 
+            { _wlLine = (a,b)
+            , _wlID = j
+            , _wlColor = col
+            , _wlOpacity = opacity
+            , _wlStructure = BlockPart blid
+            , _wlFireThrough = True
+            }
+        ) is lns
+    wallInZone wl 
+        | uncurry dist (_wlLine wl) <= 2*zoneSize 
+            = insertIMInZone x y wlid wl
+        | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl)) ips
+      where 
+        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
+        wlid  = _wlID wl
+        ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
+addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
+        
+placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> World -> (Int,World)
+placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+  where 
+    pairs = loopPairs poly
+    wWithBlock = addBlock poly i c opac is w
+
+{- | Splits a line into many four cornered blocks. -}
+placeLineBlock 
+    :: Wall     -- ^ Base pane
+    -> Float    -- ^ Block width
+    -> Float    -- ^ Block depth
+    -> Point2   -- ^ Start point (symmetric)
+    -> Point2   -- ^ End point (symmetric)
+    -> World 
+    -> (Int, World)
+placeLineBlock basePane blockWidth depth a b w = (,) 0 
+    $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
+  where 
+    psOnLine = divideLineOddNumPoints blockWidth a b
+    halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
+    blockCenPs = snd $ evenOddSplit psOnLine
+    numBlocks = length blockCenPs
+    is = [0.. numBlocks - 1]
+    cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
+    cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
+    linesAt p = loopPairs $ cornersAt p
+    wlid = IM.newKey $ _walls w
+    blid = IM.newKey $ _blocks w
+    insertBlock i = over blocks $ IM.insert (i+blid) Block 
+        {_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
+    insertBlocks = flip (foldr insertBlock) is
+    ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
+    visibilityAt i 
+        | i == 0             = [False,True,True ,True]
+        | i == numBlocks - 1 = [True ,True,False,True]
+        | otherwise          = [False,True,False,True]
+    shadowsAt i
+        | i == 0             = ksAtI 1
+        | i == numBlocks - 1 = ksAtI $ numBlocks - 2
+        | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
+    makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
+    makePane i visStatus k ps = basePane
+        {_wlID = k
+        ,_wlStructure = BlockPart $ i + blid
+        ,_wlLine = ps
+        ,_wlDraw = visStatus
+        }
+    listWalls = concat $ zipWith makeWallAt blockCenPs is
+    insertWall wl = over walls $ IM.insert (_wlID wl) wl