Add more rooms

src/Dodge/Placement/Instance/LightSource.hs

@@ -161,6 +161,12 @@ spanColLightI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
   where
     V2 x y = 0.5 *.* (a +.+ b)
 
+spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement
+spanColLightBlackI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
+    $ sps0 $ PutShape $ colorSH black $ thinHighBar h a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
 spanLightI :: Point2 -> Point2 -> Placement
 spanLightI = spanColLightI 0.75 50
 

src/Dodge/Room/Containing.hs

@@ -21,11 +21,11 @@ roomsContaining crs its = tToBTree "roomsContaining" <$> roomsContaining' crs it
 roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
 roomsContaining' crs its = do
     endroom <- join $ takeOne
-        [roomPillarsSquare
+        [ roomPillarsSquare <&> rmPmnts .++~ crsItmsUnused crs its
---        [ randomFourCornerRoomCrsIts crs its 
+        , randomFourCornerRoomCrsIts crs its 
---        , tanksRoom crs its
+        , tanksRoom crs its
---        , roomPillarsContaining crs its
+        , roomPillarsContaining crs its
---        , roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its
+        , roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its
         ]
     return (pure $ cleatOnward endroom)
 

src/Dodge/Room/Pillar.hs

@@ -1,4 +1,5 @@
 module Dodge.Room.Pillar where
+import Dodge.Placement.Instance.LightSource
 import Dodge.Data
 import Dodge.Cleat
 import Dodge.PlacementSpot
@@ -10,9 +11,10 @@ import Dodge.Room.Procedural
 import Dodge.Room.Link
 import Geometry
 import LensHelp
+import RandomHelp
 
-import Control.Monad.State
+--import Control.Monad.State
-import System.Random
+--import System.Random
 import qualified Data.Set as S
 
 blockPillar :: Float -> Float -> Placement
@@ -42,12 +44,27 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
 
 roomPillarsSquare :: RandomGen g => State g Room
 roomPillarsSquare = do
-    h <- state $ randomR (300,300)
+    let rm' = roomRectAutoLinks 300 300
-    w <- state $ randomR (300,400)
+        nlew = _numLinkEW (_rmType rm')
-    let rm = roomRectAutoLinks w h
+        nlns = _numLinkNS (_rmType rm')
-        nlew = _numLinkEW (_rmType rm)
+    addlights <- takeOne 
-        nlns = _numLinkNS (_rmType rm)
+        [ return . set rmPmnts [mntLS vShape 
-    return $ rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South,North]
+            (rotateVAround (V2 150 150) a (V2 30 30)) 
+            (onXY (rotateVAround (V2 150 150) a) $ V3 60 60 95) 
+                | a <- [0,pi/2,pi,3*pi/2] ]
+        , return . set rmPmnts [mntLS vShape 
+            (rotateVAround (V2 150 150) a (V2 150 0)) 
+            (onXY (rotateVAround (V2 150 150) a) $ V3 150 20 95) 
+                | a <- [0,pi/2,pi,3*pi/2] ]
+        , addGirderLights . set rmPmnts []
+        , return . (rmPmnts .++~ 
+                [ spanColLightBlackI 0.75 95 (V2 0 130) (V2 300 130)
+                , spanColLightBlackI 0.75 95 (V2 0 170) (V2 300 170)
+                ,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
+                ] )
+        ]
+    rm <- addlights rm'
+    shuffleLinks $ rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South,North]
         ++ concatMap (replicate nlns . makepill) [East,West]
   where
     makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar

src/Dodge/Room/Procedural.hs

@@ -72,7 +72,6 @@ roomRect x y xn yn = defaultRoom
         }
     }
   where 
-    roomposat onoffpath p = RoomPos p 0 (S.singleton onoffpath) NotLink 0
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
     somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
@@ -96,8 +95,6 @@ roomRect x y xn yn = defaultRoom
         ]
     posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (xn+1)
     interposps' = map (over _1 (+.+ V2 (20 + xd/2) (20 + yd/2))) $ gridPoints'' xd xn yd yn
-    posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1)
-    interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn
     makeoffpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0
     makerpedges' (a,b) = S.fromList 
         [PathFromEdge South b

src/Geometry/Vector.hs

@@ -90,6 +90,9 @@ rotateV r (V2 x y) = V2
     (x * cos r - y * sin r)
     (x * sin r + y * cos r)
 {-# INLINE rotateV #-}
+rotateVAround :: Point2 -> Float -> Point2 -> Point2
+rotateVAround p r q = rotateV r (q -.- p) +.+ p
+{-# INLINE rotateVAround #-}
 -- | Convert degrees to radians
 degToRad :: Float -> Float
 degToRad d = d * pi / 180