Simplify and unify block placement

2021-03-27 02:18:37 +01:00
parent 32376022cc
commit 151fa5b6bd
8 changed files with 198 additions and 187 deletions
@@ -0,0 +1,57 @@
+module Dodge.LevelGen.LineBlock
+    (putLineBlock
+    )
+    where
+import Dodge.Data
+import Dodge.Base
+import Dodge.LevelGen.Pathing
+
+import Picture
+import Geometry
+
+import Control.Lens
+
+import qualified Data.IntMap as IM
+
+-- taken from online, splits a list into its even and odd elements
+evenOddSplit = foldr f ([],[])
+    where f a (ls,rs) = (rs, a : ls)
+
+putLineBlock :: Wall -> Float -> Float -> Point2 -> Point2 -> World -> World
+putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
+  where 
+    d = dist a b
+    rot = argV (b -.- a)
+    psOnLine = divideLineOddNumPoints blockWidth a b
+    halfBlockWidth = d / (fromIntegral $ length psOnLine - 1)
+    blockCenPs = snd $ evenOddSplit psOnLine
+    numBlocks = length blockCenPs
+    is = [0.. numBlocks - 1]
+    cornerPoints = [(-halfBlockWidth,-depth)   -- goes anticlockwise around the block
+                   ,(-halfBlockWidth, depth)
+                   ,( halfBlockWidth, depth)
+                   ,( halfBlockWidth,-depth)
+                   ]
+    cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
+    linesAt p = map (\(a,b) -> [a,b]) $ makeLoopPairs $ cornersAt p
+    k = newKey $ _walls w
+    ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
+    visibilityAt i | i == 0             = [ True,True,False,True]
+                   | i == numBlocks - 1 = [False,True, True,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)
+    makeBlockAt :: Point2 -> Int -> [Wall]
+    makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
+    makePane i visStatus k' ps 
+          = basePane {_wlID = k'
+                     ,_wlLine = ps
+                     ,_blIDs = ksAtI i
+                     ,_blShadows = shadowsAt i
+                     ,_blVisible = visStatus
+                     }
+    listBlocks = concat $ zipWith makeBlockAt blockCenPs is
+    insertBlock :: Wall -> World -> World
+    insertBlock wl = over walls $ IM.insert (_wlID wl) wl
+