Add room foregrounds

2021-06-16 18:18:03 +02:00
parent 29902b6f22
commit 04ed034a3e
6 changed files with 84 additions and 37 deletions
@@ -0,0 +1,43 @@
+module Dodge.Room.Foreground
+    where
+import Picture
+import Geometry
+import Geometry.Data
+
+import Data.List
+import Data.Maybe
+
+highDiagonalMesh
+    :: Point2 
+    -> Point2 
+    -> Float    -- ^ width
+    -> Float    -- ^ vertical distance between lines
+    -> Picture
+highDiagonalMesh pa pb w d = setDepth (-0.2) $ pictures $
+    (map (flip thickLine 1 . flat2) $ diagonalLinesRect pb pa w d (pi/4))
+    ++ 
+    (map (flip thickLine 1 . flat2) $ diagonalLinesRect pa pc h d (3* pi/4))
+  where
+    pc = pa +.+ w *.* normalizeV (vNormal (pb -.- pa))
+    h = dist pa pb
+
+diagonalLinesRect 
+    :: Point2 
+    -> Point2 
+    -> Float    -- ^ width
+    -> Float    -- ^ vertical distance between lines
+    -> Float
+    -> [(Point2,Point2)]
+diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
+  where
+    xVec = negate w *.* vNormal (normalizeV $ pb -.- pa)
+    diVec = rotateV ang xVec
+    pax = pa +.+ xVec
+    pbx = pb +.+ xVec
+    lhsPoints = divideLine d (pa -.- yN) (pb +.+ yN)
+    findDiPoint p = head . sortOn (dist p) $ catMaybes 
+        [intersectLineLine' p (p +.+ diVec) pax pbx
+        ,intersectSegLine' pa pax p (p +.+ diVec)
+        ,intersectSegLine' pb pbx p (p +.+ diVec)
+        ]
+    yN = d * 0.5 *.* (normalizeV $ pa -.- pb)