diff --git a/src/Dodge/Creature/Damage.hs b/src/Dodge/Creature/Damage.hs index c686e97ff..def11606e 100644 --- a/src/Dodge/Creature/Damage.hs +++ b/src/Dodge/Creature/Damage.hs @@ -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 diff --git a/src/Dodge/Data/Item.hs b/src/Dodge/Data/Item.hs index 6a201d667..bc6baabed 100644 --- a/src/Dodge/Data/Item.hs +++ b/src/Dodge/Data/Item.hs @@ -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 diff --git a/src/Dodge/Data/Item/Location.hs b/src/Dodge/Data/Item/Location.hs new file mode 100644 index 000000000..783806d4d --- /dev/null +++ b/src/Dodge/Data/Item/Location.hs @@ -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 diff --git a/src/Dodge/Data/Item/Misc.hs b/src/Dodge/Data/Item/Misc.hs index 6a31c2f67..4b4e1d226 100644 --- a/src/Dodge/Data/Item/Misc.hs +++ b/src/Dodge/Data/Item/Misc.hs @@ -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 diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 78b2d5d51..a96ef92b5 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -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 = diff --git a/src/Dodge/Item/Location.hs b/src/Dodge/Item/Location.hs index b46d97f15..7e486fc2d 100644 --- a/src/Dodge/Item/Location.hs +++ b/src/Dodge/Item/Location.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index af20c83cd..1bf7ca6d0 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -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 diff --git a/src/Dodge/Projectile/Create.hs b/src/Dodge/Projectile/Create.hs index 916987f81..8a9f0894a 100644 --- a/src/Dodge/Projectile/Create.hs +++ b/src/Dodge/Projectile/Create.hs @@ -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 diff --git a/src/Dodge/Projectile/Update.hs b/src/Dodge/Projectile/Update.hs index 643ff2967..1fac1faca 100644 --- a/src/Dodge/Projectile/Update.hs +++ b/src/Dodge/Projectile/Update.hs @@ -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 diff --git a/src/Dodge/RadarSweep.hs b/src/Dodge/RadarSweep.hs index e437d44f8..79cd303fc 100644 --- a/src/Dodge/RadarSweep.hs +++ b/src/Dodge/RadarSweep.hs @@ -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) $ diff --git a/src/IntMapHelp.hs b/src/IntMapHelp.hs index 299596442..7d05e8011 100644 --- a/src/IntMapHelp.hs +++ b/src/IntMapHelp.hs @@ -1,5 +1,3 @@ ---{-# LANGUAGE StandaloneDeriving #-} ---{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Loop.hs b/src/Loop.hs index 42c3df678..3bc9efa8b 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -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