Add procedural room made up of four corners

src/Dodge/Creature/Inanimate.hs

@@ -22,7 +22,8 @@ lamp :: Creature
 lamp = defaultInanimate
     { _crUpdate = initialiseLamp
     , _crHP = 500
-    , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 10
+    , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 5
+    , _crRad = 5
     }
 
 initialiseLamp :: CRUpdate

src/Dodge/Floor.hs

@@ -32,7 +32,7 @@ roomTreex :: RandomGen g => State g (Maybe [Room])
 roomTreex = do
     struct' <- aTreeStrut
 --    let struct = treePost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
-    let struct = treePost [[SpecificRoom $ fmap (pure . Right) $ pure testRoom]] [EndRoom]
+    let struct = treePost [[SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom]
     let t' = padCorridors struct
         t = treeTrunk 
                 [[StartRoom]

src/Dodge/RandomHelp.hs

@@ -1,5 +1,7 @@
+{-
+Helpers for random generation.
+-}
 module Dodge.RandomHelp where
-
 import Geometry
 import Geometry.Data
 
@@ -9,7 +11,8 @@ import Data.List
 
 randomRanges :: (Random a,RandomGen g) => [a] -> State g a
 randomRanges xs = join $ takeOne $ f xs
-    where f (x:y:ys) = (state (randomR (x,y))) : (f ys)
+  where 
+    f (x:y:ys) = (state (randomR (x,y))) : (f ys)
     f  _ = []
 
 takeOne :: RandomGen g => [a] -> State g a
@@ -18,7 +21,9 @@ takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i))
 takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a
 takeOneWeighted ws xs = state (randomR (0, sum ws))
                             >>= (\w -> return (xs !! (i w ws)))
-    where i y (z:zs) | y <= z = 0
+  where 
+    i y (z:zs) 
+        | y <= z = 0
         | otherwise = 1 + i (y-z) zs
     i y _ = 0
 

src/Dodge/Room.hs

@@ -128,8 +128,8 @@ roomPillars :: Room
 roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
   where 
     plmnts = PS (120,120) 0 putLamp 
-        : PS (10,10) 0 putLamp 
+        : PS (12,12) 0 putLamp 
-        : PS (230,230) 0 putLamp 
+        : PS (228,228) 0 putLamp 
         : g 180 150 90 60
     f a x b y = putBlockRect a x b y
     g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d

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 Control.Lens
---import System.Random
+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
+The top fourth of a room of a given height.
-    { _rmPolys  = [ [(0,0),(200,200),(-200,200)] ]
+-}
-    , _rmLinks  = [((0,200), 0)]
+fourth 
-    , _rmPath   = [((0,200),(0,0)),((0,0),(0,200))]
+    :: Float -- ^ Distance from center of room to top edge
-    , _rmPS     = [PS (0,100) 0 putLamp]
+    -> Room
-    , _rmBound  = [(200,200),(-200,200)]
+fourth w = Room
-    --, _rmBound  = []
+    { _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