justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Attempt to stop reuse of link placement spots

Browse Source
This commit is contained in:
justin
2021-11-09 17:00:42 +00:00
parent 28f8ac1fbd
commit 5b09c9aa37
7 changed files with 121 additions and 81 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+6 -1
View File
@@ -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
+5 -1
View File
@@ -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
+8 -4
View File
@@ -23,11 +23,15 @@ shiftRoomTreeSearchAll
-> Seq (Tree Room) -- ^ Rooms to be added
-> [[Room]]
shiftRoomTreeSearchAll _ Empty = [[]]
shiftRoomTreeSearchAll bs (Node r ts :<| ts')
| roomIsClipping = [] -- this is called too often, but whatever
shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
| roomIsClipping = [] -- this is called too often--might get memoized?
| otherwise = case ts of
[] -> (r :) <$> shiftRoomTreeSearchAll newBounds ts'
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (ts' |> f l s))) ls
[] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
(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
+38 -2
View File
@@ -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
+1 -1
View File
@@ -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
+62 -71
View File
@@ -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 200 120) 0 putLamp
--, sPS (V2 40 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
let rcp = over rmPS ( sPS (V2 120 80) 0 putLamp : ) rcp'
rcp <- roomCenterPillar
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]
,tWest & rmPS .~ [sPS (V2 40 60) 0 putLamp]
[tEast & rmPS .~ [spanLightI (V2 (-40) 40) (V2 (-40) 80)]
]
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
shooterRoom = do
doubleCorridorBarrels :: RandomGen g => State g Room
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
shootersRoom1 = do
shootersRoom' :: RandomGen g => State g Room
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)
y2 <- state $ randomR (250,560)
y1 <- state $ randomR (250,550)
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)]
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 p (-pi/2) $ PutCrit autoCrit
,sPS (V2 (w/2) 200) 0 putLamp
--p <- takeOne [V2 x1 y1,V2 x2 y2,V2 x3 y3]
let bln x y = putBlockN (x+25) (x-25) (y+20) (y+10)
blv x y = putBlockV (x+25) (x-25) (y+20) (y+10)
plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [spanLightI (V2 0 200) (V2 w 200)
, 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
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)
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
shootersRoom = shootersRoom' <&> rmPS %~
( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
[0,1,2]
++ )
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = do
pillarGrid :: RandomGen g => State g Room
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)..]
ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..]
gap = 0.5 * h / j
ps <- takeN 3 $ zipWith V2 (map (+gap) xs) ys
aa <- state $ randomR (0,2*pi)
ab <- state $ randomR (0,2*pi)
ac <- state $ randomR (0,2*pi)
let plmnts = [sPS (head ps) aa $ PutCrit pistolCrit
,sPS (ps !! 1) ab $ PutCrit pistolCrit
,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
]
xs = take i [20+0.5*(w-40)/j,20+1.5*(w-40)/j..]
ys = take i [20+0.5*(h-40)/j,20+1.5*(h-40)/j..]
gap = 0.5 * h / (j+1)
rps = do
x <- takeOne xs
y <- takeOne ys
a <- state $ randomR (0,2*pi)
return (V2 (x+gap) y,a)
let plmnts = replicate 30 (mntLightLnkCond (const True))
++
concat [f x y | x<-xs,y<-ys]
return
$ set rmPS plmnts $ roomRect w h (max i 2) (max i 2)
return $ 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
+1 -1
View File
@@ -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