Attempt to stop reuse of link placement spots

src/Dodge/Floor.hs

@@ -35,8 +35,13 @@ initialRoomTree = do
         t = treeFromTrunk 
             [[StartRoom]
             ,[Corridor]
-            ,[SpecificRoom $ fmap connectRoom glassSwitchBackCrits]
             ,[Corridor]
+            ,[SpecificRoom $ fmap connectRoom pistolerRoom]
+            ,[Corridor]
+            ,[Corridor]
+--            ,[Corridor]
+--            ,[Corridor]
+--            ,[Corridor]
             ,[SpecificRoom $ return $ connectRoom lasTunnel ]
             ,[Corridor]
             ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]

src/Dodge/Layout.hs

@@ -42,7 +42,8 @@ generateLevelFromRoomList gr w
     = initWallZoning 
     . setupWorldBounds
     -- . flip (foldr $ flip placeSpot) plmnts
-    . flip (foldl' placeSpot) plmnts
+    -- . flip (foldl' placeSpot) plmnts
+    . flip (foldl' doRoomPlacements) rs
     $ w { _walls        = wallsFromRooms rs
         , _floorTiles   = floorsFromRooms rs
         , _gameRooms    = gameRoomsFromRooms rs
@@ -56,6 +57,9 @@ generateLevelFromRoomList gr w
     rs = zipWith addTile zs . evalState gr $ _randGen w
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
 
+doRoomPlacements :: World -> Room -> World
+doRoomPlacements w rm = fst $ foldl' placeSpot' (w,rm) $ _rmPS rm
+
 updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
 updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
 updatePSLnkUsing _ ps = ps

src/Dodge/Layout/Tree/Shift.hs

@@ -23,11 +23,15 @@ shiftRoomTreeSearchAll
     -> Seq (Tree Room)  -- ^ Rooms to be added
     -> [[Room]]
 shiftRoomTreeSearchAll _ Empty = [[]]
-shiftRoomTreeSearchAll bs (Node r ts :<| ts')
+shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
-    | roomIsClipping = [] -- this is called too often, but whatever
+    | roomIsClipping = [] -- this is called too often--might get memoized?
     | otherwise = case ts of
-        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds ts'
+        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
-        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (ts' |> f l s))) ls
+        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
+--    = case ts of
+--        [] | roomIsClipping -> []
+--        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
+--        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
   where
     convexBounds = map pointsToPoly $ _rmBound r
     ls = init $ _rmLinks r

src/Dodge/LevelGen.hs

@@ -4,8 +4,9 @@
 module Dodge.LevelGen 
     ( shiftPlacement
     , shiftPointBy
-    , placeSpot
+--    , placeSpot
     , invShiftPointBy
+    , placeSpot'
     ) where
 import Dodge.Data
 import Dodge.LevelGen.Block
@@ -25,6 +26,40 @@ import Color
 import Control.Monad.State
 import Control.Lens
 import qualified Data.IntSet as IS
+import Data.List (delete)
+
+placeSpot' :: (World,Room) -> Placement -> (World,Room)
+placeSpot' (w,rm) plmnt = case plmnt of
+    Placement{_placementSpot = PSRoomRand i}
+        -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
+           in placeSpot' (w & randGen .~ g,rm) (plmnt & placementSpot .~ uncurry PS ps)
+    Placement{_placementSpot = PSLnk{}} -> case lnks of
+        (lnk:_) -> placeSpot' (w & randGen .~ g,uselnk lnk) (updatePS (f lnk) plmnt)
+        [] -> case fallback of
+            Nothing -> (w,rm)
+            Just plmnt' -> placeSpot' (w,rm) plmnt'
+      where
+        uselnk lnk = rm & rmLinks %~ delete lnk
+        rps = _placementSpot plmnt
+        fallback = _psFallback rps
+        test = _psLinkTest rps
+        (lnks,g) = runState (shuffle $ filter test $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) 
+            $ _randGen w
+        f x (PSLnk t s _)
+            | t x = uncurry PS $ s x
+        f _ ps = ps
+        invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
+        invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
+    Placement{} ->
+        let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w
+        in (maybe w' (curry (placeSpot w') rm) (_idPlacement plmnt i) , rm)
+    PlacementUsingPos p subpl -> placeSpot' (w,rm) (subpl (shiftPoint3By shift p))
+    RandomPlacement rplmnt -> placeSpot' (w & randGen .~ g,rm) plmnt'
+      where
+        (plmnt', g) = runState rplmnt (_randGen w)
+  where
+    shift = _rmShift rm
+
 
 -- potential failure cases: randomising using an already set link position
 -- others?
@@ -49,11 +84,12 @@ placeSpot w (rm, RandomPlacement rplmnt) = placeSpot (w & randGen .~ g) (rm, plm
 -- this should be woven into placeSpot
 assignPSToLnk :: Room -> Placement -> World -> World
 assignPSToLnk rm plmnt w = case lnks of
-    (lnk:_) -> placeSpot (w & randGen .~ g) (rm, updatePS (f lnk) plmnt)
+    (lnk:_) -> placeSpot (w & randGen .~ g) (uselnk lnk, updatePS (f lnk) plmnt)
     [] -> case fallback of
         Nothing -> w
         Just plmnt' -> placeSpot w (rm,plmnt')
   where
+    uselnk lnk = rm & rmLinks %~ delete lnk
     rps = _placementSpot plmnt
     fallback = _psFallback rps
     test = _psLinkTest rps

src/Dodge/Placements/LightSource.hs

@@ -85,7 +85,7 @@ mountLightl = redMID mountLightlID
 mountLightAID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
 mountLightAID = mountLightOnShape f
   where
-    f wallpos (V3 x y z) = girder (z+10) 20 10 pout wallpos
+    f wallpos (V3 x y z) = girder (z+2) 20 10 pout wallpos
       where
         pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
 

src/Dodge/Room.hs

@@ -209,15 +209,17 @@ roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
     plmnts = 
         [ blockLine (V2 115 115) (V2 115 125)
         , blockLine (V2 125 115) (V2 125 125)
-        , sPS (V2 40 120) 0 putLamp
+        --, sPS (V2 40 120) 0 putLamp
-        , sPS (V2 200 120) 0 putLamp
+        --, sPS (V2 200 120) 0 putLamp
+        , mntLightLnkCond (const True)
+        , mntLightLnkCond (const True)
         ]
 
 roomOctogon :: Room
 roomOctogon = defaultRoom
     { _rmPolys = [poly ]
     , _rmLinks = lnks
-    , _rmPath  = allPairs $ map fst lnks
+    , _rmPath  = allPairs $ map fst lnks -- this is too much
     , _rmPS    = []
     , _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
     , _rmFloor = [makeTileFromPoly poly 7]
@@ -238,10 +240,6 @@ roomOctogon = defaultRoom
 allPairs :: Eq a => [a] -> [(a,a)]
 allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
 
-randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
-randomCorridorFrom xs = do
-    rooms <- replicateM 5 $ takeOne xs
-    return $ treeFromTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
 {- Probabilites of the type of the first floor weapon.  -}
 randFirstWeapon :: State StdGen PSType
 randFirstWeapon = do
@@ -262,7 +260,8 @@ weaponEmptyRoom = do
             [sPS (V2 (w/2) (h-40))     0 $ RandPS randFirstWeapon
             ,sPS   (V2 20 20) (pi/2) randC1
             ,sPS (V2 (w-20) 20) (pi/2) randC1
-            ,sPS (V2 (w/2) (h/2))      0 putLamp
+            --,sPS (V2 (w/2) (h/2))      0 putLamp
+            ,mntLightLnkCond (const True)
             ]
     (fmap connectRoom . randomiseOutLinks) =<< 
         changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2)
@@ -277,8 +276,7 @@ weaponUnderCrits = do
     let continuationRoom = treeFromTrunk 
             [Left corridorN,Left corridorN] 
             (connectRoom (set rmPS plmnts corridorN))
-    rcp' <- roomCenterPillar
+    rcp <- roomCenterPillar
-    let rcp = over rmPS ( sPS (V2 120 80) 0 putLamp : ) rcp'
     deadEndRoom' <- takeOne [roomPillars,rcp]
     junctionRoom <- takeOne [Left tEast,Left tWest]
     return $ treeFromTrunk [Left corridorN,Left corridorN] 
@@ -322,8 +320,7 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
 weaponLongCorridor = do
     root <- takeOne [tEast, tWest]
     connectingRoom <- takeOne 
-        [tEast & rmPS .~ [sPS (V2 (-40) 60) 0 putLamp]
+        [tEast & rmPS .~ [spanLightI (V2 (-40) 40) (V2 (-40) 80)]
-        ,tWest & rmPS .~ [sPS (V2  40 60) 0 putLamp]
         ]
     i1 <- state $ randomR (2,5)
     i2 <- state $ randomR (2,5)
@@ -332,7 +329,7 @@ weaponLongCorridor = do
     return $ Node (Left root) [branch1,branch2]
       where 
         putCrs = over rmPS (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
-        putWp = set rmPS [sPS (V2 20 40) 0 $ RandPS randFirstWeapon ,sPS (V2 20 60) 0 putLamp ]
+        putWp = set rmPS [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
 
 critInDeadEnd :: Room
 critInDeadEnd = set rmPS [sPS (V2 0 0) 0 randC1] deadEndRoom
@@ -393,8 +390,8 @@ longRoom = do
         ,sPS (V2   25 (h-10)) 0 putLamp
         ]
 
-shooterRoom :: RandomGen g => State g Room
+doubleCorridorBarrels :: RandomGen g => State g Room
-shooterRoom = do
+doubleCorridorBarrels = do
     h <- state $ randomR (200,300)
     let cond x = (sndV2 . fst) x < h - 40
     changeLinkTo cond $ roomRect 100 h 1 1 & rmPS .~
@@ -407,84 +404,78 @@ shooterRoom = do
         ,sPS (V2 75 (h-80)) 0 putLamp
         ]
 
-shootersRoom1 :: RandomGen g => State g Room
+shootersRoom' :: RandomGen g => State g Room
-shootersRoom1 = do
+shootersRoom' = do
     w <- state $ randomR (200,300)
     x1 <- state $ randomR (20,w/3-20)
     x2 <- state $ randomR (w/3+20,2*w/3-20)
     x3 <- state $ randomR (2*w/3+20,w-20)
-    y1 <- state $ randomR (250,560)
+    y1 <- state $ randomR (250,550)
-    y2 <- state $ randomR (250,560)
+    y2 <- state $ randomR (250,550)
     y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
     x4 <- state $ randomR (60,w-60)
     y4 <- state $ randomR (40,180)
-    p <- takeOne [V2 x1 (y1-10),V2 x2 (y2-10),V2 x3 (y3-10)]
+    --p <- takeOne [V2 x1 y1,V2 x2 y2,V2 x3 y3]
-    let bln x y = putBlockN (x+25) (x-25) (y+10) y
+    let bln x y = putBlockN (x+25) (x-25) (y+20) (y+10)
-    let blv x y = putBlockV (x+25) (x-25) (y+10) y
+        blv x y = putBlockV (x+25) (x-25) (y+20) (y+10)
-    let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
+        plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
-                  ++ [sPS p (-pi/2) $ PutCrit autoCrit
+                  ++ [spanLightI (V2 0 200) (V2 w 200)
-                     ,sPS (V2 (w/2)  200) 0 putLamp
+                    , mntLightLnkCond (\(V2 _ y,_) -> y < 50)
+                    , mntLightLnkCond (\(V2 _ y,_) -> y > 550)
                      ]
+        toPS x y = return (V2 x y,-0.5*pi)
     return $ set rmPS plmnts $ roomRectAutoLinks w 600
+        & rmPS .~ plmnts
+        & rmRandPSs .~ [toPS x1 y1,toPS x2 y2,toPS x3 y3]
+
+shootersRoom1 :: RandomGen g => State g Room
+shootersRoom1 = shootersRoom' <&> rmPS %~ 
+    ( (
+    RandomPlacement $ takeOne $ map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
+                    [0,1,2]
+    ) :)
 
 shootersRoom :: RandomGen g => State g Room
-shootersRoom = do
+shootersRoom = shootersRoom' <&> rmPS %~
-    w <- state $ randomR (200,300)
+    ( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
-    x1 <- state $ randomR (20,w/3-20)
+                    [0,1,2]
-    x2 <- state $ randomR (w/3+20,2*w/3-20)
+    ++ )
-    x3 <- state $ randomR (2*w/3+20,w-20)
-    y1 <- state $ randomR (250,560)
-    y2 <- state $ randomR (250,560)
-    y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
-    x4 <- state $ randomR (60,w-60)
-    y4 <- state $ randomR (40,180)
-    let bln x y = putBlockN (x+25) (x-25) (y+10) y
-    let blv x y = putBlockV (x+25) (x-25) (y+10) y
-    let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
-                  ++ [sPS (V2  x1  (y1-10)) (-pi/2) $ PutCrit autoCrit
-                     ,sPS (V2  x2  (y2-10)) (-pi/2) $ PutCrit autoCrit
-                     ,sPS (V2  x3  (y3-10)) (-pi/2) $ PutCrit autoCrit
-                     ,sPS (V2 (w/2)  200 ) 0 putLamp
-                     ]
-    return $ set rmPS plmnts $ roomRectAutoLinks w 600
 
-pistolerRoom :: RandomGen g => State g Room
+pillarGrid :: RandomGen g => State g Room
-pistolerRoom = do
+pillarGrid = do
     let f2 x y = singleBlock (V2 x y)
-        --f3 x y = [blockLine (x-20,y) (x+20,y)
-        --         ,blockLine (x,y-20) (x,y+20) ]
-        --f4 x y = [blockLine (x-20,y-20) (x+20,y+20)
-        --         ,blockLine  (x+20,y-20) (x-20,y+20) ]
     f <- takeOne [f2]
     h <- state $ randomR (400,800)
     let w = h
     i <- takeOne [3,4,5]
-    let j = fromIntegral (i+1)
+    let j = fromIntegral i
     -- the 20+etc here is to correct for the pathfinding grid, which matches up to
     -- edges based on the size of doors (i.e. the line next to the wall is 20
     -- away from it)
-        xs = take i [20+0.5*(w-40)/(j-1),20+1.5*(w-40)/(j-1)..]
+        xs = take i [20+0.5*(w-40)/j,20+1.5*(w-40)/j..]
-        ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..]
+        ys = take i [20+0.5*(h-40)/j,20+1.5*(h-40)/j..]
-        gap = 0.5 * h / j
+        gap = 0.5 * h / (j+1)
-    ps <- takeN 3 $ zipWith V2 (map (+gap) xs) ys
+        rps = do
-    aa <- state $ randomR (0,2*pi)
+            x <- takeOne xs
-    ab <- state $ randomR (0,2*pi)
+            y <- takeOne ys
-    ac <- state $ randomR (0,2*pi)
+            a <- state $ randomR (0,2*pi)
-    let plmnts = [sPS (head ps) aa $ PutCrit pistolCrit
+            return (V2 (x+gap) y,a)
-                 ,sPS (ps !! 1) ab $ PutCrit pistolCrit
+    let plmnts = replicate 30 (mntLightLnkCond (const True))
-                 ,sPS (ps !! 2) ac $ PutCrit pistolCrit
-                 ,sPS (V2 (w/2) (h-50)) 0 putLamp
-                 ,sPS (V2 (w/2)  50   ) 0 putLamp
-                 ,sPS (V2 (w-5) (h-5) ) 0 putLamp
-                 ,sPS (V2    5  (h-5) ) 0 putLamp
-                 ,sPS (V2 (w-5)  5    ) 0 putLamp
-                 ,sPS (V2    5   5    ) 0 putLamp
-                 ,sPS (V2 (w/2) (h/2) ) 0 putLamp
-                 ] 
                   ++ 
                  concat [f x y | x<-xs,y<-ys]
-    return 
+    return $ roomRect w h (max i 2) (max i 2)
-        $ set rmPS plmnts $ roomRect w h (max i 2) (max i 2)
+        & rmPS .~ plmnts
+        & rmRandPSs .~ [rps]
+
+-- TODO remove possible identical draws on random PSs
+pistolerRoom :: RandomGen g => State g Room
+pistolerRoom = pillarGrid
+    <&> rmPS %~ (
+        [Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
+        ,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
+        ,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
+        ]
+            ++)
 
 shootingRange :: RandomGen g => State g (Tree (Either Room Room))
 shootingRange = do

src/Dodge/Room/Foreground.hs

@@ -135,7 +135,7 @@ girder
     -> Float -- ^ distance between cross bars
     -> Float -- ^ width
     -> Point2 -> Point2 -> Shape
-girder = girderCol red
+girder = girderCol orange
 
 robotArm :: Shape
 robotArm = undefined