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

Commit before attempting to add concurrency to loop

Browse Source
This commit is contained in:
justin
2022-08-16 08:00:47 +01:00
parent 9e3097d681
commit 919a179283
12 changed files with 129 additions and 138 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Damage.hs
+5 -8
View File
@@ -29,21 +29,18 @@ defaultApplyDamage ds cr w =
doPoisonDam = crHP -~ poisonDam
applyDamageEffect :: Damage -> DamageEffect -> Creature -> World -> World
applyDamageEffect dm de cr w = case de of
applyDamageEffect dm de cr = case de of
PushDamage push pushexp pushRad ->
w
& cWorld . creatures . ix (_crID cr) . crPos .+.+~ pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir)
cWorld . creatures . ix (_crID cr) . crPos .+.+~ pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir)
where
pushAmount
| dist (_crPos cr) fromDir == 0 = 0
| otherwise = min 5 $ (push * 5 * pushRad / (dist (_crPos cr) fromDir * _crMass cr)) ** pushexp
PushBackDamage pback ->
w
& cWorld . creatures . ix (_crID cr) . crPos .+.+~ (pback / _crMass cr) *.* (_dmTo dm -.- fromDir)
cWorld . creatures . ix (_crID cr) . crPos .+.+~ (pback / _crMass cr) *.* (_dmTo dm -.- fromDir)
TorqueDamage rot ->
w
& cWorld . creatures . ix (_crID cr) . crDir +~ rot
NoDamageEffect -> w
cWorld . creatures . ix (_crID cr) . crDir +~ rot
NoDamageEffect -> id
where
fromDir = _dmFrom dm
src/Dodge/Data/Item.hs
+2
View File
@@ -12,6 +12,7 @@ module Dodge.Data.Item (
module Dodge.Data.Item.Scope,
module Dodge.Data.Item.Combine,
module Dodge.Data.Item.Targeting,
module Dodge.Data.Item.Location,
) where
import Color
@@ -27,6 +28,7 @@ import Dodge.Data.Item.Params
import Dodge.Data.Item.Tweak
import Dodge.Data.Item.Use
import Dodge.Data.Item.Targeting
import Dodge.Data.Item.Location
data Item = Item
{ _itUse :: ItemUse
src/Dodge/Data/Item/Location.hs
+17
View File
@@ -0,0 +1,17 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Item.Location where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
data ItemLocation
= InInv {_ipCrID :: Int, _ipInvID :: Int}
| OnTurret {_ipTuID :: Int}
| OnFloor {_ipFlID :: Int}
| InVoid
deriving (Eq, Show, Read, Ord)
makeLenses ''ItemLocation
deriveJSON defaultOptions ''ItemLocation
src/Dodge/Data/Item/Misc.hs
-9
View File
@@ -33,19 +33,10 @@ data ItemValue = ItemValue
data ItemValueType = MundaneItem | ArtefactItem
deriving (Eq, Show, Read)
data ItemLocation
= InInv {_ipCrID :: Int, _ipInvID :: Int}
| OnTurret {_ipTuID :: Int}
| OnFloor {_ipFlID :: Int}
| InVoid
deriving (Eq, Show, Read)
makeLenses ''ItemDimension
makeLenses ''ItemPortage
makeLenses ''ItemValue
makeLenses ''ItemLocation
deriveJSON defaultOptions ''ItemDimension
deriveJSON defaultOptions ''ItemPortage
deriveJSON defaultOptions ''ItemValue
deriveJSON defaultOptions ''ItemValueType
deriveJSON defaultOptions ''ItemLocation
src/Dodge/HeldUse.hs
+4 -6
View File
@@ -1,15 +1,13 @@
module Dodge.HeldUse where
import Dodge.Creature.HandPos
import Dodge.Tesla.Arc
import Color
import Data.Maybe
import Data.Traversable
import Dodge.Base.Coordinate
import Dodge.Bullet
import Dodge.Creature.HandPos
import Dodge.Data.World
import Dodge.Gas
import Dodge.Item.Location
import Dodge.Item.Weapon.BatteryGuns
import Dodge.Item.Weapon.Launcher
import Dodge.Item.Weapon.Radar
@@ -18,6 +16,7 @@ import Dodge.Item.Weapon.TriggerType
import Dodge.Item.Weapon.Utility
import Dodge.Projectile.Create
import Dodge.SoundLogic
import Dodge.Tesla.Arc
import Dodge.WorldEvent.Flash
import Geometry
import qualified IntMapHelp as IM
@@ -357,7 +356,6 @@ useMod hm = case hm of
cr & crDir %~ tweenAngles x (_crOldDir cr)
& crPos %~ tweenPoints x (_crOldPos cr)
mcUseHeld :: HeldItemType -> Item -> Machine -> World -> World
mcUseHeld hit = case hit of
LASGUN -> mcShootLaser
@@ -449,9 +447,9 @@ fireRemoteShell it cr w =
set
(cWorld . creatures . ix cid . crInv . ix j . itUse . heldUse)
(HeldExplodeRemoteShell itid i)
$ addRemRocket w'
$ addRemRocket w
where
(w', itid) = getHeldItemLoc cr w
itid = _itID it
i = IM.newKey $ _props (_cWorld w)
cid = _crID cr
addRemRocket =
src/Dodge/Item/Location.hs
+5 -21
View File
@@ -1,27 +1,11 @@
module Dodge.Item.Location where
module Dodge.Item.Location (
pointerToItemLocation,
getItem,
pointerToItem,
) where
import Control.Lens
import Data.Maybe
import Dodge.Data.World
import qualified IntMapHelp as IM
setHeldItemLoc :: Creature -> World -> World
setHeldItemLoc cr = fst . getHeldItemLoc cr
getHeldItemLoc :: Creature -> World -> (World, Int)
getHeldItemLoc cr w = case maybeitid of
Nothing ->
( w & cWorld . creatures . ix cid . crInv . ix j . itID .~ newitid
& cWorld . itemLocations %~ IM.insert newitid (InInv cid j)
, itid
)
_ -> (w, itid)
where
cid = _crID cr
j = crSel cr
newitid = IM.newKey $ _itemLocations (_cWorld w)
maybeitid = cr ^? crInv . ix j . itID
itid = fromMaybe newitid maybeitid
getItem :: Int -> World -> Maybe Item
getItem itid w = do
src/Dodge/Item/Weapon/BatteryGuns.hs
+2 -3
View File
@@ -14,7 +14,6 @@ import Dodge.Base
import Dodge.Beam
import Dodge.Creature.HandPos
import Dodge.Data.World
import Dodge.Item.Location
import Dodge.Item.Weapon.LaserPath
import Geometry
import qualified IntMapHelp as IM
@@ -157,11 +156,11 @@ circleLaser it cr w
shootDualLaser :: Item -> Creature -> World -> World
shootDualLaser it cr w =
w'
w
& cWorld . newBeams . positronBeams .:~ dualRayAt (_lasBeam $ _itParams it) itid w (_lasColor $ _itParams it) dam phasev posl dirl
& cWorld . newBeams . electronBeams .:~ basicBeamAt itid w (_lasColor2 $ _itParams it) dam phasev posr dirr
where
(w', itid) = getHeldItemLoc cr w
itid = _itID it
dir = _crDir cr
pos = _crPos cr +.+ aimlength *.* unitVectorAtAngle dir
aimlength = aimingMuzzlePos cr it
src/Dodge/Projectile/Create.hs
+27 -32
View File
@@ -1,7 +1,6 @@
module Dodge.Projectile.Create where
import Dodge.Data.World
import Dodge.Item.Location
import Geometry
import qualified IntMapHelp as IM
import LensHelp
@@ -30,24 +29,22 @@ fireShell it cr =
makeShell :: Item -> Creature -> [ProjectileUpdate] -> World -> World
makeShell it cr theupdate w =
w & cWorld . projectiles
%~ IM.insert
i
Shell
{ _prjPos = pos
, _prjZ = 20
, _prjStartPos = pos
, _prjVel = rotateV dir (V2 1 0)
, _prjDraw = DrawShell
, _prjID = i
, _prjAcc = rotateV dir (V2 3 0)
, _prjDir = dir
, _prjSpin = 0
, _prjPayload = _amPayload $ _laAmmoType am
, _prjTimer = 350
, _prjUpdates = theupdate
, _prjMITID = Just $ _itID it
}
w & cWorld . projectiles . at i
?~ Shell
{ _prjPos = pos
, _prjZ = 20
, _prjStartPos = pos
, _prjVel = rotateV dir (V2 1 0)
, _prjDraw = DrawShell
, _prjID = i
, _prjAcc = rotateV dir (V2 3 0)
, _prjDir = dir
, _prjSpin = 0
, _prjPayload = _amPayload $ _laAmmoType am
, _prjTimer = 350
, _prjUpdates = theupdate
, _prjMITID = Just $ _itID it
}
where
i = IM.newKey $ _props (_cWorld w)
dir = _crDir cr
@@ -55,20 +52,18 @@ makeShell it cr theupdate w =
am = _heldConsumption $ _itUse it
fireTrackingShell :: Item -> Creature -> World -> World
fireTrackingShell it cr w = addTrackRocket w'
fireTrackingShell it cr =
makeShell
it
cr
[ PJRemoteShellCollisionCheck
, PJDecTimMvVel
, PJSpin 335 (_crID cr) spinamount
, PJTrack (350 - thrustdelay) 0 (_itID it)
, PJThrust (350 - thrustdelay) 0
, PJReduceSpin (1 - fromIntegral spindrag * 2 / 200)
]
where
(w', itid) = getHeldItemLoc cr w
addTrackRocket =
makeShell
it
cr
[ PJRemoteShellCollisionCheck
, PJDecTimMvVel
, PJSpin 335 (_crID cr) spinamount
, PJTrack (350 - thrustdelay) 0 itid
, PJThrust (350 - thrustdelay) 0
, PJReduceSpin (1 - fromIntegral spindrag * 2 / 200)
]
spinamount = _shellSpinAmount params
thrustdelay = _shellThrustDelay params
spindrag = _shellSpinDrag params
src/Dodge/Projectile/Update.hs
+4 -4
View File
@@ -33,8 +33,8 @@ updateProjectile pj = case pj of
shellCollisionCheck :: (Proj -> World -> World) -> Proj -> World -> World
shellCollisionCheck doExplode pj w
| time > 340 && circOnSomeWall oldPos 4 w = doExplode pj w
| time <= 340 && anythingHitCirc 2 oldPos newPos w = doExplode pj w
| time > 330 && circOnSomeWall oldPos 4 w = doExplode pj w
| time <= 330 && anythingHitCirc 2 oldPos newPos w = doExplode pj w
| time <= 0 = doExplode pj w
| otherwise = w
where
@@ -48,8 +48,8 @@ remoteShellCollisionCheck = shellCollisionCheck $ \pj -> explodeRemoteRocket (fr
plainShellCollisionCheck :: Proj -> World -> World
plainShellCollisionCheck = shellCollisionCheck $ \pj ->
(usePayload (_prjPayload pj) (_prjPos pj))
. (stopSoundFrom (ShellSound (_prjID pj)))
usePayload (_prjPayload pj) (_prjPos pj)
. stopSoundFrom (ShellSound (_prjID pj))
. (cWorld . projectiles %~ IM.delete (_prjID pj))
upsProjectile :: Proj -> World -> World
src/Dodge/RadarSweep.hs
+4 -8
View File
@@ -1,4 +1,7 @@
module Dodge.RadarSweep where
module Dodge.RadarSweep
( aRadarPulse
, updateRadarSweep
) where
import Color
import Data.Maybe
@@ -73,13 +76,6 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems . _cWorld
where
f q = dist p q <= r && dist p q > r - 4
--wallBlips :: Point2 -> Float -> World -> [Point2]
--wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
-- $ S.map (over wlLine swp) (wlsInsideCirc p r w)
-- <> wlsInsideCirc p r w
-- where
-- swp (a,b) = (b,a)
wallBlips :: Point2 -> Float -> World -> [Point2]
wallBlips p r w =
mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine) $
src/IntMapHelp.hs
-2
View File
@@ -1,5 +1,3 @@
--{-# LANGUAGE StandaloneDeriving #-}
--{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
src/Loop.hs
+59 -45
View File
@@ -1,77 +1,91 @@
--{-# LANGUAGE TupleSections #-}
{- |
Module : Loop
Description : Simple game loop
This module sets up an SDL window which may be updated using a simple game loop.
-}
module Loop
( setupLoop
) where
import qualified Data.Text as T
module Loop (
setupLoop,
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Mem
import SDL
import qualified Data.Text as T
import qualified Graphics.Rendering.OpenGL as GL
import SDL
import System.Mem
-- | Create a game loop with an SDL window.
setupLoop
:: Int -- ^ Target seconds per frame
-> T.Text -- ^ Window title
-> WindowConfig
-> (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 -> IO (Maybe world))
-- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
-> IO ()
setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
setupLoop ::
-- | Target seconds per frame
Int ->
-- | Window title
T.Text ->
WindowConfig ->
-- | Function for cleaning up parameters, applied when exiting loop.
(world -> IO ()) ->
-- | Initial simulation state.
IO world ->
-- | update, called once per frame. Allows for side effects such as rendering.
(world -> IO world) ->
-- | SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
(world -> Event -> IO (Maybe world)) ->
IO ()
setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
initializeAll
bracket
(createWindow title winconfig)
destroyWindow
$ \window -> bracket
(glCreateContext window)
( \con -> GL.finish >> glDeleteContext con)
$ \_ -> bracket
ioStartWorld
paramCleanup
(doLoop spf window sideEffects eventFn)
bracket
(createWindow title winconfig)
destroyWindow
$ \window -> bracket
(glCreateContext window)
(\con -> GL.finish >> glDeleteContext con)
$ \_ ->
bracket
ioStartWorld
paramCleanup
(doLoop spf window sideEffects eventFn)
-- | The internal loop.
doLoop
:: Int -- ^ target msec per frame
-> Window -- ^ The SDL window.
-> (world -> IO world) -- ^ simulation update.
-> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling.
-> world -- ^ Current simulation state.
-> IO ()
doLoop ::
-- | target msec per frame
Int ->
-- | The SDL window.
Window ->
-- | simulation update.
(world -> IO world) ->
-- | SDL Event handling.
(world -> Event -> IO (Maybe world)) ->
-- | Current simulation state.
world ->
IO ()
doLoop spf window worldSideEffects eventFn startWorld = do
startTicks <- ticks
worldAfterSimStep <- worldSideEffects startWorld
glSwapWindow window
maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep)
case maybeUpdatedWorld of
Just updatedWorld -> do
Just updatedWorld -> do
performGC
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks)
threadDelay (theDelay * 1000 )
threadDelay (theDelay * 1000)
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.
{- | 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.
-}
applyEventIO :: (world -> Event -> IO (Maybe world)) -> Maybe world -> Event -> IO (Maybe world)
applyEventIO fn mw e = case eventPayload e of
QuitEvent -> return Nothing
QuitEvent -> return Nothing
WindowClosedEvent _ -> return Nothing
WindowSizeChangedEvent WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y}
-> (GL.viewport $= (GL.Position 0 0,GL.Size x y)) >> mupdate
_ -> mupdate
WindowSizeChangedEvent WindowSizeChangedEventData{windowSizeChangedEventSize = V2 x y} ->
(GL.viewport $= (GL.Position 0 0, GL.Size x y)) >> mupdate
_ -> mupdate
where
mupdate = case mw of
Nothing -> return Nothing
Just w -> fn w e
Just w -> fn w e