phew...

cabal.project

@@ -1,2 +1,4 @@
-packages: ./
+packages:
+  ./
+  ../ecstasy/
 profiling: True

shell.nix

@@ -247,6 +247,7 @@ let
           random sdl stm text unordered-containers vector pkgconfig
         ];
         enableExecutableProfiling = true;
+        enableLibraryProfiling = true;
         license = stdenv.lib.licenses.gpl3;
       };
 

src/Main.hs

@@ -4,6 +4,7 @@ module Main where
 import Affection as A
 
 import Data.Ecstasy
+import Data.Ecstasy.Types
 
 import qualified SDL
 
@@ -62,7 +63,7 @@ pre = do
   _ <- partSubscribe k toggleFullScreen
   _ <- partSubscribe k quitGame
   u <- partSubscribe j cacheJoypad
-  (ws, _) <- yieldSystemT (0, defStorage) (return ())
+  (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
   putAffection ud
     { threadContext = Just threadCtx
     , window     = Just (drawWindow ad)
@@ -84,7 +85,7 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
       mapM_ (partUnSubscribe j) (uuid ud)
       mapM_ (partUnSubscribe t) (uuid ud)
       SDL.glMakeCurrent (drawWindow ad) (glContext ad)
-      (ws, _) <- yieldSystemT (0, defStorage) (return ())
+      (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
       putAffection ud
         { worldState = ws
         , state = Load

src/MainGame/WorldMap.hs

@@ -15,6 +15,7 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.State.Strict (evalStateT)
 import Control.Concurrent.MVar
 import Control.Concurrent (forkIO)
+import Control.Parallel.Strategies hiding (dot)
 
 import Data.Map.Strict as Map
 import qualified Data.Set as S
@@ -38,7 +39,6 @@ import Types
 import Floorplan
 import MindMap
 import NPC
--- import Object
 import Animation
 import Collision
 
@@ -236,10 +236,9 @@ loadMapFork ud ad future progress = do
       )))
     mapM_ (\cpr -> do
       fact <- liftIO $ randomRIO (0.5, 1.5)
-      -- fut <- liftIO newEmptyMVar
       stats <- liftIO $ NPCStats
         <$> (randomRIO (0, 1))
-        <*> (randomRIO (0, 1))
+        <*> pure 0
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
@@ -266,7 +265,6 @@ loadMapFork ud ad future progress = do
       ( p + increment
       , "Registering doors into WorldState"
       )))
-    -- let doors = Prelude.filter ((\t -> t == RoomExit || t == Elevator) . pointType) rps
     mapM_ (\door -> do
       let rooms = Prelude.foldl
             (\acc coord ->
@@ -340,37 +338,6 @@ loadMapFork ud ad future progress = do
       , roomGraph = gr
       })
 
--- mouseToPlayer :: V2 Int32 -> Affection UserData ()
--- mouseToPlayer mv2 = do
---   ud <- getAffection
---   (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
---   (nws, _) <- yieldSystemT (worldState ud) $
---     emap allEnts $ do
---       with player
---       return $ unchanged
---         { xyvel = Set $ V2 rx ry
---         }
---   putAffection ud
---     { worldState = nws
---     }
--- 
--- movePlayer :: MouseMessage -> Affection UserData ()
--- movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
--- movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
---   mouseToPlayer m
--- movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
---   ud <- getAffection
---   (nws, _) <- yieldSystemT (worldState ud) $
---     emap allEnts $ do
---       with player
---       return $ unchanged
---         { xyvel = Set $ V2 0 0
---         }
---   putAffection ud
---     { worldState = nws
---     }
--- movePlayer _ = return ()
-
 movePlayerKbd :: KeyboardMessage -> Affection UserData ()
 movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
   | SDL.keysymKeycode sym == SDL.KeycodeW = do
@@ -648,7 +615,7 @@ drawMap = do
         closePath ctx
         fillColor ctx (rgb 255 255 255)
         fill ctx
-        mapM_ (\(i, ls) -> mapM_
+        void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar
             (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
             (reverse $ zip [1..] ls))
           (zip [1..] (toLists mat))
@@ -729,8 +696,6 @@ drawTile ud ctx posanims pr pc row col img =
         nnc = case mbnds of
           Just (Boundaries (_, minc) (_, _)) -> minc
           Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double
-      -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
-      -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs
     tileWidth = 64 :: Double
     tileHeight = 32 :: Double
     sorted = sortOn (\(V2 sr sc, _, mbnds) ->
@@ -744,7 +709,6 @@ drawTile ud ctx posanims pr pc row col img =
               (sr - (fromIntegral ((floor sr) :: Int)))
               (sc - (fromIntegral ((floor sc) :: Int)))
       ) posanims
-    -- sorted = posanims
     minrs = Prelude.map (fst . matmin) mb
     maxrs = Prelude.map (fst . matmax) mb
     mincs = Prelude.map (snd . matmin) mb
@@ -770,8 +734,7 @@ drawTile ud ctx posanims pr pc row col img =
 updateMap :: Double -> Affection UserData ()
 updateMap dt = do
   ud <- getAffection
-  -- empty <- liftIO $ isEmptyMVar (stateMVar ud)
+  if stateData ud == None
-  if stateData ud == None -- && empty
   then do
     mstart <- liftIO $ tryTakeMVar (stateMVar ud)
     case mstart of
@@ -789,49 +752,6 @@ updateMap dt = do
       Nothing -> return ()
   else do
     (nws, _) <- yieldSystemT (worldState ud) $ do
-      emap allEnts $ do
-        with player
-        with xyvel
-        with vel
-        V2 rx ry <- query xyvel
-        let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
-        return $ unchanged
-          { vel = Set $ 2 * V2 dr dc
-          }
-      emap allEnts $ do
-        with anim
-        stat <- query anim
-        let an = assetAnimations ud Map.! asId stat
-            ntime = asElapsedTime stat + dt
-            nstate = if ntime > fromIntegral (asCurrentFrame stat + 1) *
-              (animDuration an / fromIntegral (length $ animSprites an))
-              then
-                let nframe = asCurrentFrame stat + 1
-                in  case animPlay an of
-                      APLoop ->
-                        let (nnframe, nntime) =
-                              if nframe >= length (animSprites an)
-                              then (0, 0)
-                              else (nframe, ntime)
-                        in  stat
-                              { asCurrentFrame = nnframe
-                              , asElapsedTime  = nntime
-                              }
-                      APOnce ->
-                        let nnframe = if nframe >= length (animSprites an)
-                              then nframe - 1
-                              else nframe
-                        in  stat
-                              { asCurrentFrame = nnframe
-                              , asElapsedTime  = ntime
-                              }
-              else
-                stat
-                  { asElapsedTime = ntime
-                  }
-        return $ unchanged
-          { anim = Set nstate
-          }
       obstacleBounds <- efor allEnts $ do
         with obstacle
         with pos
@@ -839,18 +759,15 @@ updateMap dt = do
         pos' <- query pos
         return (pos', b)
       emap allEnts $ do
-        without player
-        with vel
-        with velFact
-        with pos
-        with rot
-        with anim
         pos'@(V2 pr pc) <- query pos
-        vel' <- query vel
+        vel' <- queryMaybe vel
         rot' <- query rot
-        fact' <- query velFact
+        fact' <- fromMaybe 1 <$> queryMaybe velFact
+        xyv2 <- queryMaybe xyvel
         stat <- query anim
-        let npos = pos' + fmap (* (dt * fact')) vel'
+        let an = assetAnimations ud Map.! asId stat
+            ntime = asElapsedTime stat + dt
+            npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
             dpos@(V2 dpr dpc) = npos - pos'
             aId = asId stat
             lll = (,)
@@ -889,132 +806,80 @@ updateMap dt = do
                   )
                 lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
                 )
-            nstat = case aiName aId of
+            nstate =
-              "walking"
+              let velo = fromMaybe (V2 0 0) vel'
-                | sqrt (vel' `dot` vel') > 0 ->
+                  nstat = if ntime > fromIntegral (asCurrentFrame stat + 1) *
-                  stat
+                    (animDuration an / fromIntegral (length $ animSprites an))
-                    { asId = aId
+                    then
-                      { aiDirection = fromMaybe rot' (direction vel')
+                      let nframe = asCurrentFrame stat + 1
-                      }
+                      in  case animPlay an of
-                    }
+                            APLoop ->
-                | otherwise ->
+                              let (nnframe, nntime) =
-                  stat
+                                    if nframe >= length (animSprites an)
-                    { asId = aId
+                                    then (0, 0)
-                      { aiDirection = fromMaybe rot' (direction vel')
+                                    else (nframe, ntime)
-                      , aiName = "standing"
+                              in  stat
-                      }
+                                    { asCurrentFrame = nnframe
-                    , asCurrentFrame = 0
+                                    , asElapsedTime  = nntime
-                    }
+                                    }
-              "standing"
+                            APOnce ->
-                | sqrt (vel' `dot` vel') > 0 ->
+                              let nnframe = if nframe >= length (animSprites an)
-                  stat
+                                    then nframe - 1
-                    { asId = aId
+                                    else nframe
-                      { aiDirection = fromMaybe rot' (direction vel')
+                              in  stat
-                      , aiName = "walking"
+                                    { asCurrentFrame = nnframe
-                      }
+                                    , asElapsedTime  = ntime
-                    , asCurrentFrame = 0
+                                    }
-                    }
+                    else
-                | otherwise ->
+                      stat
-                  stat
+                        { asElapsedTime = ntime
-                    { asId = aId
+                        }
-                      { aiDirection = fromMaybe rot' (direction vel')
+              in
-                      }
+                case aiName aId of
-                    }
+                  "walking"
-              x -> error ("unknown animation name" ++ x)
+                    | sqrt (velo `dot` velo) > 0 ->
+                      nstat
+                        { asId = aId
+                          { aiDirection = fromMaybe rot' (direction velo)
+                          }
+                        }
+                    | otherwise ->
+                      nstat
+                        { asId = aId
+                          { aiDirection = fromMaybe rot' (direction velo)
+                          , aiName = "standing"
+                          }
+                        , asCurrentFrame = 0
+                        }
+                  "standing"
+                    | sqrt (velo `dot` velo) > 0 ->
+                      nstat
+                        { asId = aId
+                          { aiDirection = fromMaybe rot' (direction velo)
+                          , aiName = "walking"
+                          }
+                        , asCurrentFrame = 0
+                        }
+                    | otherwise ->
+                      nstat
+                        { asId = aId
+                          { aiDirection = fromMaybe rot' (direction velo)
+                          }
+                        }
+                  x -> nstat
             ent = unchanged
-              { pos = Set $ pos' + colldpos
+              { pos  = Set $ pos' + colldpos
-              , rot = Set $ fromMaybe rot' (direction vel')
+              , rot  = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
-              , anim = Set nstat
+              , anim = Set nstate
+              , vel  = case xyv2 of
+                Just (V2 rx ry) ->
+                  let 
+                    V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
+                  in
+                    Set $ 2 * V2 dr dc
+                Nothing -> Keep
               }
         return ent
-      emap allEnts $ do
-        with player
-        with vel
-        with pos
-        with rot
-        with anim
-        pos'@(V2 pr pc) <- query pos
-        vel' <- query vel
-        rot' <- query rot
-        stat <- query anim
-        let npos = pos' + fmap (* dt) vel'
-            dpos@(V2 dpr dpc) = npos - pos'
-            aId = asId stat
-            nstat = case aiName aId of
-              "walking"
-                | sqrt (colldpos `dot` colldpos) > 0 ->
-                  stat
-                    { asId = aId
-                      { aiDirection = fromMaybe rot' (direction vel')
-                      }
-                    }
-                | otherwise ->
-                  stat
-                    { asId = aId
-                      { aiDirection = fromMaybe rot' (direction vel')
-                      , aiName = "standing"
-                      }
-                    , asCurrentFrame = 0
-                    }
-              "standing"
-                | sqrt (colldpos `dot` colldpos) > 0 ->
-                  stat
-                    { asId = aId
-                      { aiDirection = fromMaybe rot' (direction vel')
-                      , aiName = "walking"
-                      }
-                    , asCurrentFrame = 0
-                    }
-                | otherwise ->
-                  stat
-                    { asId = aId
-                      { aiDirection = fromMaybe rot' (direction vel')
-                      }
-                    }
-              x -> error ("unknown animation name" ++ x)
-            lll = (,)
-              <$> (
-                if dpr < 0
-                then [(floor dpr :: Int) .. 0]
-                else [0 .. (ceiling dpr :: Int)])
-              <*> (
-                if dpc < 0
-                then [(floor dpc :: Int) .. 0]
-                else [0 .. (ceiling dpc :: Int)])
-            colldpos = dpos * Prelude.foldl
-              (\acc a ->
-                let ret = checkBoundsCollision2 pos' npos dt acc a
-                in A.log A.Verbose (show ret) ret)
-              (V2 1 1)
-              (
-                concatMap
-                (\(dr, dc) ->
-                  let bs = (++)
-                        (maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
-                          (fromIntegral $ floor pr + dr)
-                          (fromIntegral $ floor pc + dc)
-                          (imgMat (stateData ud))))
-                        (Prelude.map snd $ Prelude.filter
-                          (\((V2 br bc), _) ->
-                            floor pr + dr == floor br &&
-                            floor pc + dc == floor bc
-                            )
-                          obstacleBounds)
-                  in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
-                        Boundaries
-                          (minr + fromIntegral dr, minc + fromIntegral dc)
-                          (maxr + fromIntegral dr, maxc + fromIntegral dc)
-                        ) bs
-                  )
-                lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
-                )
-            ent = unchanged
-              { pos = Set $ pos' + colldpos
-              , rot = Set (fromMaybe rot' $ direction vel')
-              , anim = Set nstat
-              }
-        -- liftIO $ A.logIO A.Debug ("player position: " ++ show (pos' + colldpos))
-        return ent
       allRelEnts <- efor allEnts $ do
         with pos
         with rot
@@ -1046,33 +911,3 @@ updateMap dt = do
     putAffection ud
       { worldState = nws2
       }
-
--- checkBoundsCollision2
---   :: V2 Double
---   -> V2 Double
---   -> Double
---   -> V2 Double
---   -> Boundaries Double
---   -> V2 Double
--- checkBoundsCollision2
---   pre@(V2 pr pc) nex dt acc (Boundaries (minr, minc) (maxr, maxc))
---     | colltr < dt && colltc < dt = V2 0 0
---     | colltr < dt                = V2 0 0
---     | colltc < dt                = V2 0 0
---     | otherwise                  = acc
---     where
---       V2 vr vc = fmap (/ dt) (nex - pre)
---       colltr
---         | vr > 0 && prr <= maxr && (prc + 0.15 >= minc && prc - 0.15 <= maxc) =
---           ((fromIntegral (floor pr :: Int) + minr - 0.15) - pr) / vr
---         | vr < 0 && prr >= minr && (prc + 0.15 >= minc && prc - 0.15 <= maxc) =
---           ((fromIntegral (floor pr :: Int) + maxr + 0.15) - pr) / vr
---         | otherwise = dt
---       colltc
---         | vc > 0 && prc <= maxc && (prr + 0.15 >= minr && prr - 0.15 <= maxr) =
---           ((fromIntegral (floor pc :: Int) + minc - 0.15) - pc) / vc
---         | vc < 0 && prc >= minc && (prr + 0.15 >= minr && prr - 0.15 <= maxr) =
---           ((fromIntegral (floor pc :: Int) + maxc + 0.15) - pc) / vc
---         | otherwise = dt
---       prr = pr - fromIntegral (floor pr :: Int)
---       prc = pc - fromIntegral (floor pc :: Int)

src/NPC.hs

@@ -233,7 +233,7 @@ updateStats dt =
           else min 1 (conc + 0.1 * dt)
         , statBladder       =
           if food > 0 || drin > 0
-          then min 1 (blad + 0.3 * dt)
+          then min 1 (blad + 0.01 * dt)
           else blad
         , statThirst        = min 1 (if drin > 0 then thir else thir + 0.2 * dt)
         , statHunger        = min 1 (if food > 0 then hung else hung + 0.1 * dt)

src/Object/Copier.hs

@@ -7,14 +7,24 @@ module Object.Copier where
 import Affection as A
 
 import Control.Monad (when)
+import Control.Monad.IO.Class
 
 import Data.Ecstasy
 import Data.Maybe
+import Data.String (IsString(..))
 
 import Linear
 
 import Types
 
+copierObjectAction
+  :: (Monad m, MonadIO m, ActionTime ObjType ObjState)
+  => [(Ent, V2 Double, Direction, Word)]
+  -> Double
+  -> ObjType
+  -> ObjState
+  -> Ent
+  -> SystemT Entity m ()
 copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
   emap (anEnt ent) $ do
     mtime <- queryMaybe objStateTime
@@ -38,6 +48,14 @@ copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
 
 copierObjectAction _ _ _ _ _ = return ()
 
+copierObjectTransition
+  :: (Eq a, IsString a, MonadIO m)
+  => ObjType
+  -> a
+  -> Bool
+  -> Ent
+  -> Maybe Ent
+  -> SystemT Entity m (Entity 'SetterOf)
 copierObjectTransition ObjCopier "idle" playerActivated ent (Just aent) = do
   e <- efor (anEnt ent) $ do
       let nstat = AnimState

tracer-game.cabal

@@ -78,6 +78,7 @@ executable tracer-game
                      , bytestring
                      , algebraic-graphs
                      , mtl
+                     , parallel
   hs-source-dirs:      src
   ghc-options:         -Wall -threaded
   default-language:    Haskell2010