-- Copyright (c) 2008--2011 Andres Loeh
-- Copyright (c) 2010--2021 Mikolaj Konarski and others (see git history)
-- This file is a part of the computer game Allure of the Stars
-- and is released under the terms of the GNU Affero General Public License.
-- For license and copyright information, see the file LICENSE.
--
-- | Here the knot of engine code pieces, frontend and the game-specific
-- content definitions is tied, resulting in an executable game.
module TieKnot
  ( tieKnotForAsync, tieKnot
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import           Control.Concurrent.Async
import qualified Control.Exception as Ex
import qualified Data.Primitive.PrimArray as PA
import           GHC.Compact
import qualified System.Random.SplitMix32 as SM

import           Game.LambdaHack.Client
import qualified Game.LambdaHack.Client.UI.Content.Input as IC
import qualified Game.LambdaHack.Client.UI.Content.Screen as SC
import           Game.LambdaHack.Client.UI.ContentClientUI
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.Point (speedupHackXSize)
import qualified Game.LambdaHack.Common.Tile as Tile
import qualified Game.LambdaHack.Content.CaveKind as CK
import qualified Game.LambdaHack.Content.FactionKind as FK
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.ModeKind as MK
import qualified Game.LambdaHack.Content.PlaceKind as PK
import qualified Game.LambdaHack.Content.RuleKind as RK
import qualified Game.LambdaHack.Content.TileKind as TK
import           Game.LambdaHack.Server

import qualified Client.UI.Content.Input as Content.Input
import qualified Client.UI.Content.Screen as Content.Screen
import qualified Content.CaveKind
import qualified Content.FactionKind
import qualified Content.ItemKind
import qualified Content.ModeKind
import qualified Content.PlaceKind
import qualified Content.RuleKind
import qualified Content.TileKind
import           Implementation.MonadServerImplementation (executorSer)

-- | Tie the LambdaHack engine client, server and frontend code
-- with the game-specific content definitions, and run the game.
--
-- The custom monad types to be used are determined by the @executorSer@
-- call, which in turn calls @executorCli@. If other functions are used
-- in their place- the types are different and so the whole pattern
-- of computation differs. Which of the frontends is run inside the UI client
-- depends on the flags supplied when compiling the engine library.
-- Similarly for the choice of native vs JS builds.
tieKnotForAsync :: ServerOptions -> IO ()
tieKnotForAsync :: ServerOptions -> IO ()
tieKnotForAsync options :: ServerOptions
options@ServerOptions{ Bool
sallClear :: ServerOptions -> Bool
sallClear :: Bool
sallClear
                                     , Bool
sboostRandomItem :: ServerOptions -> Bool
sboostRandomItem :: Bool
sboostRandomItem
                                     , Maybe SMGen
sdungeonRng :: ServerOptions -> Maybe SMGen
sdungeonRng :: Maybe SMGen
sdungeonRng } = do
  -- Set the X size of the dungeon from content ASAP, before it's used.
  MutablePrimArray RealWorld X
speedupHackXSizeThawed <- PrimArray X -> IO (MutablePrimArray (PrimState IO) X)
forall (m :: * -> *) a.
PrimMonad m =>
PrimArray a -> m (MutablePrimArray (PrimState m) a)
PA.unsafeThawPrimArray PrimArray X
speedupHackXSize
  MutablePrimArray (PrimState IO) X -> X -> X -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> X -> a -> m ()
PA.writePrimArray MutablePrimArray RealWorld X
MutablePrimArray (PrimState IO) X
speedupHackXSizeThawed X
0 (X -> IO ()) -> X -> IO ()
forall a b. (a -> b) -> a -> b
$
    RuleContent -> X
RK.rWidthMax RuleContent
Content.RuleKind.standardRules
  IO (PrimArray X) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (PrimArray X) -> IO ()) -> IO (PrimArray X) -> IO ()
forall a b. (a -> b) -> a -> b
$ MutablePrimArray (PrimState IO) X -> IO (PrimArray X)
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
PA.unsafeFreezePrimArray MutablePrimArray RealWorld X
MutablePrimArray (PrimState IO) X
speedupHackXSizeThawed
  -- This setup ensures the boosting option doesn't affect generating initial
  -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline
  -- equal to what was generated last time, ensures the same item boost.
  SMGen
initialGen <- IO SMGen -> (SMGen -> IO SMGen) -> Maybe SMGen -> IO SMGen
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO SMGen
SM.newSMGen SMGen -> IO SMGen
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SMGen
sdungeonRng
  let soptionsNxt :: ServerOptions
soptionsNxt = ServerOptions
options {sdungeonRng :: Maybe SMGen
sdungeonRng = SMGen -> Maybe SMGen
forall a. a -> Maybe a
Just SMGen
initialGen}
      corule :: RuleContent
corule = RuleContent -> RuleContent
RK.makeData RuleContent
Content.RuleKind.standardRules
      boostedItems :: [ItemKind]
boostedItems = SMGen -> [ItemKind] -> [ItemKind]
IK.boostItemKindList SMGen
initialGen [ItemKind]
Content.ItemKind.items
      itemContent :: [ItemKind]
itemContent =
        if Bool
sboostRandomItem
        then [ItemKind]
boostedItems [ItemKind] -> [ItemKind] -> [ItemKind]
forall a. [a] -> [a] -> [a]
++ [ItemKind]
Content.ItemKind.otherItemContent
        else [ItemKind]
Content.ItemKind.content
      coitem :: ContentData ItemKind
coitem = ItemSymbolsUsedInEngine
-> [ItemKind]
-> [GroupName ItemKind]
-> [GroupName ItemKind]
-> ContentData ItemKind
IK.makeData (RuleContent -> ItemSymbolsUsedInEngine
RK.ritemSymbols RuleContent
corule)
                           [ItemKind]
itemContent
                           [GroupName ItemKind]
Content.ItemKind.groupNamesSingleton
                           [GroupName ItemKind]
Content.ItemKind.groupNames
      cotile :: ContentData TileKind
cotile = [TileKind]
-> [GroupName TileKind]
-> [GroupName TileKind]
-> ContentData TileKind
TK.makeData [TileKind]
Content.TileKind.content
                           [GroupName TileKind]
Content.TileKind.groupNamesSingleton
                           [GroupName TileKind]
Content.TileKind.groupNames
      cofact :: ContentData FactionKind
cofact = [FactionKind]
-> [GroupName FactionKind]
-> [GroupName FactionKind]
-> ContentData FactionKind
FK.makeData [FactionKind]
Content.FactionKind.content
                           [GroupName FactionKind]
Content.FactionKind.groupNamesSingleton
                           [GroupName FactionKind]
Content.FactionKind.groupNames
      -- Common content operations, created from content definitions.
      -- Evaluated fully to discover errors ASAP and to free memory.
      -- Fail here, not inside server code, so that savefiles are not removed,
      -- because they are not the source of the failure.
      copsRaw :: COps
copsRaw = COps :: ContentData CaveKind
-> ContentData FactionKind
-> ContentData ItemKind
-> ContentData ModeKind
-> ContentData PlaceKind
-> RuleContent
-> ContentData TileKind
-> ItemSpeedup
-> TileSpeedup
-> COps
COps
        { cocave :: ContentData CaveKind
cocave = RuleContent
-> [CaveKind]
-> [GroupName CaveKind]
-> [GroupName CaveKind]
-> ContentData CaveKind
CK.makeData RuleContent
corule
                               [CaveKind]
Content.CaveKind.content
                               [GroupName CaveKind]
Content.CaveKind.groupNamesSingleton
                               [GroupName CaveKind]
Content.CaveKind.groupNames
        , ContentData FactionKind
cofact :: ContentData FactionKind
cofact :: ContentData FactionKind
cofact
        , ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: ContentData ItemKind
coitem
        , comode :: ContentData ModeKind
comode = ContentData FactionKind
-> [ModeKind]
-> [GroupName ModeKind]
-> [GroupName ModeKind]
-> ContentData ModeKind
MK.makeData ContentData FactionKind
cofact
                               [ModeKind]
Content.ModeKind.content
                               [GroupName ModeKind]
Content.ModeKind.groupNamesSingleton
                               [GroupName ModeKind]
Content.ModeKind.groupNames
        , coplace :: ContentData PlaceKind
coplace = ContentData TileKind
-> [PlaceKind]
-> [GroupName PlaceKind]
-> [GroupName PlaceKind]
-> ContentData PlaceKind
PK.makeData ContentData TileKind
cotile
                                [PlaceKind]
Content.PlaceKind.content
                                [GroupName PlaceKind]
Content.PlaceKind.groupNamesSingleton
                                [GroupName PlaceKind]
Content.PlaceKind.groupNames
        , RuleContent
corule :: RuleContent
corule :: RuleContent
corule
        , ContentData TileKind
cotile :: ContentData TileKind
cotile :: ContentData TileKind
cotile
        , coItemSpeedup :: ItemSpeedup
coItemSpeedup = ContentData ItemKind -> ItemSpeedup
speedupItem ContentData ItemKind
coitem
        , coTileSpeedup :: TileSpeedup
coTileSpeedup = Bool -> ContentData TileKind -> TileSpeedup
Tile.speedupTile Bool
sallClear ContentData TileKind
cotile
        }
  -- Evaluating for compact regions catches all kinds of errors in content ASAP,
  -- even in unused items.
  --
  -- Not using @compactWithSharing@, because it helps with residency,
  -- but nothing else and costs a bit at startup.
#ifdef USE_JSFILE
  let cops = copsRaw  -- until GHCJS implements GHC.Compact
#else
  COps
cops <- Compact COps -> COps
forall a. Compact a -> a
getCompact (Compact COps -> COps) -> IO (Compact COps) -> IO COps
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> COps -> IO (Compact COps)
forall a. a -> IO (Compact a)
compact COps
copsRaw
#endif
  -- Parse UI client configuration file.
  -- It is reparsed at each start of the game executable.
  -- Fail here, not inside client code, so that savefiles are not removed,
  -- because they are not the source of the failure.
  UIOptions
sUIOptions <- RuleContent -> ClientOptions -> IO UIOptions
mkUIOptions RuleContent
corule (ServerOptions -> ClientOptions
sclientOptions ServerOptions
soptionsNxt)
  -- Client content operations containing default keypresses
  -- and command descriptions.
  let !ccui :: CCUI
ccui = CCUI :: InputContent -> ScreenContent -> CCUI
CCUI
        { coinput :: InputContent
coinput = Maybe UIOptions -> InputContentRaw -> InputContent
IC.makeData (UIOptions -> Maybe UIOptions
forall a. a -> Maybe a
Just UIOptions
sUIOptions)
                                InputContentRaw
Content.Input.standardKeysAndMouse
        , coscreen :: ScreenContent
coscreen = RuleContent -> ScreenContent -> ScreenContent
SC.makeData RuleContent
corule ScreenContent
Content.Screen.standardLayoutAndFeatures
        }
  -- Wire together game content, the main loops of game clients
  -- and the game server loop.
  COps -> CCUI -> ServerOptions -> UIOptions -> IO ()
executorSer COps
cops CCUI
ccui ServerOptions
soptionsNxt UIOptions
sUIOptions

-- | Runs tieKnotForAsync in an async and applies the main thread workaround.
tieKnot :: ServerOptions -> IO ()
tieKnot :: ServerOptions -> IO ()
tieKnot ServerOptions
serverOptions = do
#ifdef USE_JSFILE
  -- Hard to tweak the config file when in the browser, so hardwire.
  let serverOptionsJS = serverOptions {sdumpInitRngs = True}
  a <- async $ tieKnotForAsync serverOptionsJS
  wait a
#else
  let fillWorkaround :: IO ()
fillWorkaround =
        -- Set up void workaround if nothing specific required.
        IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (IO ()) -> IO () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (IO ())
workaroundOnMainThreadMVar (IO () -> IO Bool) -> IO () -> IO Bool
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- Avoid the bound thread that would slow down the communication.
  Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ ServerOptions -> IO ()
tieKnotForAsync ServerOptions
serverOptions
               IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Ex.finally` IO ()
fillWorkaround
  -- Exit on an exception without waiting for frontend to spawn.
  Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
a
  -- Run a (possibly void) workaround. It's needed for OSes/frontends
  -- that need to perform some actions on the main thread
  -- (not just any bound thread), e.g., newer OS X drawing with SDL2.
  IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (MVar (IO ()) -> IO (IO ())
forall a. MVar a -> IO a
takeMVar MVar (IO ())
workaroundOnMainThreadMVar)
  -- Wait in case frontend workaround not run on the main thread
  -- and so we'd exit too early and end the game.
  Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
a
  -- Consume the void workaround if it was spurious to make @tieKnot@ reentrant.
  IO (Maybe (IO ())) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (IO ())) -> IO ()) -> IO (Maybe (IO ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (IO ()) -> IO (Maybe (IO ()))
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar (IO ())
workaroundOnMainThreadMVar
#endif