Add procedural room made up of four corners

src/Dodge/Room/Procedural.hs

@@ -9,14 +9,18 @@ module Dodge.Room.Procedural
 import Dodge.Room.Data
 import Dodge.Room.Placement
 import Dodge.Room.Link
+import Dodge.RandomHelp
 import Dodge.LevelGen
 import Dodge.LevelGen.Data
+import Dodge.Creature
 import Geometry
 
 import Data.List (nub,nubBy,sortBy)
 import Data.Function (on)
---import Control.Monad.State
---import System.Random
+import Control.Lens
+import Control.Monad
+import Control.Monad.State
+import System.Random
 {-
 A simple rectangular room with a light in the center.
 Creates links and pathfinding graph.
@@ -82,21 +86,120 @@ combineRooms r r' = Room
     , _rmBound = convexHull . nubBy (\a b -> dist a b < 5) $ _rmBound r ++ _rmBound r'
     }
 
-northSegment :: Room
-northSegment = Room
-    { _rmPolys  = [ [(0,0),(200,200),(-200,200)] ]
-    , _rmLinks  = [((0,200), 0)]
-    , _rmPath   = [((0,200),(0,0)),((0,0),(0,200))]
-    , _rmPS     = [PS (0,100) 0 putLamp]
-    , _rmBound  = [(200,200),(-200,200)]
-    --, _rmBound  = []
+{-
+The top fourth of a room of a given height.
+-}
+fourth 
+    :: Float -- ^ Distance from center of room to top edge
+    -> Room
+fourth w = Room
+    { _rmPolys  = [ [(0,0),(w,w),(-w,w)] ]
+    , _rmLinks  = [((0,w), 0)]
+    , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
+    , _rmPS     = 
+        [PS (0,w/2) 0 putLamp
+        ]
+    , _rmBound  = [(w,w),(-w,w)]
     }
 
-testRoom :: Room
-testRoom = foldr1 combineRooms $ map (\a -> shiftRoomBy ((0,0),a) northSegment) [0,pi/2,pi,3*pi/2]
+{-
+Randomly generate a top fourth of a room possibly with a wall.
+Add a light and a 'PutNothing' placement.
+-}
+fourthWall :: RandomGen g => Float -> State g Room
+fourthWall w = do
+    b <- takeOne 
+        --[   [ PS (20-w,w-40) 0  putLamp
+        --    , PS (w-20,w-40) pi PutNothing
+        --    ]
+--        [   [ PS (20-w,w-40) 0  putLamp
+--            , PS (0,40)      0  putLamp
+--            , PS (w-20,w-40) pi PutNothing
+--            , blockLine (w/2,w) (negate $ w/2,w/2)
+--            ]
+        [   [ PS (20-w,w-40) 0  putLamp
+            , PS (0,40)      0  putLamp
+            , PS (w-20,w-20) pi PutNothing
+            , blockLine (w/2,w/2) (w/2,w)
+            ]
+        ,   [ PS (20-w,w-40) 0  putLamp
+            , PS (0,40)      0  putLamp
+            , PS (w-20,w-20) pi PutNothing
+            , blockLine (w/2,w/2) (negate $ w/2,w/2)
+            ]
+        ,   [ PS (20-w,w-40) 0  putLamp
+            , PS (0,20)      0  putLamp
+            , PS (w-20,w-20) pi PutNothing
+            , blockLine (w/2,w/2) (0,w/2)
+            , blockLine (-29,w) (0,w/2)
+            ]
+        ]
+    pure $ Room
+        { _rmPolys  = [ [(0,0),(w,w),(-w,w)] ]
+        , _rmLinks  = [((0,w), 0)]
+        , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
+        , _rmPS     = b
+        , _rmBound  = [(w,w),(-w,w)]
+        }
+
+fourthCorner :: Float -> Room
+fourthCorner w = Room
+    { _rmPolys  = [ [(0,0),(w,w),(0,2*w),(-w,w)] ]
+    , _rmLinks  = 
+        [((w/2,3*w/2), negate $ pi/4)
+        ,((negate $ w/2,3*w/2), pi/4)
+        ]
+    , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
+    , _rmPS     = [PS (0,w) 0 putLamp]
+    , _rmBound  = [(w,w),(0,2*w),(-w,w)]
+    }
+
+fourthCornerWall :: RandomGen g => Float -> State g Room
+fourthCornerWall w = do
+    let l = w/2 - 30
+    b <- takeOne 
+        [   [blockLine (5,5) (w-50,w-50)
+            ,PS (0,w) 0 putLamp
+            ,PS (0,w-30) 0 PutNothing
+            ]
+        ,   [blockLine (0,5) (0,2*w-60)
+            ,PS (-50,w) 0 putLamp
+            ,PS (50,w) 0 PutNothing
+            ]
+        ,   [blockLine (50,50) (w,w)
+            ,PS (0,w) 0 putLamp
+            ,PS (w-40,w) (pi/4) PutNothing
+            ]
+        ,   [blockLine (40-l,l+40) (w-l,l+w)
+            ,PS (0,w) 0 putLamp
+            ,PS (w-40,0) (pi/8) PutNothing
+            ]
+        ]
+    pure $ Room
+        { _rmPolys  = [ [(0,0),(w,w),(0,2*w),(-w,w)] ]
+        , _rmLinks  = 
+            [((w/2,3*w/2), negate $ pi/4)
+            ,((negate $ w/2,3*w/2), pi/4)
+            ]
+        , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
+        , _rmPS     = b
+        , _rmBound  = [(w,w),(0,2*w),(-w,w)]
+        }
+
+fillNothingPlacement :: PSType -> Room -> Room
+fillNothingPlacement pst r =
+    r & rmPS %~ replaceNothingWith pst
+  where
+    replaceNothingWith x (PS p rot PutNothing: pss) = PS p rot x : pss
+    replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
+    replaceNothingWith _ [] = []
+
+testRoom :: RandomGen g => State g Room
+testRoom = do
+    corners <- replicateM 4 . join $ takeOne [fourthWall 100] --, fourthCornerWall 100]
+--    corners <- replicateM 4 (fourthCornerWall 100)
+    randomiseAllLinks 
+        . fillNothingPlacement (PutCrit chaseCrit)
+        . foldr1 combineRooms 
+        $ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
 
----- -- -{- Combines multiple rooms into one room.
----- -- -Combines into one big poly and one big bound, and concatenates the rest.
----- -- --}
----- -- -combineRooms :: [Room] -> Room
----- -- -combineRooms rs = foldr f