From 7da1a8bc451038ec8b7821feb5295fc1309b14b6 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 24 Sep 2021 13:25:24 +0100 Subject: [PATCH] Move debug flags to config, various perf improvements --- appDodge/Main.hs | 22 +++-- src/Dodge/Base.hs | 14 +-- src/Dodge/Config/Data.hs | 23 ++--- src/Dodge/Creature/Picture.hs | 3 + src/Dodge/Data.hs | 9 +- src/Dodge/Debug/Flag/Data.hs | 10 -- src/Dodge/Debug/Terminal.hs | 4 +- src/Dodge/Default/World.hs | 10 +- src/Dodge/Initialisation.hs | 2 +- src/Dodge/Layout.hs | 6 -- src/Dodge/LevelGen/Block.hs | 7 +- src/Dodge/Menu.hs | 29 ++++-- src/Dodge/Room.hs | 2 +- src/Dodge/SoundLogic.hs | 10 +- src/Dodge/Update.hs | 21 ++-- src/Dodge/WallCreatureCollisions.hs | 59 +++++------ src/Loop.hs | 146 +++------------------------- 17 files changed, 112 insertions(+), 265 deletions(-) delete mode 100644 src/Dodge/Debug/Flag/Data.hs diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 1af8190a8..f0cee26a3 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -11,7 +11,6 @@ import Dodge.Config.KeyConfig import Dodge.Config.Load import Dodge.Config.Update import Dodge.SoundLogic.LoadSound -import Dodge.Debug.Flag.Data import Picture import Render import Preload.Render @@ -33,11 +32,13 @@ import qualified SDL import qualified SDL.Mixer as Mix --import qualified Control.Monad.Parallel as MP import Control.Parallel +import qualified Data.Map.Strict as M main :: IO () main = do (sizex,sizey) <- loadConfig - setupLoop' + setupLoop + 20 (sizex,sizey) theCleanup (firstWorldLoad (sizex,sizey)) @@ -68,21 +69,22 @@ updateRenderSplit w = do doSideEffects :: World -> IO World doSideEffects w = do let preData = _preloadData w - newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_sounds w) + newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_toPlaySounds w) w' <- _sideEffects w w endTicks <- SDL.ticks let lastFrameTicks = _frameTimer preData - when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable - (_pictureShaders $ _renderData preData) - (setDepth (-1) - . translate (-0.5) (-0.8) . scale 0.0005 0.0005 - . text $ "ms/frame " ++ show (endTicks - lastFrameTicks) - ) + when (_debug_seconds_frame $ _config w) $ void $ renderFoldable + (_pictureShaders $ _renderData preData) + (setDepth (-1) + . translate (-0.5) (-0.8) . scale 0.0005 0.0005 + . text $ "ms/frame " ++ show (endTicks - lastFrameTicks) + ) return $ w' & preloadData . frameTimer .~ endTicks & playingSounds .~ newPlayingSounds - & sideEffects .~ return + & toPlaySounds .~ M.empty + & sideEffects .~ return doPreload :: IO PreloadData doPreload = do diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index f1dfdf317..40f9cf577 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -281,13 +281,13 @@ collideCircWalls'' p1 p2 rad ws -- | Looks for first collision of a point with a list of lines. -- If found, gives point and normal of wall. -collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2) -collidePointLines p1 p2 ws - = safeMinimumOn f - $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) - . _wlLine') ws - where - f (a,_) = magV (p1 -.- a) +--collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2) +--collidePointLines p1 p2 ws +-- = safeMinimumOn f +-- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) +-- . _wlLine') ws +-- where +-- f (a,_) = magV (p1 -.- a) -- | Looks for first collision of a point with walls. -- If found, gives point and normal of wall. diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 15066c3b7..a61ce9229 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -1,23 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} -module Dodge.Config.Data ( - Configuration (..) - , defaultConfig - , volume_master - , volume_sound - , volume_music - , wall_textured - , cloud_shadows - , resolution_factor - , windowX - , windowY - , rotate_to_wall - , show_sound - ) where +module Dodge.Config.Data + where import Data.Aeson import GHC.Generics ---import System.Directory import Control.Lens data Configuration = Configuration { _volume_master :: Float @@ -30,6 +17,9 @@ data Configuration = Configuration , _windowY :: Float , _rotate_to_wall :: Bool , _show_sound :: Bool + , _debug_seconds_frame :: Bool + , _debug_noclip :: Bool + , _debug_cr_status :: Bool } deriving (Generic, Show) makeLenses ''Configuration @@ -51,4 +41,7 @@ defaultConfig = Configuration , _windowY = 600 , _rotate_to_wall = True , _show_sound = False + , _debug_seconds_frame = True + , _debug_noclip = False + , _debug_cr_status = False } diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 07190fbc7..3de7fa467 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -9,6 +9,7 @@ module Dodge.Creature.Picture , picAtCrPosNoRot ) where import Dodge.Data +import Dodge.Config.Data --import Dodge.Data.DamageType --import Dodge.Base --import Dodge.Creature.Stance.Data @@ -65,6 +66,8 @@ basicCrShape col cr = tr $ mconcat creatureDisplayText :: World -> Creature -> Picture creatureDisplayText w cr + | not (_debug_cr_status $ _config w) = [] + | otherwise = setLayer 4 . setDepth 50 . translate x y diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 4c233d79d..2f656108d 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -13,7 +13,6 @@ import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data import Dodge.Creature.Perception.Data import Dodge.Creature.Memory.Data -import Dodge.Debug.Flag.Data import Dodge.Data.SoundOrigin import Dodge.Data.DamageType import Dodge.Zone.Data @@ -71,7 +70,7 @@ data World = World , _worldEvents :: World -> World , _pressPlates :: IM.IntMap PressPlate , _buttons :: IM.IntMap Button - , _sounds :: M.Map SoundOrigin Sound + , _toPlaySounds :: M.Map SoundOrigin Sound , _playingSounds :: M.Map SoundOrigin Sound , _decorations :: IM.IntMap Picture , _foregroundShape :: Shape @@ -97,7 +96,6 @@ data World = World , _keyConfig :: KeyConfigSDL , _config :: Configuration , _sideEffects :: World -> IO World - , _debugFlags :: DebugFlags , _inventoryMode :: InventoryMode , _lClickHammer :: HammerPosition , _radDistortion :: [(Point2,Point2,Point2,Float)] @@ -504,11 +502,6 @@ data Projectile } data Either3 a b c = E3x1 a | E3x2 b | E3x3 c -data Wall' = Wall' - { _wlLine' :: (Point2,Point2) - , _wlColor' :: Color - } - data Wall = Wall { _wlLine :: (Point2,Point2) diff --git a/src/Dodge/Debug/Flag/Data.hs b/src/Dodge/Debug/Flag/Data.hs deleted file mode 100644 index 1e71a384b..000000000 --- a/src/Dodge/Debug/Flag/Data.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Debug.Flag.Data - where -import Control.Lens -data DebugFlags = DebugFlags - { _noClip :: Bool - , _displaySecondsPerFrame :: Bool - } -makeLenses ''DebugFlags diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index 25ec64ed7..84086f148 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -1,10 +1,10 @@ module Dodge.Debug.Terminal where import Dodge.Data -import Dodge.Debug.Flag.Data +import Dodge.Config.Data import Control.Lens applyTerminalString :: String -> World -> World -applyTerminalString "NOCLIP" w = w & debugFlags . noClip %~ not +applyTerminalString "NOCLIP" w = w & config . debug_noclip %~ not applyTerminalString _ w = w diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index bc5e56337..c35786ea2 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -3,7 +3,6 @@ module Dodge.Default.World import Dodge.Data import Dodge.Base import Dodge.Zone.Data -import Dodge.Debug.Flag.Data import Dodge.Config.Data import Dodge.Config.KeyConfig import Dodge.Item.Data @@ -48,7 +47,7 @@ defaultWorld = World , _worldEvents = id , _pressPlates = IM.empty , _buttons = IM.empty - , _sounds = M.empty + , _toPlaySounds = M.empty , _playingSounds = M.empty , _corpses = Zone IM.empty , _decorations = IM.empty @@ -76,7 +75,6 @@ defaultWorld = World , _keyConfig = defaultKeyConfigSDL , _config = defaultConfig , _sideEffects = return - , _debugFlags = defaultDebugFlags , _inventoryMode = TopInventory , _lClickHammer = HammerUp , _foregroundShape = mempty @@ -86,17 +84,11 @@ defaultWorld = World , _frameClock = 0 , _worldBounds = defaultBounds } -defaultDebugFlags :: DebugFlags -defaultDebugFlags = DebugFlags - { _noClip = False - , _displaySecondsPerFrame = True - } youLight :: TempLightSource youLight = TLS { _tlsPos = V3 0 0 0 ,_tlsRad = 300 ,_tlsIntensity = 0.1 - --,_tlsUpdate = \w _ -> (w, Nothing) ,_tlsUpdate = \w _ -> Just (youLight {_tlsPos = f $ _crPos (you w)}) ,_tlsTime = 0 } diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index df6110769..d1bd067d6 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -54,7 +54,7 @@ initialWorld = defaultWorld . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]] , _pressPlates = IM.empty , _buttons = IM.empty - , _sounds = M.empty + , _toPlaySounds = M.empty , _decorations = IM.empty , _storedLevel = Nothing , _menuLayers = [TerminalScreen 300 rezText'] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 9b20904b4..0f18ebcd8 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -95,12 +95,6 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] --pinc = M.fromList $ pairsToIncidence pairGraph -wallToWall :: Wall -> IM.IntMap (IM.IntMap [Wall']) -> IM.IntMap (IM.IntMap [Wall']) -wallToWall wl wls = foldl' (flip f) wls is - where - is = uncurry zoneOfLine (_wlLine wl) - wl' = Wall' {_wlLine' = _wlLine wl, _wlColor' = _wlColor wl} - f (x,y) = insertInZoneWith x y (++) [wl'] updateWallZoning :: World -> World updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 3f39c94df..56d9de0c4 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -22,9 +22,10 @@ import Data.Function import System.Random updateBlocks :: World -> World -updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes - $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) - degradeBlocks +updateBlocks w + = (\w' -> seq (_wallsZone w') w') + $ flip (foldr removeFromZone) deadPanes + $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks where degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks removeFromZone :: Wall -> World -> World diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index b2b70cc76..2f922f2a2 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -33,13 +33,30 @@ 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") + ] +debugOptionsMenu :: ScreenLayer +debugOptionsMenu = OptionScreen + { _scTitle = const "OPTIONS:GAMEPLAY" + , _scOptions = debugMenuOptions + , _scDefaultEff = popScreen . writeConfig + , _scOptionFlag = NormalOptions + } +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)) ] ---levelMenuOptions :: [MenuOption] ---levelMenuOptions = --- [ InvisibleToggle ScancodeEscape (const Nothing) --- , InvisibleToggle ScancodeO (pushScreen optionMenu) --- , InvisibleToggle ScancodeC (pushScreen displayControls) --- ] gameplayOptionsMenu :: ScreenLayer gameplayOptionsMenu = OptionScreen { _scTitle = const "OPTIONS:GAMEPLAY" diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 94764f88b..c0c6c48fd 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -479,7 +479,7 @@ pistolerRoom = do aa <- state $ randomR (0,2*pi) ab <- state $ randomR (0,2*pi) ac <- state $ randomR (0,2*pi) - let plmnts = [sPS (ps !! 0) aa $ PutCrit pistolCrit + 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 diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index 8e35a8460..277c7484f 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -48,7 +48,7 @@ soundWithStatus -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished -> World -> World -soundWithStatus status so pos sType mtime w = over sounds (M.insertWith f so sound) w +soundWithStatus status so pos sType mtime w = over toPlaySounds (M.insertWith f so sound) w where sound = Sound { _soundChunkID = sType @@ -86,7 +86,7 @@ soundFromGeneral -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished -> World -> World -soundFromGeneral so fpos sType mtime w = over sounds (M.insertWith f so sound) w +soundFromGeneral so fpos sType mtime w = over toPlaySounds (M.insertWith f so sound) w where sound = Sound { _soundChunkID = sType @@ -126,7 +126,7 @@ soundMultiFrom -> World soundMultiFrom [] _ _ _ w = w soundMultiFrom [so] pos sType mtime w - = over sounds (M.insert so sound) w + = over toPlaySounds (M.insert so sound) w where sound = Sound { _soundChunkID = sType @@ -140,7 +140,7 @@ soundMultiFrom [so] pos sType mtime w a = soundAngle pos w soundMultiFrom (so:sos) pos sType mtime w | so `M.member` _playingSounds w = soundMultiFrom sos pos sType mtime w - | otherwise = over sounds (M.insert so sound) w + | otherwise = over toPlaySounds (M.insert so sound) w where sound = Sound { _soundChunkID = sType @@ -154,5 +154,5 @@ soundMultiFrom (so:sos) pos sType mtime w a = soundAngle pos w {- | Sets '_soundTime' to 0. -} stopSoundFrom :: SoundOrigin -> World -> World -stopSoundFrom so = over (sounds . ix so . soundTime) (fmap $ min 0) +stopSoundFrom so = over (playingSounds . ix so . soundTime) (fmap $ min 0) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 2d723ae49..02505c0e4 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -30,7 +30,6 @@ import Data.Maybe import Data.Function import qualified Data.Set as S import qualified Data.IntMap.Lazy as IM -import qualified Data.Map as M import Control.Lens import Data.Monoid import System.Random @@ -50,8 +49,7 @@ functionalUpdate w = case _menuLayers w of (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> updateParticles . updateProjectiles . updateLightSources - . updateClouds - $ updateSoundQueue + $ updateClouds w (_ : _) -> w [] -> checkEndGame @@ -75,9 +73,9 @@ functionalUpdate w = case _menuLayers w of . updateCreatureGroups . updateBlocks . updateSeenWalls - . updateSoundQueue $ updateCloseObjects w where + --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w zoneCreatures = set (creaturesZone . znObjects) (IM.foldl' (flip creatureInZone) IM.empty (_creatures w)) creatureInZone cr = insertIMInZone x y cid cr @@ -119,9 +117,6 @@ updateTriggers w where cr = _creatures w IM.! 0 & crPos .~ V2 0 0 -updateSoundQueue :: World -> World -updateSoundQueue = set sounds M.empty - updateLightSources :: World -> World updateLightSources w = set tempLightSources tlss w where @@ -156,7 +151,7 @@ ppEvents :: World -> World ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w updateSeenWalls :: World -> World -updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate +updateSeenWalls w = foldr markSeen w wallsToUpdate where vPos = _cameraViewFrom w wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) @@ -229,10 +224,10 @@ clClSpringVel a v b radDist = (_clRad a + _clRad b) / 2 simpleCrSprings :: World -> World -simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w +simpleCrSprings w = IM.foldr crSpring w $ _creatures w crSpring :: Creature -> World -> World -crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs +crSpring c w = IM.foldr (crCrSpring c) w cs where cs = creaturesNearPoint (_crPos c) w @@ -241,8 +236,10 @@ crCrSpring c1 c2 w | id1 == id2 = w | vec == V2 0 0 = w | diff >= comRad = w - | otherwise = over (creatures . ix id1 . crPos) (+.+ overlap1) - $ over (creatures . ix id2 . crPos) (-.- overlap2) w + | otherwise = over creatures + ( over (ix id1 . crPos) (+.+ overlap1) + . over (ix id2 . crPos) (-.- overlap2) + ) w where id1 = _crID c1 id2 = _crID c2 diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index eadfd07f5..9474dd4a5 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -1,14 +1,16 @@ {- | Deals with moving creature wall collisions. -} -module Dodge.WallCreatureCollisions where +module Dodge.WallCreatureCollisions + ( colCrsWalls + ) where import Dodge.Data import Dodge.Data.DamageType import Dodge.Creature.State.Data -import Dodge.Debug.Flag.Data import Dodge.Zone import Dodge.Base +import Dodge.Config.Data import Geometry -import Data.List +import Data.Monoid import Data.Maybe import Data.Function import Control.Lens @@ -21,9 +23,7 @@ colCrWall :: World -> Creature -> Creature colCrWall w c | noclipIsOn && _crID c == 0 = c -- for noclip | p1 == p2 = pushOrCrush ls c - | otherwise = c & crPos %~ --- collideCorners rad wallPoints - collideWalls rad p1 ls + | otherwise = c & crPos %~ pushOutFromWalls rad ls . flip (collidePointWalls p1) wls -- check push throughs where rad = _crRad c + wallBuffer @@ -32,7 +32,7 @@ colCrWall w c ls = IM.elems $ _wlLine <$> wallsNearPoint p2 w wls = wallsNearPoint p2 w --wallPoints = map fst ls - noclipIsOn = _noClip $ _debugFlags w + noclipIsOn = _debug_noclip $ _config w -- the amount to push creatures out from walls, extra to their radius wallBuffer :: Float @@ -41,23 +41,11 @@ wallBuffer = 0 -- the following tests whether or not a point is on a wall, and if so pushes it -- out from the wall -- this is then repeated if the point ends up on a new wall -collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2 -collideWalls rad cp1 wls cp2 = case (listToMaybe . mapMaybe (pushOutFromWall rad cp2)) wls of - Nothing -> cp2 - Just cp3 -> case (listToMaybe . reverse . mapMaybe (pushOutFromWall rad cp3)) wls of - Nothing -> cp3 --- Just cp4 -> 0.5 *.* (cp4 +.+ cp1) - Just _ -> cp1 - --- pushes a point out from a list of walls --- if multiple new points occur, chooses the one closest to the orignal point pushOutFromWalls :: Float -> [(Point2,Point2)] -> Point2 -> Point2 -pushOutFromWalls rad wls p = - fromMaybe p - . listToMaybe - . sortBy (compare `on` dist p) - $ mapMaybe (pushOutFromWall rad p) - wls +pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of + Nothing -> p1 + Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall rad p2)) wls + -- possible improvement: choose between the closer of p2 and "p3" to p1 pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of @@ -80,18 +68,17 @@ pushOutFromWall rad cp2 (wp1,wp2) newP = errorClosestPointOnLine 5 wp1' wp2' cp2 isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad -pushOutFromCorners :: World -> Creature -> Creature -pushOutFromCorners w cr = cr & crPos .~ newPos - where - newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls - ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w +--pushOutFromCorners :: World -> Creature -> Creature +--pushOutFromCorners w cr = cr & crPos .~ newPos +-- where +-- newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls +-- ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w -collideCorners :: Float -> [Point2] -> Point2 -> Point2 -collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps - --- collide circles with points (outer corners) -intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 -intersectCirclePoint rad p cCen - | dist cCen p > rad = cCen - | otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p)) +--collideCorners :: Float -> [Point2] -> Point2 -> Point2 +--collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps +---- collide circles with points (outer corners) +--intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 +--intersectCirclePoint rad p cCen +-- | dist cCen p > rad = cCen +-- | otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p)) diff --git a/src/Loop.hs b/src/Loop.hs index c744abaa8..66446ee4d 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -7,64 +7,27 @@ This module sets up an SDL window which may be updated using a simple game loop. -} module Loop ( setupLoop - , setupMiniLoop - , setupLoop' ) where import qualified Data.Text as T import Control.Concurrent import Control.Exception import Control.Monad -import Control.Monad.Trans.Maybe import System.Mem --import Foreign.C import SDL import qualified Graphics.Rendering.OpenGL as GL -import qualified Data.Vector.Fusion.Stream.Monadic as VS ---import Control.Lens ((.~),(&),(+~)) + -- | Create a game loop with an SDL window. setupLoop - :: (Int,Int) -- ^ The window size. - -> IO params -- ^ Initial parameters. - -> (params -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop. - -> IO world -- ^ Initial simulation state. - -> (params -> world -> IO params) -- ^ Parameter update, called once per frame. Allows for side effects such as rendering. - -> (world -> Event -> Maybe world) - -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop. - -> (world -> Maybe world) - -- ^ Simulation update, once per frame. 'Nothing' exits the loop. - -> IO () -setupLoop - (xSize,ySize) - initParams - paramCleanup - ioStartWorld - sideEffects - eventFn - worldFn = do - startWorld <- ioStartWorld - initializeAll - bracket - (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) - destroyWindow - $ \window -> bracket - (glCreateContext window) - ( \con -> GL.finish >> glDeleteContext con) - $ \_ -> bracket - initParams - paramCleanup - $ doLoop window startWorld sideEffects eventFn worldFn - - --- | Create a game loop with an SDL window. -setupLoop' - :: (Int,Int) -- ^ The window size. + :: Int -- ^ Target seconds per frame + -> (Int,Int) -- ^ The window size. -> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop. -> IO world -- ^ Initial simulation state. -> (world -> IO world) -- ^ update, called once per frame. Allows for side effects such as rendering. -> (world -> Event -> Maybe world) -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop. -> IO () -setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do +setupLoop spf (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do initializeAll bracket (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) @@ -75,15 +38,17 @@ setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do $ \_ -> bracket ioStartWorld paramCleanup - $ doLoop' window sideEffects eventFn + $ doLoop spf window sideEffects eventFn -- | The internal loop. -doLoop' - :: Window -- ^ The SDL window. +doLoop + :: Int -- ^ target msec per frame + -> Window -- ^ The SDL window. -> (world -> IO world) -- ^ simulation update. -> (world -> Event -> Maybe world) -- ^ SDL Event handling. -> world -- ^ Current simulation state. -> IO () -doLoop' +doLoop + spf window worldSideEffects eventFn @@ -99,42 +64,10 @@ doLoop' performGC endTicks <- ticks -- it might be better to use System.Clock (monotonic) - let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks) + let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks) threadDelay (theDelay * 1000 ) - doLoop' window worldSideEffects eventFn updatedWorld - Nothing -> return () --- | The internal loop. -doLoop - :: Window -- ^ The SDL window. - -> world -- ^ Current simulation state. - -> (params -> world -> IO params) -- ^ Parameter update. - -> (world -> Event -> Maybe world) -- ^ SDL Event handling. - -> (world -> Maybe world) -- ^ Simulation update - -> params -- ^ Current parameters. - -> IO () -doLoop - window - startWorld - worldSideEffects - eventFn - worldUpdate - startParams - = do - startTicks <- ticks - newParams <- worldSideEffects startParams startWorld - glSwapWindow window - events <- pollEvents - maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just startWorld) events - case maybeUpdatedWorld >>= worldUpdate of - Just updatedWorld -> do - performGC - endTicks <- ticks -- it might be better to use System.Clock (monotonic) - - let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks) - threadDelay (theDelay * 1000 ) - - doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams + doLoop spf window worldSideEffects eventFn updatedWorld Nothing -> return () -- | Handle quit events in a manner to exit the loop. Other events handled as -- determined by the custom function, although resize events also change the viewport. @@ -156,59 +89,4 @@ winConfig x y = defaultWindow , windowResizable =True } -setupMiniLoop - :: (Int,Int) -- ^ The window size. - -> IO world -- ^ Initial simulation state. - -> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop. - -> (world -> Event -> MaybeT IO world) - -- ^ Event handling - -> (world -> MaybeT IO world) - -- ^ Simulation update - -> IO () -setupMiniLoop (xsize,ysize) initWorld cleanup eventUpdate simUpdate = do - bracket - (createWindow (T.pack "Mini Loop") (winConfig xsize ysize)) - destroyWindow - $ \window -> bracket - (glCreateContext window) - (\con -> GL.finish >> glDeleteContext con) - $ \_ -> bracket - initWorld - cleanup - (doMiniLoop window eventUpdate simUpdate) -doMiniLoop - :: Window - -> (world -> Event -> MaybeT IO world) - -> (world -> MaybeT IO world) - -> world - -> IO () -doMiniLoop window eventUpdate simUpdate startWorld = do - startTicks <- ticks - glSwapWindow window - mayWorld <- runMaybeT $ foldEventsT (plungeMaybe eventUpdate) startWorld >>= simUpdate - case mayWorld of - Just w -> do - performGC - endTicks <- ticks -- it might be better to use System.Clock (monotonic) - - let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks) - threadDelay (theDelay * 1000 ) - - doMiniLoop window eventUpdate simUpdate w - Nothing -> return () - -plungeMaybe :: (a -> b -> MaybeT IO a) -> Maybe a -> b -> IO (Maybe a) -plungeMaybe f a b = runMaybeT $ MaybeT (pure a) >>= flip f b - -foldEventsT :: (Maybe world -> Event -> IO (Maybe world)) -> world -> MaybeT IO world -foldEventsT f w = MaybeT $ foldEvents f w - -foldEvents :: (Maybe world -> Event -> IO (Maybe world)) -> world -> IO (Maybe world) -foldEvents f w = VS.foldlM' f (Just w) streamEvents - -streamEvents :: VS.Stream IO Event -streamEvents = VS.unfoldrM pollEventSeed () - -pollEventSeed :: () -> IO (Maybe (Event,())) -pollEventSeed _ = fmap (fmap (,())) pollEvent