Add room foregrounds

src/Dodge/Room/Foreground.hs

@@ -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)

src/Dodge/Room/Start.hs

@@ -0,0 +1,29 @@
+module Dodge.Room.Start
+    where
+import Dodge.Room.Data
+import Dodge.Room.Link
+import Dodge.Room.Procedural
+import Dodge.Room.Foreground
+import Dodge.LevelGen.Data
+import Picture
+--import Geometry
+
+import Data.Tree
+import Control.Monad.State
+import Control.Lens
+import System.Random
+
+startRoom :: RandomGen g => State g (Tree (Either Room Room))
+startRoom = do
+    w <- state $ randomR (100,400)
+    h <- state $ randomR (200,400)
+    let fground = sPS (0,0) 0 $ PutForeground $ pictures
+            [ highDiagonalMesh (0,0) (0,h) w 25
+            --, setDepth (-0.1) $ color orange $ pictures
+            --    [ polygon $ rectNSEW 50 40 140 (-20)
+            --    , translate 60 45 $ scale 0.5 1 $  thickArc 0 pi 75 10
+            --    , translate (-20) 300 $ polygon $ rectNSEW 10 0 40 0
+            --    ]
+            , highDiagonalMesh (w,0) (0,0) h 25
+            ]
+    pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))