Function for adding random lights to roomNGon

src/Dodge/Data/GenWorld.hs

@@ -100,6 +100,8 @@ data PlacementSpot
     | PSNoShiftCont {_psPos :: Point2, _psRot :: Float}
     | PSPos
         { _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
+        -- looks for the first rp for which a rp rm returns Just (ps,rp'),
+        -- replaces the rp with rp'
         , _psRoomEff :: RoomPos -> Room -> Room
         , _psFallback :: Maybe Placement
         }
@@ -138,7 +140,7 @@ data Room = Room
     , _rmPos :: [RoomPos]
     , _rmPath :: S.Set (Point2, Point2)
     , _rmPmnts :: [Placement]
-    , _rmInPmnt :: [(Int,GenWorld -> Placement)]  -- so far as I can tell,
+    , _rmInPmnt :: [(Int,GenWorld -> State StdGen Placement)]  -- so far as I can tell,
         -- the first Int only determines the order in which these are applied
     , _rmBound :: [[Point2]]
     , _rmFloor :: Floor
@@ -162,3 +164,12 @@ makeLenses ''RoomType
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
+
+-- I may regret this. I believe it satisfies associativity, but haven't thought
+-- about it too much.
+instance Semigroup Placement where
+    p <> q = p & plIDCont %~ f
+      where
+        f g gw pl = case g gw pl of
+            Nothing -> Just q
+            Just r -> Just $ r & plIDCont %~ f

src/Dodge/Data/Room.hs

@@ -38,6 +38,10 @@ data RoomType
         , _rmWidth :: Float
         , _rmHeight :: Float
         }
+    | RoomNgon
+        { _rmngonSides :: Int 
+        , _rmngonSize :: Float
+        }
     deriving (Eq, Ord)
 
 data RoomLinkType
@@ -81,6 +85,7 @@ data RoomPosFlag
     = RoomPosOnGrid {_onGridFromEdges :: S.Set PathFromEdge}
     | RoomPosOffGrid {_offGridFromEdges :: S.Set PathFromEdge}
     | RoomPosOnFloor
+    | ColoredLightRP
     deriving (Eq, Ord, Show)
 
 data UsedPos

src/Dodge/Floor.hs

@@ -25,7 +25,7 @@ initialRoomTree =
     foldMTRS $
         intersperse
             (zoom lyGen doorCor)
-            [ intAnno startRoom
+            [ startRoom
             , passthroughLockKeyLists
                     [(sensorRoomRunPast ElectricSensor, takeOne 
                         [-- CRAFT (ENERGYBALLCRAFT TeslaBall) , 

src/Dodge/Layout.hs

@@ -1,25 +1,27 @@
 {-# LANGUAGE TupleSections #-}
+
 module Dodge.Layout (
     generateLevelFromRoomList,
     tilesFromRooms,
     shuffleRoomPos,
 ) where
 
-import qualified Data.Vector.Unboxed as UV
---import Dodge.Path.Translate
+-- import Dodge.Path.Translate
 import qualified Control.Foldl as L
 import Control.Lens
 import Data.Foldable
 import Data.Function
---import Data.Graph.Inductive (labEdges, labNodes)
-import Data.List (nubBy,sortOn)
+import Linear
+-- import Data.Graph.Inductive (labEdges, labNodes)
+import Data.List (nubBy, sortOn)
 import Data.Maybe
 import Data.Tile
---import Data.Traversable
+import qualified Data.Vector.Unboxed as UV
+-- import Data.Traversable
 import Dodge.Data.GenWorld
 import Dodge.Default.Wall
 import Dodge.GameRoom
---import Dodge.Item.Location.Initialize
+-- import Dodge.Item.Location.Initialize
 import Dodge.LevelGen.LevelStructure
 import Dodge.LevelGen.StaticWalls
 import Dodge.Path
@@ -37,29 +39,27 @@ generateLevelFromRoomList gr' w =
     over gwWorld initWallZoning
         . over gwWorld randomCompass
         . over gwWorld setupWorldBounds
---        . over (gwWorld . cWorld . lWorld) initItemLocations
         . doInPlacements
---        . doOutPlacements
         . doIndividualPlacements
         . setTiles
         . worldToGenWorld rs'
-        $ w & cWorld . lWorld . walls .~ wallsFromRooms rs
+        $ w
+            & cWorld . lWorld . walls .~ wallsFromRooms rs
             & cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
             & cWorld . incNode .~ inodes
             & cWorld . incGraph .~ igraph
             & cWorld . incEdges .~ ipairs
-            & incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i,p) m) mempty inodes
+            & incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i, p) m) mempty inodes
             & incEdgeZoning .~ foldl' (flip (zoneIncPe inodes)) mempty ipairs
   where
     pairs = snapToGrid $ foldMap _rmPath rs
-    (inodes,igraph,ipairs) = pairsToIncGraph pairs
+    (inodes, igraph, ipairs) = pairsToIncGraph pairs
     rs = map doRoomShift $ IM.elems rs'
     rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
 
-
 randomCompass :: World -> World
-randomCompass w = w 
-    & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
+randomCompass w =
+    w & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
 
 -- note the order of traversal of the rooms is important
 -- hence the reverse
@@ -70,65 +70,61 @@ setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
 setTile :: Room -> GenWorld -> GenWorld
 setTile r gw = case _rmFloor r of
     Tiled{} -> gw
-    InheritFloor -> gw 
-        & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
+    InheritFloor ->
+        gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
   where
     t = case _rmMParent r of
         Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
         Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
-    poly = orderPolygon . convexHullSafe 
-        . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
+    poly =
+        orderPolygon
+            . convexHullSafe
+            . nubBy ((==) `on` roundPoint2)
+            . concat
+            $ _rmPolys r
 
-shuffleRoomPos :: RandomGen g => Room -> State g Room
+shuffleRoomPos :: (RandomGen g) => Room -> State g Room
 shuffleRoomPos = rmPos shuffle
---shuffleRoomPos rm = do
---    newPos <- shuffle $ _rmPos rm
---    return $ rm & rmPos .~ newPos
 
 doInPlacements :: GenWorld -> GenWorld
-doInPlacements w = foldl' (\gw (i,(_,f)) -> placeSpot i gw (f gw)) w
-    . sortOn (fst.snd)
-    $ foldMap g $ w ^. genRooms
+doInPlacements w =
+    foldl' (\gw (i, (_, f)) -> rplaceSpot i gw (f gw)) w
+        . sortOn (fst . snd)
+        . foldMap g
+        $ w ^. genRooms
   where
-    g rm = (rm^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
---    let (gw, rms) = mapAccumR doRoomInPlacements w (_genRooms w)
---     in gw & genRooms .~ rms
-
---doRoomInPlacements :: GenWorld -> Room -> (GenWorld, Room)
---doRoomInPlacements w rm = foldr f (w, rm) $ _rmInPmnt rm
---  where
---    f plf (w', r') =  placeSpot (w', r') (plf w')
+    g rm = (rm ^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
+    rplaceSpot i gw rx = placeSpot i (gw & gwWorld . randGen .~ gen) x
+      where
+        (x,gen) = runState rx (gw ^. gwWorld . randGen)
 
 doIndividualPlacements :: GenWorld -> GenWorld
 doIndividualPlacements gw = foldl' doRoomPlacements gw (_genRooms gw)
 
 doRoomPlacements :: GenWorld -> Room -> GenWorld
-doRoomPlacements w rm = foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty) 
-    . sortOn  plPriority $ _rmPmnts rm
+doRoomPlacements w rm =
+    foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty)
+        . sortOn plPriority
+        $ _rmPmnts rm
   where
     i = rm ^?! rmMID . _Just
 
 plPriority :: Placement -> Int
 plPriority pl = case pl ^. plType of
-    PutChasm {} -> 0 
-    PutBlock {} -> 1
-    PutDoor {} -> 2
+    PutChasm{} -> 0
+    PutBlock{} -> 1
+    PutDoor{} -> 2
     _ -> 3
 
---placeSpot' :: Int -> GenWorld -> Placement -> GenWorld
---placeSpot' = placeSpot
---placeSpot' i gw x = 
---    let (gw',r') = placeSpot (gw,(gw ^?! genRooms . ix i)) x
---    in gw' & genRooms . ix i .~ r'
-
 setupWorldBounds :: World -> World
 setupWorldBounds w =
-    w & cWorld . cwGen . cwgWorldBounds
-        %~ ( (bdMinX .~ f minx)
-                . (bdMaxX .~ f maxx)
-                . (bdMinY .~ f miny)
-                . (bdMaxY .~ f maxy)
-           )
+    w
+        & cWorld . cwGen . cwgWorldBounds
+            %~ ( (bdMinX .~ f minx)
+                    . (bdMaxX .~ f maxx)
+                    . (bdMinY .~ f miny)
+                    . (bdMaxY .~ f maxy)
+               )
   where
     f = fromMaybe 0
     ps = IM.map (fst . _wlLine) $ w ^. cWorld . lWorld . walls -- _walls (_cWorld w)
@@ -162,14 +158,17 @@ gameRoomFromRoom rm =
     GameRoom
         { _grViewpoints =
             map doshift $
-                _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
+                _rmViewpoints rm
+                    ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
                     ++ mapMaybe filterUnusedLinks (_rmPos rm)
         , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
         , _grBound =
-            map doshift $
-                expandPolyCorners 50 . convexHullSafe . nubBy closePoints
+            map doshift
+                $ expandPolyCorners 50
+                    . convexHullSafe
+                    . nubBy closePoints
                     . concat
-                    $ _rmBound rm ++ _rmPolys rm
+                $ _rmBound rm ++ _rmPolys rm
         , _grRmBounds = map (map doshift) $ _rmBound rm
         , _grDir = getDir $ _rmPos rm
         , _grLinkDirs = mapMaybe undir $ _rmPos rm
@@ -180,8 +179,8 @@ gameRoomFromRoom rm =
     doubleShift p a =
         map
             doshift
-            [ p +.+ 10 *.* unitVectorAtAngle a
-            , p -.- 10 *.* unitVectorAtAngle a
+            [ p + 10 *^ unitVectorAtAngle a
+            , p - 10 *^ unitVectorAtAngle a
             ]
     filterUnusedLinks rp = case _rpType rp of
         UnusedLink{} -> Just $ _rpPos rp
@@ -210,36 +209,36 @@ getTiles fl = case fl of
     Tiled xs -> xs
     _ -> error "tiles not correctly set for some room"
 
---divideWall :: Wall -> [Wall]
---divideWall wl
+-- divideWall :: Wall -> [Wall]
+-- divideWall wl
 --    = let (a,b) = _wlLine wl
 --          ps = divideLine (zoneSize * 2) a b
 --      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
 
---divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
---divideWallIn wl wls =
+-- divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
+-- divideWallIn wl wls =
 --    let (wl':newWls) = divideWall wl
 --        k = IM.newKey wls
 --        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
 --    in  foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
 --
---divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
---divideWalls wls = foldl' (flip divideWallIn) wls wls
+-- divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
+-- divideWalls wls = foldl' (flip divideWallIn) wls wls
 
---insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
---insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
+-- insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
+-- insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
 --    where f _ = IM.insert y obj
 
---shiftRoomTree :: Tree Room -> Tree Room
---shiftRoomTree (Node t []) = Node t []
---shiftRoomTree (Node t ts) = Node t
+-- shiftRoomTree :: Tree Room -> Tree Room
+-- shiftRoomTree (Node t []) = Node t []
+-- shiftRoomTree (Node t ts) = Node t
 --    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
 --    (_rmLinks t)
 --    ts
 
---shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
---shiftRoomTreeConstruction (Node t []) = [Node t []]
---shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
+-- shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
+-- shiftRoomTreeConstruction (Node t []) = [Node t []]
+-- shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
 --    zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
 --    (_rmLinks t)
 --    ts
@@ -248,8 +247,8 @@ getTiles fl = case fl of
 --      where
 --        (p,a) = last $ _rmLinks r
 
---addTile :: Float -> Room -> Room
---addTile z r
+-- addTile :: Float -> Room -> Room
+-- addTile z r
 --    | not (null (_rmFloor r)) || null rp = r
 --    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
 --  where

src/Dodge/LockAndKey.hs

@@ -25,9 +25,8 @@ lockRoomMultiItems =
 
 lockRoomKeyItems :: [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
 lockRoomKeyItems =
-    [ (lasCenSensEdge, takeOne [LASER,HELD TESLACOIL, HELD FLATSHIELD])
---    [ (lasCenSensEdge, takeOne [HELD RLAUNCHER, LASER, HELD SPARKGUN, HELD FLATSHIELD])
---    , (sensorRoomRunPast LaserSensor, return LASER)
+--    [ (lasCenSensEdge, takeOne [LASER,HELD TESLACOIL, HELD FLATSHIELD])
+    [ (sensorRoomRunPast LaserSensor, return LASER)
 --    , (const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3))
 --    , (const longRoomRunPast, takeOne [HELD SNIPERRIFLE, HELD FLATSHIELD])
 --    , (const glassLessonRunPast, takeOne [LASER])

src/Dodge/Placement/Instance/LightSource.hs

@@ -181,7 +181,8 @@ spanColLightBlackI col h a b =
     V2 x y = 0.5 *.* (a +.+ b)
 
 spanLightI :: Point2 -> Point2 -> Placement
-spanLightI = spanColLightI 0.75 50.1
+--spanLightI = spanColLightI 0.75 50.1
+spanLightI = spanColLightI 0.75 95
 
 spanLightY :: Point2 -> Point2 -> Point2 -> Point2 -> Placement
 spanLightY l x y z = 
@@ -191,7 +192,7 @@ spanLightY l x y z =
         sps0 $ f z
   where
     f p = putShape $ thinHighBar h p (l + normalize (l-p))
-    h = 50
+    h = 95
 
 --extendAway :: Point2 -> Point2 -> Point2
 --extendAway p x = p +.+ squashNormalizeV (p -.- x)

src/Dodge/Placement/PlaceSpot.hs

@@ -33,7 +33,7 @@ import NewInt
 placeSpot :: Int -> GenWorld -> Placement -> GenWorld
 placeSpot rid w plmnt = case plmnt ^. plSpot of
     PSRoomRand i f -> placeSpotRoomRand rid i f plmnt w
-    PSPos extract eff fallback -> placeSpotUsingLink w rid plmnt extract eff fallback
+    PSPos extract eff fallback -> placeSpotUsingRoomPos w rid plmnt extract eff fallback
     _ -> placePlainPSSpot w rid plmnt shift
   where
     shift = _rmShift $ w ^?! genRooms . ix rid
@@ -62,7 +62,7 @@ placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
             (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
 
 -- this should be tidied up
-placeSpotUsingLink ::
+placeSpotUsingRoomPos ::
     GenWorld ->
     Int ->
     Placement ->
@@ -70,7 +70,7 @@ placeSpotUsingLink ::
     (RoomPos -> Room -> Room) ->
     Maybe Placement ->
     GenWorld
-placeSpotUsingLink w rid plmnt extract eff fallback =
+placeSpotUsingRoomPos w rid plmnt extract eff fallback =
     case searchedPoss (w ^?! genRooms . ix rid . rmPos) of
         Just (ps, rmposs) ->
             placeSpot

src/Dodge/Room/Airlock.hs

@@ -52,7 +52,7 @@ decontamRoom i =
                ]
         --        & rmOutPmnt . at i ?~
         --               analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0)
-        & rmInPmnt .~ [(0, f)]
+        & rmInPmnt .~ [(0, return . f)]
         & rmBound .~ [rectNSWE 75 15 0 40, switchcut]
   where
     f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do

src/Dodge/Room/Containing.hs

@@ -1,6 +1,7 @@
---{-# LANGUAGE TupleSections #-}
+-- {-# LANGUAGE TupleSections #-}
 module Dodge.Room.Containing where
 
+import Control.Monad
 import Dodge.Cleat
 import Dodge.Data.GenWorld
 import Dodge.Item.Display
@@ -15,28 +16,27 @@ import Dodge.Tree
 import Geometry
 import LensHelp
 import RandomHelp
-import Control.Monad
 
-roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String)
+roomsContaining :: (RandomGen g) => [Creature] -> [Item] -> State g (MetaTree Room String)
 roomsContaining crs its = tToBTree str <$> roomsContaining' crs its
   where
     str = "roomsContaining " ++ concatMap _crName crs ++ concatMap (head . basicItemDisplay) its
 
-roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
+roomsContaining' :: (RandomGen g) => [Creature] -> [Item] -> State g (Tree Room)
 roomsContaining' crs its = do
     endroom <-
         join $
             takeOne
-                [-- roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its
-                 --, randomFourCornerRoomCrsIts crs its
-                 --, tanksRoom crs its
---                 tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
-                 roomPillarsContaining crs its
---                , roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its
+                [ roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its
+                , randomFourCornerRoomCrsIts crs its
+                , tanksRoom crs its
+                , tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
+                , roomPillarsContaining crs its
+                , roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its
                 ]
     return (pure $ cleatOnward endroom)
 
-roomPillarsContaining :: RandomGen g => [Creature] -> [Item] -> State g Room
+roomPillarsContaining :: (RandomGen g) => [Creature] -> [Item] -> State g Room
 roomPillarsContaining crs itms = do
     (w, wn) <- takeOne [(240, 2), (340, 3)]
     (h, hn) <- takeOne [(240, 2), (340, 3)]
@@ -47,7 +47,7 @@ crsItmsUnused crs itms =
     map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
         ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
 
-pedestalRoom :: RandomGen g => Item -> State g Room
+pedestalRoom :: (RandomGen g) => Item -> State g Room
 pedestalRoom it = do
     let flit = PutFlIt it
     x <- state $ randomR (150, 250)

src/Dodge/Room/Door.hs

@@ -40,7 +40,7 @@ triggerDoorRoom i =
         -- note no bounds
         }
   where
-    f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
+    f gw = return $ fromMaybe (error "tried to put a door using an empty placement list") $ do
         pmnt <- gw ^? genPmnt . ix i
         return $ putDoubleDoor defaultDoorWall (cond pmnt) (V2 0 20) (V2 40 20) 2
     cond pmnt = WdTrig $ fromJust (_plMID pmnt)

src/Dodge/Room/LasTurret.hs

@@ -17,6 +17,7 @@ module Dodge.Room.LasTurret (
     storeRoomID,
 ) where
 
+import Dodge.Room.Modify
 import Color
 import Control.Monad
 import Data.Foldable
@@ -148,9 +149,9 @@ lasSensorTurretTest = do
     let cenroom =
             cenroom''
                 & rmInPmnt
-                <>~ [ (0, alight pi . f i)
-                    , (0, alight (0.5 * pi) . f i)
-                    , (0, alight (1.5 * pi) . f i)
+                <>~ [ (0, return . alight pi . f i)
+                    , (0, return . alight (0.5 * pi) . f i)
+                    , (0, return . alight (1.5 * pi) . f i)
                     ]
     rToOnward "lasSensorTurretTest" $
         treePost
@@ -166,7 +167,7 @@ lasCenSensEdge n = do
     (i, cenroom') <- storeRoomID =<< shuffleLinks =<< lightSensByDoor n =<< cenLasTur
     lshape <- takeOne [vShape, lShape, jShape, liShape]
     let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
-        blight a = (0, alight a . f i)
+        blight a = (0, return . alight a . f i)
     let cenroom = cenroom' & rmInPmnt <>~ map blight [pi, (0.5 * pi), (1.5 * pi)]
     let doorroom = triggerDoorRoom n
     rToOnward "lasCenSensEdge" $
@@ -181,16 +182,6 @@ lasCenSensEdge n = do
     isused UsedOutLink{_rplsChildNum = 0} = True
     isused _ = False
 
-storeRoomID :: Room -> State LayoutVars (Int, Room)
-storeRoomID x = do
-    i <- nextLayoutInt
-    return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
-  where
-    f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
-
--- unsafe! assumes that storeRoomID has been called
-getRoomFromID :: Int -> GenWorld -> Room
-getRoomFromID i gw = gw ^?! genRooms . ix (gw ^?! genInts . ix i)
 
 lasRunYinYang :: (RandomGen g) => State g (MetaTree Room String)
 lasRunYinYang = do

src/Dodge/Room/Modify.hs

@@ -1,4 +1,76 @@
-module Dodge.Room.Modify 
-    ( module Dodge.Room.Modify.Girder
-    ) where
+module Dodge.Room.Modify (
+    module Dodge.Room.Modify.Girder,
+    storeRoomID,
+    getRoomFromID,
+    addLightsNGon,
+    removeLights,
+) where
+
+import Color
+import Shape
+import Dodge.Placement.Instance.LightSource
+import Dodge.LevelGen.PlacementHelper
+import LensHelp
+import Dodge.Data.MetaTree
+import RandomHelp
+import Dodge.Data.GenWorld
 import Dodge.Room.Modify.Girder
+import qualified Data.Set as S
+import Data.Maybe
+import Geometry
+import Data.Foldable
+
+storeRoomID :: Room -> State LayoutVars (Int, Room)
+storeRoomID x = do
+    i <- nextLayoutInt
+    return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
+  where
+    f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
+
+-- unsafe! assumes that storeRoomID has been called
+getRoomFromID :: Int -> GenWorld -> Room
+getRoomFromID i gw = gw ^?! genRooms . ix (gw ^?! genInts . ix i)
+
+removeLights :: Room -> Room
+removeLights = rmPmnts %~ mapMaybe f
+  where
+    f x = case x ^. plType of
+        PutLabel "light" -> Nothing
+        _ -> Just x
+
+addLightsNGon :: Room -> State LayoutVars Room
+addLightsNGon rm = do
+    (i, rm') <- storeRoomID $ removeLights rm
+    return $
+        rm'
+            & rmInPmnt
+            .:~ (0, f i)
+  where
+    a = 2 * pi - (2 * pi / fromIntegral (rm ^?! rmType . rmngonSides))
+    y = rm ^?! rmType . rmngonSize
+    x = y * tan (0.5 * a)
+    f i gw = do
+        lshape <- takeOne [vShape, lShape, jShape, liShape]
+        let ps = fromMaybe (PS (V2 y 0) 0) $ rpToPS <$> find iscolorlight (grm ^. rmPos)
+            alight a' = mntLSCond (fmap (fmap $ colorSH black) lshape) (rotateps a' ps)
+        takeOne
+            [ spanLightY (V2 0 0) (V2 y x) (V2 (x) y) (V2 (x) (-y))
+            , spanLightY (V2 20 20) (V2 y 20) (V2 (-y) 20) (V2 20 (-y))
+            , spanLightI (V2 22 y) (V2 22 (-y))
+            , spanLightI (V2 x y) (V2 (-x) (-y))
+            , alight (0.5 * pi) <> alight (1.5 * pi)
+            ]
+      where
+        grm = getRoomFromID i gw
+    rotateps a' (PS v d) = PS (rotateV a' v) (a' + d)
+    rotateps _ _ = error "in addLightsNGon"
+    rpToPS rp = (PS (_rpPos rp) (_rpDir rp))
+    iscolorlight rp =
+        (ColoredLightRP `S.member` (rp ^. rpFlags))
+            && islinkroompos rp
+    islinkroompos rp = case rp ^. rpType of
+        UsedOutLink{} -> True
+        UsedInLink{} -> True
+        UnusedLink{} -> True
+        NotLink{} -> False
+

src/Dodge/Room/Ngon.hs

@@ -24,6 +24,7 @@ roomNgon n x = do
             , _rmPmnts = [thelight]
             , _rmBound = [poly]
             , _rmFloor = Tiled [makeTileFromPoly poly 2]
+            , _rmType = RoomNgon n x
             --, _rmFloor = InheritFloor
             , _rmName = show n ++ "gon"
             , _rmPos = poss

src/Dodge/Room/Room.hs

@@ -154,7 +154,7 @@ roomCenterPillar = do
                             roomRect 240 240 2 2
             )
 
-weaponEmptyRoom :: State StdGen (Tree Room)
+weaponEmptyRoom :: RandomGen g => State g (Tree Room)
 weaponEmptyRoom = do
     w <- state $ randomR (220, 300)
     h <- state $ randomR (220, 300)
@@ -209,7 +209,7 @@ weaponBehindPillar = do
             , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi / 2) randC1] corridorN
             ]
 
-weaponBetweenPillars :: State StdGen (MetaTree Room String)
+weaponBetweenPillars :: State LayoutVars (MetaTree Room String)
 weaponBetweenPillars = do
     (w, wn) <- takeOne [(240, 2), (340, 3)]
     (h, hn) <- takeOne [(240, 2), (340, 3)]
@@ -271,7 +271,7 @@ deadEndRoom =
     lnks = [(V2 0 30, 0)]
 
 {- A random Either tree with a weapon and melee monster challenge.  -}
-weaponRoom :: State StdGen (MetaTree Room String)
+weaponRoom :: State LayoutVars (MetaTree Room String)
 weaponRoom =
     join $
         takeOne
@@ -458,7 +458,7 @@ distributerRoom atype aamount = do
                     )
                 )
     return $ r & rmPmnts .:~ store
-        & rmInPmnt <>~ [(0,dst),(1,thepipe)]
+        & rmInPmnt <>~ [(0,return . dst),(1,return . thepipe)]
         & rmLinks %~ setInLinksByType (OnEdge South)
         & rmLinks %~ setOutLinks (not . S.member (OnEdge South) . _rlType)
 

src/Dodge/Room/SensorDoor.hs

@@ -1,33 +1,37 @@
 {-# LANGUAGE TupleSections #-}
-module Dodge.Room.SensorDoor (sensAboveDoor,sensorRoomRunPast) where
 
-import Dodge.Data.MTRS
+module Dodge.Room.SensorDoor (sensAboveDoor, sensorRoomRunPast) where
+
+import Dodge.Room.Procedural
+import Control.Monad
 import qualified Data.Set as S
 import Dodge.Cleat
 import Dodge.Data.GenWorld
+import Dodge.Data.MTRS
 import Dodge.LevelGen.PlacementHelper
 import Dodge.Placement.Instance
 import Dodge.PlacementSpot
 import Dodge.Room.Corridor
 import Dodge.Room.Door
 import Dodge.Room.Link
+import Dodge.Room.Modify
 import Dodge.Room.Ngon
-import Dodge.Room.Procedural
 import Dodge.Terminal
 import Dodge.Tree
 import Dodge.Wire
 import Geometry
 import LensHelp
 import RandomHelp
-import Control.Monad
 
 -- TODO fix case where the sensor created by sensInsideDoor blocks another door
 -- for roomRectAutoLinks-- make the locked door a center door?
-sensorRoom :: RandomGen g => SensorType -> Int -> State g (Tree Room)
+sensorRoom :: SensorType -> Int -> State LayoutVars (Tree Room)
 sensorRoom senseType n = do
-    rm <- join $ takeOne [roomNgon 8 200, roomRectAutoLights 200 200]
+    rm <- join $ takeOne [addLightsNGon =<< roomNgon 8 200, roomRectAutoLights 200 200]
+    --rm <- join $ takeOne [addLightsNGon =<< roomNgon 8 200]
     cenroom <- shuffleLinks $ sensInsideDoor senseType n rm
-    return $ treePost
+    return $
+        treePost
             [ door
             , cenroom & rmLinkEff .~ f
             , triggerDoorRoom n
@@ -43,29 +47,40 @@ sensorRoom senseType n = do
         p' = p +.+ rotateV d (V2 0 (negate 100))
         isclose = dist (_rlPos rl) p' < 30
 
-sensorRoomRunPast :: RandomGen g => SensorType -> Int -> State g MTRS
+
+
+sensorRoomRunPast :: SensorType -> Int -> State LayoutVars MTRS
 sensorRoomRunPast dt n = do
     t <- sensorRoom dt n
-    rToOnward "sensorRoomRunPast" $ t
-            & applyToSubforest [0]
-                ( ++ [ treePost [ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)) , cleatLabel n corridor ] ])
+    rToOnward "sensorRoomRunPast" $
+        t
+            & applyToSubforest
+                [0]
+                (++ [treePost [door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)), cleatLabel n corridor]])
 
 sensAboveDoor :: SensorType -> Float -> PlacementSpot -> Placement
 sensAboveDoor sensetype wth ps =
     extTrigLitPos
-        (atFstLnkOutShiftBy (\(p, a) -> ((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosHigh)))
+        ( psposAddLabel
+            ColoredLightRP
+            (atFstLnkOutShiftBy (\(p, a) -> ((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosHigh)))
+        )
         (\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps)
 
 sensInsideDoor :: SensorType -> Int -> Room -> Room
-sensInsideDoor senseType i rm = rm
-    & rmName .++~ take 4 (show senseType)
-    & rmPmnts
+sensInsideDoor senseType i rm =
+    rm
+        & rmName
+        .++~ take 4 (show senseType)
+        & rmPmnts
         .++~ [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
              , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
              , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
-             , putMessageTerminal 
+             , putMessageTerminal
                 (textTerminal & tmCommands .:~ TCDamageCommand)
-                & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10 <&> (, S.singleton UsedPosHigh))
-            , sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
+                & plSpot
+                .~ rprBoolShift isUnusedLnk (shiftInBy 10 <&> (,S.singleton UsedPosHigh))
+             , sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
              ]
+
 --    & rmOutPmnt . at i ?~ sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)

src/Dodge/Room/Start.hs

@@ -50,8 +50,9 @@ powerFakeout = do
                    ]
 
 -- the i is used either for a PickOnePlacement or a room id, this is not great
-startRoom :: Int -> State StdGen (MetaTree Room String)
-startRoom i =
+startRoom :: State LayoutVars (MetaTree Room String)
+startRoom = do
+    i <- nextLayoutInt
     join $
         takeOne
             [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom

src/Dodge/Room/Tutorial.hs

@@ -2,6 +2,7 @@
 
 module Dodge.Room.Tutorial where
 
+import Dodge.Room.Modify
 import Control.Monad
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
@@ -119,7 +120,7 @@ tutDrop = do
     return $
         tToBTree "TutDrop" $
             treePost
-                [x & rmInPmnt .:~ (0, t j), y, cleatOnward rm]
+                [x & rmInPmnt .:~ (0, return . t j), y, cleatOnward rm]
   where
     t j gw =
         let x = gw ^? genInts . ix j
@@ -391,13 +392,6 @@ tutLight = do
                         )
             _ -> Nothing
 
-removeLights :: Room -> Room
-removeLights = rmPmnts %~ mapMaybe f
-  where
-    f x = case x ^. plType of
-        PutLabel "light" -> Nothing
-        _ -> Just x
-
 tutHub :: State LayoutVars (MetaTree Room String)
 tutHub = do
     (is, wbp) <- setTreeInts =<< critsRoom 1
@@ -413,7 +407,7 @@ tutHub = do
     x <-
         shuffleLinks
             . analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i
-            . (rmInPmnt .:~ (0, a))
+            . (rmInPmnt .:~ (0, return . a))
             . addDoorAtNthLinkToggleTerminal 1 ss j
             --            . addDoorAtNthLinkToggleInterrupt 2 ds j
             . addDoorAtNthLinkToggleInterrupt 2 ds j1

src/Dodge/TestString.hs

@@ -30,11 +30,12 @@ import qualified Data.Map.Strict as M
 import NewInt
 import Data.Foldable
 import Data.Monoid
+import RandomHelp
 
 testStringInit :: Universe -> [String]
-testStringInit u = 
-    (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
-    <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
+testStringInit u = [evalState (takeOne ["a","b"]) (_randGen $ _uvWorld u)]
+--    (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
+--    <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
 --testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
 --testStringInit u =  map show
 --    (u ^.. uvWorld . cWorld . lWorld . machines . traverse .mcType . _McDistributer)

src/RandomHelp.hs

@@ -2,13 +2,13 @@
 {- Helpers for random generation.  -}
 module RandomHelp (
     module System.Random,
---    module Control.Monad.State,
+    --    module Control.Monad.State,
     module RandomHelp,
     module Control.Monad.Trans.State.Lazy,
 ) where
 
 import Control.Monad
---import Control.Monad.State
+-- import Control.Monad.State
 import Control.Monad.Trans.State.Lazy
 import Data.List
 import Geometry
@@ -21,8 +21,25 @@ randomRanges = join . takeOne . f
     f (x : y : ys) = state (randomR (x, y)) : f ys
     f _ = []
 
-takeOne :: RandomGen g => [a] -> State g a
-takeOne xs = state (randomR (0, length xs - 1)) >>= (\i -> return (xs !! i))
+takeOne :: (RandomGen g) => [a] -> State g a
+takeOne xs = state (randomR (0, length xs - 1)) >>= \i -> return (xs !! i)
+
+takeOneRem :: (RandomGen g) => [a] -> State g (Maybe (a, [a]))
+takeOneRem [] = return Nothing
+takeOneRem xs =
+    state (randomR (0, length xs - 1)) >>= \i -> do
+        let (ys, (z : zs)) = splitAt i xs
+        return $ Just (z, ys <> zs)
+
+takeOneFiltered :: (RandomGen g) => (a -> Bool) -> [a] -> State g (Maybe a)
+takeOneFiltered t xs = do
+    m <- takeOneRem xs
+    f m
+  where
+    f Nothing = return Nothing
+    f (Just (y, ys))
+        | t y = return $ Just y
+        | otherwise = takeOneFiltered t ys
 
 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))
@@ -32,25 +49,25 @@ takeOneWeighted ws xs = state (randomR (0, sum ws)) >>= (\w -> return (xs !! i w
         | otherwise = 1 + i (y - z) zs
     i _ _ = 0
 
---{-# OPTIONS -Wno-incomplete-uni-patterns #-}
-takeOneMore :: RandomGen g => ([a], [a]) -> State g ([a], [a])
+-- {-# OPTIONS -Wno-incomplete-uni-patterns #-}
+takeOneMore :: (RandomGen g) => ([a], [a]) -> State g ([a], [a])
 takeOneMore (_, []) = error "trying to takeOneMore from empty list"
 takeOneMore (xs, ys) = do
     i <- state $ randomR (0, length ys - 1)
     let (zs, w : ws) = splitAt i ys
     return (w : xs, zs ++ ws)
 
-takeNMore :: RandomGen g => Int -> ([a], [a]) -> State g ([a], [a])
+takeNMore :: (RandomGen g) => Int -> ([a], [a]) -> State g ([a], [a])
 takeNMore n p = foldl' (flip $ const (>>= takeOneMore)) (return p) [1 .. n]
 
-takeN :: RandomGen g => Int -> [a] -> State g [a]
+takeN :: (RandomGen g) => Int -> [a] -> State g [a]
 takeN 0 _ = return []
 takeN i xs = fst <$> takeNMore i ([], xs)
 
 -- | Randomly shuffle a list.
-shuffle :: RandomGen g => [a] -> State g [a]
+shuffle :: (RandomGen g) => [a] -> State g [a]
 shuffle xs = do
-    rands <- forM [0 .. length xs -1] $ \i -> state $ randomR (0, i)
+    rands <- forM [0 .. length xs - 1] $ \i -> state $ randomR (0, i)
     let f ys rand =
             let (as, b : bs) = splitAt rand ys
              in (as ++ bs, b)
@@ -58,94 +75,95 @@ shuffle xs = do
     return $ forceElements zs `seq` zs
 
 -- | Randomly shuffle the tail of a list, not safe.
-shuffleTail :: RandomGen g => [a] -> State g [a]
+shuffleTail :: (RandomGen g) => [a] -> State g [a]
 shuffleTail (x : xs) = (x :) <$> shuffle xs
 shuffleTail _ = undefined
 
 -- select elements from a list randomly
 -- each element has the same independent chance of being selected
-randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
+randomSelectionFromList :: (RandomGen g) => Float -> [a] -> State g [a]
 randomSelectionFromList = filterM . const . randProb
 
-randProb :: RandomGen g => Float -> State g Bool
+randProb :: (RandomGen g) => Float -> State g Bool
 randProb p = do
     p1 <- state $ randomR (0, 1)
     return (p1 < p)
 
-randInCirc :: RandomGen g => Float -> State g Point2
+randInCirc :: (RandomGen g) => Float -> State g Point2
 randInCirc = flip randInArc (2 * pi)
 
-randOnCirc :: RandomGen g => Float -> State g Point2
+randOnCirc :: (RandomGen g) => Float -> State g Point2
 randOnCirc r = do
-    a <- state $ randomR (0, 2*pi)
+    a <- state $ randomR (0, 2 * pi)
     return $ r *.* unitVectorAtAngle a
 
-randInArc :: RandomGen g => Float -> Float -> State g Point2
+randInArc :: (RandomGen g) => Float -> Float -> State g Point2
 randInArc = randInArcStrip 0
 
-randInArcStrip :: RandomGen g => Float -> Float -> Float -> State g Point2
+randInArcStrip :: (RandomGen g) => Float -> Float -> Float -> State g Point2
 randInArcStrip minrad maxRad maxangle = do
     rad <- state $ randomR (minrad, maxRad)
     ang <- state $ randomR (0, maxangle)
     return $ rad *.* unitVectorAtAngle ang
 
-randOnUnitSphere :: RandomGen g => State g Point3
+randOnUnitSphere :: (RandomGen g) => State g Point3
 randOnUnitSphere = do
     z <- state $ randomR (negate 1, 1)
     longitude <- state $ randomR (0, 2 * pi)
     let (V2 x y) = sqrt (1 - z ^ (2 :: Int)) *.* unitVectorAtAngle longitude
     return (V3 x y z)
 
-randOnHemisphere :: RandomGen g => State g Point3
+randOnHemisphere :: (RandomGen g) => State g Point3
 randOnHemisphere = do
     z <- state $ randomR (0, 1)
     longitude <- state $ randomR (0, 2 * pi)
     let (V2 x y) = sqrt (1 - z ^ (2 :: Int)) *.* unitVectorAtAngle longitude
     return (V3 x y z)
 
-randInHemisphere :: RandomGen g => State g Point3
+randInHemisphere :: (RandomGen g) => State g Point3
 randInHemisphere = do
     p <- randOnHemisphere
     r <- state $ randomR (0, 1)
     return $ r *.*.* p
 
-randInRect :: RandomGen g => Float -> Float -> State g Point2
+randInRect :: (RandomGen g) => Float -> Float -> State g Point2
 randInRect w h = do
     x <- state $ randomR (0, w)
     y <- state $ randomR (0, h)
     return (V2 x y)
 
-maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
+maybeTakeOne :: (RandomGen g) => [a] -> State g (Maybe a)
 maybeTakeOne [] = return Nothing
 maybeTakeOne xs = state (randomR (0, length xs - 1)) >>= (\i -> return (Just (xs !! i)))
 
-randsSpread :: RandomGen g => (Float, Float) -> Int -> State g [Float]
+randsSpread :: (RandomGen g) => (Float, Float) -> Int -> State g [Float]
 randsSpread (a, b) i
     | i <= 0 = error "tried to take <= 0 randsSpread"
     | otherwise = zipWith (+) [a + x, a + 2 * x ..] <$> replicateM i (state $ randomR (0, x))
   where
     x = (b - a) / fromIntegral i
 
-randsOnCirc :: RandomGen g => Int -> State g [Float]
+randsOnCirc :: (RandomGen g) => Int -> State g [Float]
 randsOnCirc = randsSpread (0, 2 * pi)
 
-randPeakedParam :: RandomGen g => Int -> Float -> Float -> Float -> State g Float
+randPeakedParam :: (RandomGen g) => Int -> Float -> Float -> Float -> State g Float
 randPeakedParam i a b c = do
     x <- state $ randomR (-1, 1)
     let y = x ^ i
-    return $ if y < 0
-        then a + y * (a-b)
-        else b + y * (c-b)
+    return $
+        if y < 0
+            then a + y * (a - b)
+            else b + y * (c - b)
 
-randPeaked :: RandomGen g => Float -> Float -> Float -> State g Float
+randPeaked :: (RandomGen g) => Float -> Float -> Float -> State g Float
 randPeaked = randPeakedParam 3
 
-randFromPair :: RandomGen g => Float -> (a,a) -> State g a
-randFromPair x (l,r) = do
-    y <- state $ randomR (0,1)
+randFromPair :: (RandomGen g) => Float -> (a, a) -> State g a
+randFromPair x (l, r) = do
+    y <- state $ randomR (0, 1)
     if x < y then return l else return r
 
-shufflePair :: RandomGen g => (a,a) -> State g (a,a)
-shufflePair (x,y) = do
-    v <- state $ randomR (0::Float,1)
-    if v > 0.5 then return (x,y) else return (y,x)
+shufflePair :: (RandomGen g) => (a, a) -> State g (a, a)
+shufflePair (x, y) = do
+    v <- state $ randomR (0 :: Float, 1)
+    if v > 0.5 then return (x, y) else return (y, x)