Add room foregrounds

src/Dodge/Default/World.hs

@@ -7,11 +7,9 @@ import Dodge.Debug.Flag.Data
 import Dodge.Config.Data
 import Dodge.Config.KeyConfig
 import Dodge.Item.Data
-import Picture
+--import Picture
-import Geometry
+--import Geometry
 --import Picture.Texture
-import Data.Tile
-import Tile
 
 import System.Random
 import qualified Data.IntMap.Strict as IM
@@ -39,23 +37,7 @@ defaultWorld = World
     , _wallsZone = IM.empty
     , _forceFields = IM.empty
     , _floorItems = IM.empty
-    , _floorTiles = tToRender $ Tile
+    , _floorTiles = []
-        { _tilePoly = rectNSWE 200 0 0 200
-        , _tileCenter = (0,0)
-        , _tileX = (100,0)
-        , _tileY = (0,100)
-        , _tileZ = 16
-        } 
---        let x = 200
---            y = 0.9
---            z = 16
---            r = 8
---        in tileToRender [(0,0,z),(r,0,z),(r,r,z),(0,r,z)]
---            [(20,100 + 20,y)
---            ,( x,100 + 20,y)
---            ,( x,100 +  x,y)
---            ,(20,100 +  x,y)
---            ]
     , _randGen = mkStdGen 2
     , _mousePos = (0,0)
     , _testString = []
@@ -95,18 +77,8 @@ defaultWorld = World
     , _debugFlags = defaultDebugFlags
     , _inventoryMode = TopInventory
     , _lClickHammer = HammerUp
-    , _foregroundDecorations = 
+    , _foregroundDecorations = []
-        [ 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
-            ]
-        , setDepth (-0.2) $ rotate 0.75 $ pictures
-            $ map f [5,25,45,65]
-        ]
     }
-  where 
-    f x = polygon $ rectNSEW (x - 20) (x-22) 500 0
 defaultDebugFlags :: DebugFlags
 defaultDebugFlags = DebugFlags
     { _noClip = False

src/Dodge/Layout/Tree/Annotate.hs

@@ -16,6 +16,7 @@ import Dodge.Room.Treasure
 import Dodge.Room.Link
 import Dodge.Room.Data
 import Dodge.Room.Airlock
+import Dodge.Room.Start
 import Dodge.Room
 import Dodge.Room.Teleport
 
@@ -80,10 +81,7 @@ annoToRoomTree [FirstWeapon] = do
     blockedC <- longBlockedCorridor
     join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
 annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
-annoToRoomTree [StartRoom] = do
+annoToRoomTree [StartRoom] = startRoom
-    w <- state $ randomR (100,400)
-    h <- state $ randomR (200,400)
-    pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
 annoToRoomTree (SpecificRoom rt:_) = rt
 annoToRoomTree (BossAno cr : _) = do
     br <- bossRoom cr

src/Dodge/LevelGen.hs

@@ -81,6 +81,7 @@ placeSpot ps w = case _psType ps of
     PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
+    PutBlock _ _ _ -> error "messed up block placement somehow"
     PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                             (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) 
@@ -91,7 +92,10 @@ placeSpot ps w = case _psType ps of
       where 
         (q:qs) = map (shiftPointBy (p,rot)) ps'
         rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
-    _   -> w
+    PutForeground pic -> w & foregroundDecorations %~ (uncurry translate p (rotate rot pic) :)
+    PutNothing -> w
+    PutID _ -> w
+    --_   -> w
   where 
     p = _psPos ps
     rot = _psRot ps

src/Dodge/LevelGen/Data.hs

@@ -22,6 +22,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutBtDoor Color Point2 Float Point2 Point2
     | PutSwitchDoor Color Point2 Float Point2 Point2
     | RandPS (State StdGen PSType)
+    | PutForeground Picture
     | PutNothing
     | PutID { _putID :: Int}
 data PlacementSpot = PS

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