------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Task
-- Copyright   :  (c) 2012-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- Provides tasks that you can use with a daemon. These tasks handle
-- reading and writing agents, and various other housekeeping chores,
-- which reduces the amount of code you need to write.
--
-- It’s also easy to write your own tasks, using these as a guide.)
--
------------------------------------------------------------------------
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

module ALife.Creatur.Task
 (
    AgentProgram,
    AgentsProgram,
    withAgent,
    withAgents,
    runNoninteractingAgents,
    runInteractingAgents,
    simpleJob,
    startupHandler,
    shutdownHandler,
    doNothing,
    exceptionHandler,
    checkPopSize,
    requestShutdown
 ) where

import ALife.Creatur.Daemon (Job(..))
import qualified ALife.Creatur.Daemon as D
import ALife.Creatur.Universe (Universe, Agent, AgentProgram,
  AgentsProgram, writeToLog, lineup, refreshLineup, markDone, endOfRound,
  withAgent, withAgents, incTime, popSize)
import Control.Conditional (whenM)
import Control.Exception (SomeException)
import Control.Monad (when)
import Control.Monad.Catch (catchAll)
import Control.Monad.State (StateT, execStateT, evalStateT)
import Control.Monad.Trans.Class (lift)
import Data.Serialize (Serialize)
import GHC.Stack (callStack, prettyCallStack)

simpleJob :: Universe u => Job u
simpleJob :: Job u
simpleJob = Job :: forall s.
(s -> IO s)
-> (s -> IO ())
-> (s -> SomeException -> IO s)
-> StateT s IO ()
-> Int
-> Job s
Job
  {
    onStartup :: u -> IO u
onStartup = u -> IO u
forall u. Universe u => u -> IO u
startupHandler,
    onShutdown :: u -> IO ()
onShutdown = u -> IO ()
forall u. Universe u => u -> IO ()
shutdownHandler,
    onException :: u -> SomeException -> IO u
onException = u -> SomeException -> IO u
forall u. Universe u => u -> SomeException -> IO u
exceptionHandler,
    task :: StateT u IO ()
task = StateT u IO ()
forall a. HasCallStack => a
undefined,
    sleepTime :: Int
sleepTime = Int
100
  }

startupHandler :: Universe u => u -> IO u
startupHandler :: u -> IO u
startupHandler = StateT u IO () -> u -> IO u
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog (String -> StateT u IO ()) -> String -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting")

shutdownHandler :: Universe u => u -> IO ()
shutdownHandler :: u -> IO ()
shutdownHandler u
u = StateT u IO () -> u -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog String
"Shutdown requested") u
u

exceptionHandler :: Universe u => u -> SomeException -> IO u
exceptionHandler :: u -> SomeException -> IO u
exceptionHandler u
u SomeException
x = StateT u IO () -> u -> IO u
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog (String
"WARNING: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
x)) u
u

-- | Can be used as a startupHandler, shutdownHandler,
--   startRoundProgram, or endRoundProgram
doNothing :: Monad m => m ()
doNothing :: m ()
doNothing = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runNoninteractingAgents
  :: (Universe u, Serialize (Agent u))
    => AgentProgram u -> StateT u IO () -> StateT u IO ()
      -> StateT u IO ()
runNoninteractingAgents :: AgentProgram u
-> StateT u IO () -> StateT u IO () -> StateT u IO ()
runNoninteractingAgents AgentProgram u
agentProgram StateT u IO ()
startRoundProgram
    StateT u IO ()
endRoundProgram = do
  StateT u IO () -> StateT u IO ()
forall u. Universe u => StateT u IO () -> StateT u IO ()
atStartOfRound StateT u IO ()
startRoundProgram
  [String]
as <- StateT u IO [String]
forall u. Universe u => StateT u IO [String]
lineup
  Bool -> StateT u IO () -> StateT u IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [String]
as) (StateT u IO () -> StateT u IO ())
-> StateT u IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ do
    let a :: String
a = [String] -> String
forall a. [a] -> a
head [String]
as
    StateT u IO ()
-> (SomeException -> StateT u IO ()) -> StateT u IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAll (AgentProgram u -> String -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
AgentProgram u -> String -> StateT u IO ()
withAgent AgentProgram u
agentProgram String
a) SomeException -> StateT u IO ()
forall u. Universe u => SomeException -> StateT u IO ()
reportException
    String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
markDone String
a
    StateT u IO () -> StateT u IO ()
forall u. Universe u => StateT u IO () -> StateT u IO ()
atEndOfRound StateT u IO ()
endRoundProgram

--   The input parameter is a list of agents. The first agent in the
--   list is the agent whose turn it is to use the CPU. The rest of
--   the list contains agents it could interact with. For example, if
--   agents reproduce sexually, the program might check if the first
--   agent in the list is female, and the second one is male, and if so,
--   mate them to produce offspring. The input list is generated in a
--   way that guarantees that every possible sequence of agents has an
--   equal chance of occurring.

runInteractingAgents
  :: (Universe u, Serialize (Agent u))
    => AgentsProgram u -> StateT u IO () -> StateT u IO ()
      -> StateT u IO ()
runInteractingAgents :: AgentsProgram u
-> StateT u IO () -> StateT u IO () -> StateT u IO ()
runInteractingAgents AgentsProgram u
agentsProgram StateT u IO ()
startRoundProgram
    StateT u IO ()
endRoundProgram = do
  StateT u IO () -> StateT u IO ()
forall u. Universe u => StateT u IO () -> StateT u IO ()
atStartOfRound StateT u IO ()
startRoundProgram
  [String]
as <- StateT u IO [String]
forall u. Universe u => StateT u IO [String]
lineup
  StateT u IO ()
-> (SomeException -> StateT u IO ()) -> StateT u IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAll (AgentsProgram u -> [String] -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
AgentsProgram u -> [String] -> StateT u IO ()
withAgents AgentsProgram u
agentsProgram [String]
as) SomeException -> StateT u IO ()
forall u. Universe u => SomeException -> StateT u IO ()
reportException
  String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
markDone ([String] -> String
forall a. [a] -> a
head [String]
as)
  StateT u IO () -> StateT u IO ()
forall u. Universe u => StateT u IO () -> StateT u IO ()
atEndOfRound StateT u IO ()
endRoundProgram

reportException :: Universe u => SomeException -> StateT u IO ()
reportException :: SomeException -> StateT u IO ()
reportException SomeException
e = do
  String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog (String -> StateT u IO ()) -> String -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Unhandled exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
  String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog (String -> StateT u IO ()) -> String -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Call stack: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack

checkPopSize :: Universe u => (Int, Int) -> StateT u IO ()
checkPopSize :: (Int, Int) -> StateT u IO ()
checkPopSize (Int
minAgents, Int
maxAgents) = do
  Int
n <- StateT u IO Int
forall u. Universe u => StateT u IO Int
popSize
  String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog (String -> StateT u IO ()) -> String -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String
"Pop. size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
  Bool -> StateT u IO () -> StateT u IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minAgents) (StateT u IO () -> StateT u IO ())
-> StateT u IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
requestShutdown String
"population too small"
  Bool -> StateT u IO () -> StateT u IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxAgents) (StateT u IO () -> StateT u IO ())
-> StateT u IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
requestShutdown String
"population too big"

requestShutdown :: Universe u => String -> StateT u IO ()
requestShutdown :: String -> StateT u IO ()
requestShutdown String
s = do
  String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog (String -> StateT u IO ()) -> String -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String
"Requesting shutdown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
  IO () -> StateT u IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
D.requestShutdown

atStartOfRound :: Universe u => StateT u IO () -> StateT u IO ()
atStartOfRound :: StateT u IO () -> StateT u IO ()
atStartOfRound StateT u IO ()
program = do
  StateT u IO Bool -> StateT u IO () -> StateT u IO ()
forall bool (m :: * -> *).
(ToBool bool, Monad m) =>
m bool -> m () -> m ()
whenM StateT u IO Bool
forall u. Universe u => StateT u IO Bool
endOfRound (StateT u IO () -> StateT u IO ())
-> StateT u IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ do
    StateT u IO ()
forall u. Universe u => StateT u IO ()
refreshLineup
    StateT u IO ()
forall u. Universe u => StateT u IO ()
incTime
    String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog String
"Beginning of round"
    StateT u IO ()
program

atEndOfRound :: Universe u => StateT u IO () -> StateT u IO ()
atEndOfRound :: StateT u IO () -> StateT u IO ()
atEndOfRound StateT u IO ()
program = do
  StateT u IO Bool -> StateT u IO () -> StateT u IO ()
forall bool (m :: * -> *).
(ToBool bool, Monad m) =>
m bool -> m () -> m ()
whenM StateT u IO Bool
forall u. Universe u => StateT u IO Bool
endOfRound (StateT u IO () -> StateT u IO ())
-> StateT u IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog String
"End of round"
    StateT u IO ()
program

-- nothing :: StateT u IO ()
-- nothing = return ()

-- Note: There's no reason for the checklist type to be a parameter of
-- the Universe type. Users don't interact directly with it, so they
-- won't have any reason to want to use a different checklist
-- implementation.