feat(server): draft: does sim without I/O

4 files changed, 162 insertions, 7 deletions

diff --git a/grav2ty.cabal b/grav2ty.cabal
index 44ba47d..6be978a 100644
--- a/grav2ty.cabal
+++ b/grav2ty.cabal
@@ -25,6 +25,7 @@ library grav2ty-lib
                      , Grav2ty.Protocol
                      , Grav2ty.Util.RelGraph
                      , Grav2ty.Util.Serialization
+                     , System.Ticked
   -- other-extensions:
   build-depends:       base >=4.12 && <5
                      , containers ^>=0.6
@@ -34,6 +35,10 @@ library grav2ty-lib
                      , bytestring ^>=0.10
                      , flat^>=0.4
                      , attoparsec^>=0.13
+                     , network^>=3.1
+                     , stm^>=2.5
+                     , clock^>=0.8
+                     , async^>=2.2
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
@@ -49,6 +54,22 @@ library grav2ty-lib
 --  hs-source-dirs:      client
 --  default-language:    Haskell2010
 
+executable grav2ty-server
+  main-is:             Main.hs
+  build-depends:       base >=4.12 && <5
+                     , grav2ty-lib
+                     , linear >=1.20 && <1.22
+                     , time
+                     , network^>=3.1
+                     , lens >=4.17 && <4.20
+                     , containers ^>=0.6
+                     , transformers^>=0.5
+                     , clock^>=0.8
+                     , stm^>=2.5
+                     , async^>=2.2
+  hs-source-dirs:      server
+  default-language:    Haskell2010
+
 test-suite lib-test
   type:                exitcode-stdio-1.0
   main-is:             test/Main.hs
diff --git a/grav2ty.nix b/grav2ty.nix
index 6c416ff..25bc8de 100644
--- a/grav2ty.nix
+++ b/grav2ty.nix
@@ -1,5 +1,6 @@
-{ mkDerivation, aeson, base, bytestring, containers, flat, gloss
-, lens, linear, stdenv, tasty, tasty-quickcheck
+{ mkDerivation, attoparsec, base, bytestring, clock, containers
+, flat, gloss, lens, linear, network, stdenv, stm, tasty
+, tasty-quickcheck, time, transformers
 }:
 mkDerivation {
   pname = "grav2ty";
@@ -8,13 +9,15 @@ mkDerivation {
   isLibrary = false;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson base bytestring containers flat lens linear
+    attoparsec base bytestring clock containers flat lens linear
+    network stm transformers
+  ];
+  executableHaskellDepends = [
+    base clock containers gloss lens linear network stm time
+    transformers
   ];
-  executableHaskellDepends = [ base containers gloss lens linear ];
   testHaskellDepends = [ base tasty tasty-quickcheck ];
-  enableLibraryProfiling = true;
-  enableExecutableProfiling = true;
-  doHaddock = true;
+  doHaddock = false;
   description = "a 2d space (ship) game with realistic physics-based gameplay";
   license = stdenv.lib.licenses.gpl3;
 }
diff --git a/lib/System/Ticked.hs b/lib/System/Ticked.hs
new file mode 100644
index 0000000..ae4cfd8
--- /dev/null
+++ b/lib/System/Ticked.hs
@@ -0,0 +1,47 @@
+module System.Ticked
+  ( runTicked
+  , tickGenerator
+  , tickRunner
+  , Ticked (..)
+  ) where
+
+import System.Clock
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async
+import Control.Concurrent.STM.TBQueue
+import Control.Monad (when, forever, unless)
+import Control.Monad.STM
+import Data.Maybe
+
+newtype Ticked = Ticked { unTicked :: TBQueue () }
+
+tickGenerator :: Int -> Ticked -> Integer -> IO ()
+tickGenerator d (Ticked queue) tick = do
+  atomically $ unGetTBQueue queue ()
+  threadDelay d
+  tickGenerator d (Ticked queue) (tick + 1)
+
+tickRunner :: Ticked -> IO () -> IO ()
+tickRunner (Ticked q) action = forever $ do
+  _ <- atomically $ do
+    ts' <- readTBQueue q
+    writeTBQueue q ts'
+    pure ts'
+  action
+  _ <- atomically $ readTBQueue q
+  pure ()
+
+runTicked :: Int -> IO () -> IO ()
+runTicked delay action = do
+  tickQueue <- Ticked <$> newTBQueueIO 1
+
+  tr <- async $ tickRunner tickQueue action
+  link tr
+
+  tg <- async $ tickGenerator delay tickQueue 0
+  link tg
+
+  link2 tg tr
+
+  wait tg
+  wait tr
diff --git a/server/Main.hs b/server/Main.hs
new file mode 100644
index 0000000..94b0673
--- /dev/null
+++ b/server/Main.hs
@@ -0,0 +1,84 @@
+module Main where
+
+import Grav2ty.Core
+import Grav2ty.Control
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMVar
+import Control.Concurrent.STM.TChan
+import Control.Lens ((%=))
+import Control.Monad (forever, forM_)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.State.Lazy
+import qualified Data.Map as M
+import Linear.V2
+import System.Clock
+import System.Ticked
+
+initialState :: Grav2tyState Double ()
+initialState = Grav2tyState 0 (10^6) mempty ()
+  (M.fromList
+    [ (0, Dynamic (centeredCircle 10) 0 5000 (V2 0 200) (V2 15 0) (V2 0 0) NoMod Nothing Nothing)
+    , (1, Static (centeredCircle 80) 0 8e14 (V2 0 0)) ])
+  1
+
+data TickThreadMsg a
+  = TickThreadUpdates [Grav2tyUpdate a]
+  | TickThreadDone Tick TimeSpec
+  deriving (Show, Eq, Ord)
+
+processTick :: TMVar (Grav2tyState Double ()) -> TChan (TickThreadMsg Double) -> IO ()
+processTick svar chan = do
+  state <- atomically $ takeTMVar svar
+  before <- getTime Monotonic
+
+  forM_ (tickUpdates state) $ \updates ->
+    atomically $ writeTChan chan (TickThreadUpdates updates)
+
+  after <- getTime Monotonic
+  atomically
+    . writeTChan chan
+    $ TickThreadDone (_tick state) (diffTimeSpec before after)
+
+processUpdates :: TMVar (Grav2tyState Double ()) -> TChan (TickThreadMsg Double)
+               -> Grav2ty Double () IO ()
+processUpdates svar chan = forever $ do
+  msg <- liftIO . atomically $ readTChan chan
+  liftIO $ print msg
+
+  case msg of
+    TickThreadUpdates updates -> forM_ updates $ \u -> do
+      liftIO $ print u
+      case u of
+        DeleteObject i -> delObject i
+        UpdateObject i o -> setObject (Just i) o >> pure ()
+        NewObject o -> addObject o >> pure ()
+    TickThreadDone t timespec -> do
+      tick %= (+ 1)
+      state <- get
+      liftIO . putStrLn $ "Tick " ++ show t ++ " took "
+        ++ show (toNanoSecs timespec) ++ "ns"
+      liftIO . atomically $ putTMVar svar state
+
+main :: IO ()
+main = do
+  stateForTick <- newTMVarIO initialState
+  tickChan <- newTChanIO
+
+  tickThreads <- async
+    . runTicked (_timePerTick initialState)
+    $ processTick stateForTick tickChan
+
+  link tickThreads
+
+  stateThread <- async $ do
+    execStateT (processUpdates stateForTick tickChan) initialState
+    pure ()
+
+  link stateThread
+  link2 tickThreads stateThread
+
+  wait tickThreads
+  wait stateThread