Commit before attempting to add concurrency to loop

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
-            & cWorld . creatures . ix (_crID cr) . crDir +~ rot
+    NoDamageEffect -> id
-    NoDamageEffect -> w
   where
     fromDir = _dmFrom dm
 

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

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

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

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 =

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

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

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,10 +29,8 @@ fireShell it cr =
 
 makeShell :: Item -> Creature -> [ProjectileUpdate] -> World -> World
 makeShell it cr theupdate w =
-    w & cWorld . projectiles
+    w & cWorld . projectiles . at i
-        %~ IM.insert
+        ?~ Shell
-            i
-            Shell
             { _prjPos = pos
             , _prjZ = 20
             , _prjStartPos = pos
@@ -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 =
-  where
-    (w', itid) = getHeldItemLoc cr w
-    addTrackRocket =
     makeShell
         it
         cr
         [ PJRemoteShellCollisionCheck
         , PJDecTimMvVel
         , PJSpin 335 (_crID cr) spinamount
-            , PJTrack (350 - thrustdelay) 0 itid
+        , PJTrack (350 - thrustdelay) 0 (_itID it)
         , PJThrust (350 - thrustdelay) 0
         , PJReduceSpin (1 - fromIntegral spindrag * 2 / 200)
         ]
+  where
     spinamount = _shellSpinAmount params
     thrustdelay = _shellThrustDelay params
     spindrag = _shellSpinDrag params

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 > 330 && circOnSomeWall oldPos 4 w = doExplode pj w
-    | time <= 340 && anythingHitCirc 2 oldPos newPos 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))
+             usePayload (_prjPayload pj) (_prjPos pj)
-            . (stopSoundFrom (ShellSound (_prjID pj)))
+            . stopSoundFrom (ShellSound (_prjID pj))
             . (cWorld . projectiles %~ IM.delete (_prjID pj))
 
 upsProjectile :: Proj -> World -> World

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) $

src/IntMapHelp.hs

@@ -1,5 +1,3 @@
---{-# LANGUAGE StandaloneDeriving #-}
---{-# LANGUAGE DeriveGeneric #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 

src/Loop.hs

@@ -1,31 +1,39 @@
 --{-# 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
+module Loop (
-    ( setupLoop
+    setupLoop,
-    ) where
+) where
-import qualified Data.Text as T
+
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
-import System.Mem
+import qualified Data.Text as T
-import SDL
 import qualified Graphics.Rendering.OpenGL as GL
+import SDL
+import System.Mem
+
 -- | Create a game loop with an SDL window.
-setupLoop
+setupLoop ::
-    :: Int                  -- ^ Target seconds per frame
+    -- | Target seconds per frame
-    -> T.Text               -- ^ Window title
+    Int ->
-    -> WindowConfig
+    -- | Window title
-    -> (world -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
+    T.Text ->
-    -> IO world             -- ^ Initial simulation state.
+    WindowConfig ->
-    -> (world -> IO world)   -- ^ update, called once per frame. Allows for side effects such as rendering.
+    -- | Function for cleaning up parameters, applied when exiting loop.
-    -> (world -> Event -> IO (Maybe world))
+    (world -> IO ()) ->
-                            -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
+    -- | Initial simulation state.
-    -> IO ()
+    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
@@ -33,19 +41,26 @@ setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
         destroyWindow
         $ \window -> bracket
             (glCreateContext window)
-            ( \con -> GL.finish >> glDeleteContext con)
+            (\con -> GL.finish >> glDeleteContext con)
-            $ \_   -> bracket 
+            $ \_ ->
+                bracket
                     ioStartWorld
                     paramCleanup
                     (doLoop spf window sideEffects eventFn)
+
 -- | The internal loop.
-doLoop
+doLoop ::
-    :: Int      -- ^ target msec per frame
+    -- | target msec per frame
-    -> Window   -- ^ The SDL window.
+    Int ->
-    -> (world -> IO world) -- ^ simulation update. 
+    -- | The SDL window.
-    -> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling.
+    Window ->
-    -> world    -- ^ Current simulation state.
+    -- | simulation update.
-    -> IO ()
+    (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
@@ -55,21 +70,20 @@ doLoop spf window worldSideEffects eventFn startWorld = 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
+{- | 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.
+ 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
     WindowClosedEvent _ -> return Nothing
-    WindowSizeChangedEvent WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y}
+    WindowSizeChangedEvent WindowSizeChangedEventData{windowSizeChangedEventSize = V2 x y} ->
-                        -> (GL.viewport $= (GL.Position 0 0,GL.Size x y)) >> mupdate
+        (GL.viewport $= (GL.Position 0 0, GL.Size x y)) >> mupdate
     _ -> mupdate
   where
     mupdate = case mw of