diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index db3262671..15d5dd758 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -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 } diff --git a/src/Dodge/Item/Weapon/AutoGun.hs b/src/Dodge/Item/Weapon/AutoGun.hs index 73a56e80f..04643097d 100644 --- a/src/Dodge/Item/Weapon/AutoGun.hs +++ b/src/Dodge/Item/Weapon/AutoGun.hs @@ -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)) ) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index e41f53d56..67cdd2b62 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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) diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index bcb638c2d..789c7e805 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -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 diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 6fb6f5d30..2a42a70cd 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index bdb970574..eb983ec06 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -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) diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 016bbae68..e83ab814e 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -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) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index ac09195b6..e454cf06c 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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 -