Refactor window block

2021-03-23 03:25:35 +01:00
parent 257e60e4e8
commit afb3d8a712
16 changed files with 151 additions and 883 deletions
@@ -1,10 +1,15 @@
 module Dodge.LevelGen.WindowBlock
-    (
+    (putWindowBlock'
    )
    where
 import Dodge.Data
+import Dodge.Base
+import Dodge.LevelGen.Pathing

 import Picture
+import Geometry
+
+import Control.Lens

 import qualified Data.IntMap as IM

@@ -23,3 +28,98 @@ basePane = Block
    , _blDegrades = [5,5]
    }
 --singleBlock :: [Int] -> IM.IntMap Wall
+
+-- taken from online, splits a list into its even and odd elements
+evenOddSplit = foldr f ([],[])
+    where f a (ls,rs) = (rs, a : ls)
+
+putWindowBlock :: Point2 -> Point2 -> World -> World
+putWindowBlock a b w = removePathsCrossing a b $ foldr (makeBlockAt bSide) w $ zip ps ns
+    where d = dist a b
+          rot = argV (b -.- a)
+          numPoints = 2 * floor (d / 20)
+          ns = take (numPoints+1) [0..]
+          ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) 
+                   $ map fromIntegral ns
+          bSide = d / (fromIntegral numPoints)
+          makeBlockAt :: Float -> (Point2,Int) -> World -> World
+          makeBlockAt bSide (p,i) w = 
+            let k = newKey $ _walls w
+                ds = [(-bSide,-9),(-bSide,9),(bSide,9),(bSide,-9)]
+                polyAtP p = map ((+.+) p . rotateV rot) ds
+                ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
+                (k0:k1:k2:k3:_) = ksAtN i
+                (bl:tl:tr:br:_) = polyAtP p
+                shadows | i == 0 = ksAtN 1
+                        | i == numPoints - 1 = ksAtN $ numPoints - 2
+                        | otherwise = ksAtN (i-1) ++ ksAtN (i+1)
+                seen | even i    = True
+                     | otherwise = False
+                isLeftmost | i == 0 = True
+                           | otherwise = False
+                isRightmost | i == numPoints = True
+                            | otherwise = False
+                l = baseBlock 
+                        { _wlLine = [bl,tl]
+                        , _wlID = k0
+                        , _blVisible = isLeftmost
+                        }
+                t = baseBlock 
+                        { _wlLine = [tl,tr]
+                        , _wlID = k1
+                        , _blVisible = seen
+                        }
+                r = baseBlock 
+                        { _wlLine = [tr,br]
+                        , _wlID = k2
+                        , _blVisible = isRightmost
+                        }
+                b = baseBlock 
+                        { _wlLine = [br,bl]
+                        , _wlID = k3
+                        , _blVisible = seen
+                        }
+                baseBlock = basePane
+                        { _blIDs = ksAtN i
+                        , _blShadows = shadows
+                        }
+                f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
+            in  over walls f w
+
+putWindowBlock' :: Point2 -> Point2 -> World -> World
+putWindowBlock' a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
+    where d = dist a b
+          rot = argV (b -.- a)
+          psOnLine = divideLineOddNumPoints 9 a b
+          halfBlockWidth = d / (fromIntegral $ length psOnLine - 1)
+          blockCenPs = snd $ evenOddSplit psOnLine
+          numBlocks = length blockCenPs
+          is = [0.. numBlocks - 1]
+          cornerPoints = [(-halfBlockWidth,-9)   -- goes anticlockwise around the block
+                         ,(-halfBlockWidth, 9)
+                         ,( halfBlockWidth, 9)
+                         ,( halfBlockWidth,-9)
+                         ]
+          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 - 1
+                      | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
+          makeBlockAt :: Point2 -> Int -> [Wall]
+          makeBlockAt p i = zipWith3 (makePane i) (ksAtI i) (visibilityAt i) (linesAt p)
+          makePane i k' visStatus 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
+