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

Fix---at least partially---level generation bug

Browse Source
This commit is contained in:
jgk
2021-03-28 18:51:39 +02:00
parent bacaded2a5
commit 1c11d82878
10 changed files with 214 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
-10
View File
@@ -613,19 +613,10 @@ data PlacementSpot = PS
, _psRot :: Float
, _psType :: PSType
}
data Room = Room
{ _rmPolys :: [Poly]
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmBound :: Poly
}
data SubNode a = SN a | InLink | OutLink
data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
makeLenses ''RoomLink
makeLenses ''World
makeLenses ''Cloud
makeLenses ''Creature
@@ -652,7 +643,6 @@ makeLenses ''PressPlate
makeLenses ''Button
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Room
numColor :: Int -> Color
numColor 0 = (1,0,0,1)
src/Dodge/Event/Keyboard.hs
+1 -3
View File
@@ -6,6 +6,7 @@ import Dodge.Data
import Dodge.Base
import Dodge.CreatureAction
import Dodge.LoadConfig
import Dodge.Event.Test
import SDL
import Data.Maybe
@@ -46,9 +47,6 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
Just (Right but) -> _btEvent but but w
Nothing -> w
testEvent :: World -> World
testEvent w = w
pauseGame :: World -> World
pauseGame w = w {_menuState = PauseMenu}
src/Dodge/Event/Test.hs
+98
View File
@@ -0,0 +1,98 @@
module Dodge.Event.Test
( testEvent
)
where
import Dodge.Data
import Dodge.Base
import Dodge.Default
import Picture
import Geometry
import qualified Data.IntMap as IM
import Control.Lens
testEvent :: World -> World
testEvent w = over walls (IM.union testWalls) w
where
k = newKey $ _walls w
setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..]
testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls)
polyPairs = makeLoopPairs
$ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)]
-- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)]
polyWalls = map (wallWithCol red . flat2) polyPairs
errorWallPair =
(9,[(-340.0,60.0),(-320.0,60.0)])
-- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
errorWall = wallWithCol green $ snd errorWallPair
errorWallPairs =
[(1,[(-400.0,59.999996),(-340.0,60.0)])
,(12,[(-340.0,60.0),(-340.0,59.999996)])
]
-- [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
-- ]
errorWalls = map (wallWithCol blue . snd) errorWallPairs
startWallPairs =
[(0,[(-320.0,60.0),(-320.0,100.0)])
,(1,[(-400.0,59.999996),(-320.0,60.0)])
,(2,[(-400.0,100.0),(-400.0,59.999996)])
,(3,[(-320.0,100.0),(-400.0,100.0)])
,(4,[(-260.0,60.0),(-225.35898,80.0)])
,(5,[(-260.0,100.0),(-260.0,60.0)])
,(6,[(-225.35898,80.0),(-260.0,100.0)])
]
-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
-- ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)])
-- ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)])
-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
-- ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)])
-- ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)])
-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
-- ]
startWalls = map (wallWithCol yellow . snd) startWallPairs
endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs
endWallPairs =
[(0,[(-320.0,60.0),(-320.0,100.0)])
,(1,[(-400.0,59.999996),(-340.0,60.0)])
,(2,[(-400.0,100.0),(-400.0,59.999996)])
,(3,[(-320.0,100.0),(-340.0,100.0)])
,(4,[(-260.0,60.0),(-225.35898,80.0)])
,(5,[(-260.0,100.0),(-260.0,60.0)])
,(6,[(-225.35898,80.0),(-260.0,100.0)])
,(9,[(-340.0,60.0),(-320.0,60.0)])
,(11,[(-340.0,100.0),(-400.0,100.0)])
,(12,[(-340.0,60.0),(-340.0,59.999996)])
]
-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
-- ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)])
-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
-- ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
-- ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)])
-- ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)])
-- ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)])
-- ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
-- ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)])
-- ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)])
-- ]
--flat2 :: (a,a) -> [a]
--flat2 (x,y) = [x,y]
wallWithCol :: Color -> [Point2] -> Wall
wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True
src/Dodge/Floor.hs
+38 -37
View File
@@ -8,6 +8,7 @@ import Picture
import Dodge.Data
import Dodge.Rooms
import Dodge.Room.Data
import Dodge.Base
import Dodge.Layout
import Dodge.Creature
@@ -32,44 +33,44 @@ lev1 = do
(
[return $ return $ Right deadEndRoom
]
++ [return $ connectRoom corridor
,return $ connectRoom door
,glassSwitchBack >>= randomiseLinks]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [miniRoom3]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [roomCCrits]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++[roomMiniIntro]
++ [longRoom >>= randomiseLinks]
++ [return $ connectRoom corridor
,return $ connectRoom door]
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door
-- ,glassSwitchBack >>= randomiseLinks]
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door]
-- ++ [miniRoom3]
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door]
-- ++ [roomCCrits]
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door]
-- ++[roomMiniIntro]
-- ++ [longRoom >>= randomiseLinks]
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door]
++ firstWeapon
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [randomiseLinks =<< pistolerRoom]
++ [return $ connectRoom door]
++ [randomiseLinks =<< shooterRoom]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
++ [return $ connectRoom corridor]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange]
++ (replicate 3 $ randomiseLinks corridor)
++[roomMiniIntro]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor
,return $ connectRoom door
,slowDoorRoom]
++ [return $ connectRoom corridor
,spawnerRoom
,return $ connectRoom corridor
]
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door]
-- ++ [randomiseLinks =<< pistolerRoom]
-- ++ [return $ connectRoom door]
-- ++ [randomiseLinks =<< shooterRoom]
-- ++ (replicate 3 $ randomiseLinks corridor)
-- ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
-- ++ [return $ connectRoom corridor]
-- ++ (replicate 3 $ randomiseLinks corridor)
-- ++ [return $ connectRoom corridor]
-- ++[return $ connectRoom corridor,return $ connectRoom door]
-- ++ [shootingRange]
-- ++ (replicate 3 $ randomiseLinks corridor)
-- ++[roomMiniIntro]
-- ++ (replicate 3 $ randomiseLinks corridor)
-- ++ [return $ connectRoom corridor
-- ,return $ connectRoom door
-- ,slowDoorRoom]
-- ++ [return $ connectRoom corridor
-- ,spawnerRoom
-- ,return $ connectRoom corridor
-- ]
)
$ randomiseLinks corridor
src/Dodge/Layout.hs
+1
View File
@@ -10,6 +10,7 @@ import Dodge.Base
import Dodge.RandomHelp
import Dodge.Path
import Dodge.Layout.Tree
import Dodge.Room.Data
import Geometry
src/Dodge/LevelGen.hs
+2 -1
View File
@@ -4,7 +4,7 @@ module Dodge.LevelGen
( module Dodge.LevelGen
, cutWalls
, createInnerWalls
, checkWalls
-- , checkWalls
, nubWalls
, pairsToGraph
, makeButton
@@ -14,6 +14,7 @@ module Dodge.LevelGen
import Dodge.Data
import Dodge.Base
import Dodge.Room.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.LineBlock
src/Dodge/LevelGen/StaticWalls.hs
+49 -20
View File
@@ -18,14 +18,18 @@ import qualified Data.Set as S
-- given a polygon of points and collection of walls, cuts out the polygon
-- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls qs walls = createPolyWalls rs
. IM.filter (not.wallIsZeroLength)
. removeWallsInPolygon ps
$ fuseWallsWith zs cwals
where (zs,cwals) = cutWallsWithPoints ps walls
ps = orderPolygon qs
rs = orderPolygon $ nub $ zs ++ qs
cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls' qs walls =
IM.filter (not.wallIsZeroLength)
. fuseWallsWith zs
.createPolyWalls rs
. IM.filter (not.wallIsZeroLength)
. removeWallsInPolygon ps
$ fuseWallsWith zs cwals
where
(zs,cwals) = cutWallsWithPoints ps walls
ps = orderPolygon qs
rs = orderPolygon $ nub $ zs ++ qs
-- the overall procedure is:
-- split walls that intersect with the polygon into two
-- (possibly three if the wall extends across the polygon)
@@ -34,6 +38,30 @@ cutWalls qs walls = createPolyWalls rs
-- also remove any walls that ended up zero length
-- draw the required new walls along the polygon boundary
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of
[] -> newWalls
errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n"
++ unlines (map (show . f) errs)
++ "\nStart walls:\n"
++ unlines (map (show . g) (IM.elems wls))
++ "\nEnd walls:\n"
++ unlines (map (show . g) (IM.elems newWalls))
where
newWalls = cutWalls' ps wls
newWallsList = IM.elems newWalls
g v = (_wlID v, _wlLine v)
f (v,vs) = (g v, map g vs)
checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
[w] -> Nothing
wls -> Just (wl, wls)
checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
[w] -> Nothing
wls -> Just (wl,wls)
createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
@@ -154,21 +182,20 @@ finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith []
nubWalls :: IM.IntMap Wall -> IM.IntMap Wall
nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls
checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
Just wl -> error $ show $ _wlLine wl
_ -> wls
checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
== (map _wlLine $ IM.elems wls) = wls
| otherwise = error "hasdup"
--checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
--checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
-- Just wl -> error $ show $ _wlLine wl
-- _ -> wls
--
--checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
-- == (map _wlLine $ IM.elems wls) = wls
-- | otherwise = error "hasdup"
-- idea: create inner walls to draw and to cast shadows
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
createInnerWalls wls = IM.map (createInnerWall wls) wls
createInnerWall :: IM.IntMap Wall -> Wall -> Wall
--createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)]
createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
where wl0 = _wlLine wl !! 0
wl1 = _wlLine wl !! 1
@@ -183,14 +210,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
findWallLeft :: Wall -> IM.IntMap Wall -> Wall
findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
[w] -> w
wls -> error $ "findWallLeft: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
wls -> error $ "findWallLeft: " ++ show (map _wlID wls)
++ " wlLines: "++ show (map _wlLine wls)
findWallRight :: Wall -> IM.IntMap Wall -> Wall
findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
[w] -> w
wls -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
++ " wlLines: "++ show (map _wlLine wls)
wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
src/Dodge/Rendering/HUD.hs
+1
View File
@@ -102,6 +102,7 @@ mapWall w wl =
else Nothing
where
t = normalizeV (y -.- x)
-- n2 = 2 *.* vNormal t
n2 = 20 *.* vNormal t
(x:y:_) = (_wlLine wl)
c = _wlColor wl
src/Dodge/Room/Data.hs
+18
View File
@@ -0,0 +1,18 @@
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Room.Data
where
import Dodge.Data
import Control.Lens
data Room = Room
{ _rmPolys :: [Poly]
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmBound :: Poly
}
data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
makeLenses ''Room
makeLenses ''RoomLink
src/Dodge/Rooms.hs
+6 -1
View File
@@ -1,4 +1,8 @@
module Dodge.Rooms where
module Dodge.Rooms
-- ( module Dodge.Rooms
-- , module Dodge.Rooms.Data
-- )
where
-- imports {{{
import Dodge.Data
import Dodge.Item.Weapon
@@ -12,6 +16,7 @@ import Dodge.Path
import Dodge.Layout
import Dodge.LightSources
import Dodge.SoundLogic
import Dodge.Room.Data
import Dodge.Room.Placement