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

Nub close points for game room boundaries

Browse Source
This commit is contained in:
justin
2021-10-04 09:39:18 +01:00
parent df9a8ea242
commit c8e08d903e
8 changed files with 67 additions and 95 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Config/Data.hs
+2
View File
@@ -21,6 +21,7 @@ data Configuration = Configuration
, _debug_noclip :: Bool
, _debug_cr_status :: Bool
, _debug_view_boundaries :: Bool
, _debug_pathing :: Bool
}
deriving (Generic, Show)
makeLenses ''Configuration
@@ -46,4 +47,5 @@ defaultConfig = Configuration
, _debug_noclip = False
, _debug_cr_status = False
, _debug_view_boundaries = False
, _debug_pathing = False
}
src/Dodge/Item/Weapon/AutoGun.hs
+1 -1
View File
@@ -65,7 +65,7 @@ autoGun = defaultAutoGun
}
autoGunPic :: Item -> SPic
autoGunPic it =
( (colorSH red $ prismPoly
( colorSH red (prismPoly
(map (addZ 5) $ rectNESW 2 12 (-2) (-8))
(map (addZ 0) $ rectNESW 4 12 (-4) (-12))
)
src/Dodge/Layout.hs
+4 -2
View File
@@ -25,7 +25,7 @@ import Tile
import Polyhedra
import Polyhedra.Data
import Data.List (nub)
import Data.List (nubBy)
import Control.Monad.State
import Control.Lens
import System.Random
@@ -123,10 +123,12 @@ gameRoomsFromRooms = map f
f rm = GameRoom
{ _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
, _grViewpointsEx = map fst (_rmLinks rm)
, _grBound = expandPolyByFixed 100 . convexHullSafe . nub . concat $ _rmBound rm ++ _rmPolys rm
, _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints
. concat $ _rmBound rm ++ _rmPolys rm
, _grDir = snd . last $ _rmLinks rm
, _grName = _rmName rm
}
closePoints x y = dist x y < 1
floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
src/Dodge/LevelGen/Data.hs
+1 -1
View File
@@ -49,7 +49,7 @@ jsps0 :: PSType -> Maybe Placement
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
sps0 :: PSType -> Placement
sps0 pst = sPS (V2 0 0) 0 pst
sps0 = sPS (V2 0 0) 0
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
jspsJ p a pst plm = Just $ Placement (PS p a pst) $ \_ -> Just plm
src/Dodge/Menu.hs
+22 -29
View File
@@ -18,7 +18,6 @@ import Dodge.Initialisation
import Preload.Update
import Dodge.Base.Window
import Dodge.SoundLogic
--import Picture
import Control.Lens
optionMenu :: ScreenLayer
@@ -30,13 +29,15 @@ optionMenu = OptionScreen
}
optionsOptions :: [MenuOption]
optionsOptions =
[ Toggle ScancodeV (pushScreen soundMenu) (const "VOLUME")
, Toggle ScancodeG (pushScreen graphicsMenu) (const "GRAPHICS")
, Toggle ScancodeP (pushScreen gameplayOptionsMenu) (const "GAMEPLAY")
, Toggle ScancodeD (pushScreen debugOptionsMenu) (const "DEBUG OPTIONS")
[ anOption ScancodeV soundMenu "VOLUME"
, anOption ScancodeG graphicsMenu "GRAPHICS"
, anOption ScancodeP gameplayMenu "GAMEPLAY"
, anOption ScancodeD debugMenu "DEBUG OPTIONS"
]
debugOptionsMenu :: ScreenLayer
debugOptionsMenu = OptionScreen
where
anOption scode submenu t = Toggle scode (pushScreen submenu) (const t)
debugMenu :: ScreenLayer
debugMenu = OptionScreen
{ _scTitle = const "OPTIONS:GAMEPLAY"
, _scOptions = debugMenuOptions
, _scDefaultEff = popScreen . writeConfig
@@ -44,21 +45,16 @@ debugOptionsMenu = OptionScreen
}
debugMenuOptions :: [MenuOption]
debugMenuOptions =
[ Toggle ScancodeF
(Just . (config . debug_seconds_frame %~ not))
(\w -> "SHOW SECONDS/FRAME:" ++ show (_debug_seconds_frame $ _config w))
, Toggle ScancodeC
(Just . (config . debug_noclip %~ not))
(\w -> "NOCLIP:" ++ show (_debug_noclip $ _config w))
, Toggle ScancodeS
(Just . (config . debug_cr_status %~ not))
(\w -> "SHOW CREATURE STATUS:" ++ show (_debug_cr_status $ _config w))
, Toggle ScancodeV
(Just . (config . debug_view_boundaries %~ not))
(\w -> "SHOW VIEW BOUNDARIES:" ++ show (_debug_view_boundaries $ _config w))
[ doption ScancodeF debug_seconds_frame "SHOW SECONDS/FRAME" _debug_seconds_frame
, doption ScancodeC debug_noclip "NOCLIP" _debug_noclip
, doption ScancodeS debug_cr_status "SHOW CREATURE STATUS" _debug_cr_status
, doption ScancodeV debug_view_boundaries "SHOW VIEW BOUNDARIES" _debug_view_boundaries
, doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
]
gameplayOptionsMenu :: ScreenLayer
gameplayOptionsMenu = OptionScreen
where
doption scode l t rec = Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
gameplayMenu :: ScreenLayer
gameplayMenu = OptionScreen
{ _scTitle = const "OPTIONS:GAMEPLAY"
, _scOptions = gameplayMenuOptions
, _scDefaultEff = popScreen . writeConfig
@@ -66,15 +62,12 @@ gameplayOptionsMenu = OptionScreen
}
gameplayMenuOptions :: [MenuOption]
gameplayMenuOptions =
[ Toggle
ScancodeR
(Just . (config . rotate_to_wall %~ not))
(\w -> "ROTATE TO WALL:" ++ show (_rotate_to_wall $ _config w))
, Toggle
ScancodeS
(Just . (config . show_sound %~ not))
(\w -> "SHOW VISUAL SOUNDS:" ++ show (_show_sound $ _config w))
[ option ScancodeR rotate_to_wall "ROTATE TO WALL" _rotate_to_wall
, option ScancodeS show_sound "SHOW VISUAL SOUNDS" _show_sound
]
where
option scode l t rec = Toggle scode (Just . (config . l %~ not))
(\w -> t ++ ":" ++ show (rec $ _config w))
soundMenu :: ScreenLayer
soundMenu = OptionScreen
src/Dodge/Render/Picture.hs
+8 -6
View File
@@ -7,6 +7,7 @@ import Dodge.Data
import Dodge.Base
import Dodge.Base.Window
import Dodge.Zone
import Dodge.Graph
import Dodge.Picture
import Dodge.Picture.SizeInvariant
import Dodge.Picture.Layer
@@ -43,6 +44,7 @@ worldPictures w = pictures
,concatMapPic drawWallFloor $ wallFloorsToDraw w
,soundPics w
,viewBoundaries w
,drawPathing w
]
where
crIsClose cr = dist (_crPos cr) camCen < winSize
@@ -68,15 +70,15 @@ customMouseCursor w =
testPic :: World -> Picture
testPic _ = []
--testPic w = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
-- <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
-- where
-- p = _crPos $ you w
-- grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
-- where
-- thepic = setDepth 20 . color green . polygon $ rectNSEW 5 (-5) (-5) (5)
--testPic _ = blank
--testPic w = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
--testPic w =
drawPathing :: World -> Picture
drawPathing w
| _debug_pathing (_config w)
= color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
| otherwise = []
viewBoundaries :: World -> Picture
viewBoundaries w
| _debug_view_boundaries (_config w)
src/Dodge/Room/Link.hs
+3 -3
View File
@@ -66,7 +66,7 @@ shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ map (shiftPathPointBy shift)
& rmPath %~ map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmShift %~ shiftLinkBy shift
& rmFloor %~ map
@@ -82,8 +82,8 @@ shiftLinkBy
-> (Point2,Float)
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPathPointBy
shiftPathBy
:: (Point2,Float)
-> (Point2,Point2)
-> (Point2,Point2)
shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
src/Dodge/Room/Procedural.hs
+26 -53
View File
@@ -69,51 +69,35 @@ roomRect x y xn yn = defaultRoom
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
{- Combines two rooms into one room.
Combines into one big bound, concatenates the rest. -}
combineRooms :: Room -> Room -> Room
combineRooms r r' = defaultRoom
{ _rmPolys = _rmPolys r ++ _rmPolys r'
, _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmPath = _rmPath r ++ _rmPath r'
, _rmPath = map (shiftPathBy $ _rmShift r) (_rmPath r )
++ map (shiftPathBy $ _rmShift r') (_rmPath r')
, _rmPS = map (shiftPlacement $ _rmShift r) (_rmPS r)
++ map (shiftPlacement $ _rmShift r') (_rmPS r')
, _rmBound = _rmBound r ++ _rmBound r'
, _rmFloor = _rmFloor r ++ _rmFloor r'
, _rmShift = (V2 0 0 , 0)
}
--{- The top fourth of a room of a given height. -}
--fourth
-- :: Float -- ^ Distance from center of room to top edge
-- -> Room
--fourth w = Room
-- { _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
-- , _rmLinks = [((0,w), 0)]
-- , _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
-- , _rmPS =
-- [sPS (0,w/2) 0 putLamp
-- ]
-- , _rmBound = [[(0,0),(w,w),(-w,w)]]
-- }
{- Randomly generate a top fourth of a room possibly with a wall.
Add a light and a 'PutNothing' placement. -}
fourthWall :: RandomGen g => Float -> State g Room
fourthWall w = do
quarterRoomFlat :: RandomGen g => Float -> State g Room
quarterRoomFlat w = do
b <- takeOne
[ [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 40) 0 putLamp
[ [ mountedLightV (V2 0 w) (V3 0 (w-20) 70)
, mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
]
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 40) 0 putLamp
, [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
]
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 20) 0 putLamp
, [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) w) (V2 0 (w/2))
@@ -130,27 +114,20 @@ fourthWall w = do
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
b <- takeOne
[ [ sPS (V2 (10-w) w) 0 putLamp
, sPS (V2 (w-10) w) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 0 (2*w-20)) pi PutNothing
[ [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
, sPS (V2 20 (2*w-40)) pi PutNothing
]
, [ sPS (V2 0 (3*w/2)) 0 putLamp
, sPS (V2 (w-10) w) 0 putLamp
, sPS (V2 (10-w) (w-20) ) 0 putLamp
, sPS (V2 0 10 ) 0 putLamp
, sPS (V2 0 (2*w-20)) pi PutNothing
, [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) w ) (V2 0 w)
]
, [ sPS (V2 (10-w) w ) 0 putLamp
, sPS (V2 (w-10) w ) 0 putLamp
, sPS (V2 0 10 ) 0 putLamp
, sPS (V2 20 (2*w-40)) pi PutNothing
]
, [ mountedLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70)
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 0 w) (V2 0 (w*2))
, sPS (V2 20 (2*w-40)) pi PutNothing
]
]
pure $ defaultRoom
@@ -159,7 +136,9 @@ fourthCornerWall w = do
[(V2 (w/2) (3*w/2), negate $ pi/4)
,(V2 (negate $ w/2) (3*w/2), pi/4)
]
, _rmPath = [(V2 0 w,V2 0 0),(V2 0 0,V2 0 w)]
, _rmPath = [(V2 0 0,V2 w 0)
,(V2 0 0,V2 w w)
]
, _rmPS = b
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
@@ -185,7 +164,7 @@ shufflePlacements r = do
Tight corridors, random placements. -}
randomFourCornerRoom :: RandomGen g => State g Room
randomFourCornerRoom = do
corners <- replicateM 4 . join $ takeOne [fourthWall 100, fourthCornerWall 100]
corners <- replicateM 4 . join $ takeOne [quarterRoomFlat 100, fourthCornerWall 100]
nItms <- state $ randomR (1,2)
itms <- takeN nItms $ fmap PutFlIt $ [autoRadar,autoSonar,remoteLauncher,jetPack,blinkGun] ++ replicate 5 (medkit 500)
nCrits <- state $ randomR (1,3)
@@ -193,11 +172,11 @@ randomFourCornerRoom = do
++ replicate 20 chaseCrit
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements
. over rmPS ( sps0 putLamp :)
. foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
)
{- | Creates room with a central vault with doors around it.
-}
{- | Creates room with a central vault with doors around it. -}
centerVaultRoom
:: Float -- ^ Width
-> Float -- ^ Height
@@ -214,20 +193,16 @@ centerVaultRoom w h d = do
]
, _rmPath = []
, _rmPS =
[sps0 $ PutWall (rectNSEW ( d) (d - 30) ( d) (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW ( d) (d - 30) (-d) (30 - d)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) ( d) (d - 30)) defaultWall
[sps0 $ PutWall (rectNSEW d (d - 30) d (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) d (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
-- ,sps0 $ PutForeground $ girder 55 10 10 (V2 (-w) (h/2)) (V2 w (h/2))
,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
-- ,mountedLight (V2 (-w) (h/2-20)) (V3 (20-w) (h/2-20) 70)
-- ,mountedLight (V2 w (h/2-20)) (V3 (w-20) (h/2-20) 70)
-- ,mountedLightV (V2 0 (d-20)) (V3 0 0 70)
]
++ map (\a -> mountedLightV (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
[0,0.5*pi,pi,1.5*pi]
++ concat (map (\r -> map (shiftPlacement (V2 0 0,r)) $ theDoor)
[0,pi/2,pi,3*pi/2])
++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor)
[0,pi/2,pi,3*pi/2]
, _rmBound = [rectNSWE h (-h) (-w) w]
}
where
@@ -235,8 +210,6 @@ centerVaultRoom w h d = do
theDoor =
[ Placement (PS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 21 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 21 0) (V2 0 0) 2)
]
--cond i w' = or $ M.lookup (DoorNumOpen i) (_worldState w')
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn