------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Universe
-- Copyright   :  (c) 2012-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- Provides a habitat for artificial life.
--
------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
module ALife.Creatur.Universe
  (
    -- * Constructors
    Universe(..),
    SimpleUniverse,
    CachedUniverse,
    mkSimpleUniverse,
    mkCachedUniverse,
    -- * Clock
    currentTime,
    incTime,
    -- * Logging
    writeToLog,
    -- * Database
    agentIds,
    archivedAgentIds,
    popSize,
    getAgent,
    getAgentFromArchive,
    getAgents,
    -- addAgent,
    store,
    -- * Names
    genName,
    -- * Agent programs
    AgentProgram,
    withAgent,
    AgentsProgram,
    withAgents,
    isNew, -- exported for testing only
    -- * Agent rotation
    lineup,
    startOfRound,
    endOfRound,
    refreshLineup,
    markDone
 ) where

import           Prelude                                 hiding (lookup)

import qualified ALife.Creatur                           as A
import qualified ALife.Creatur.Checklist                 as CL
import qualified ALife.Creatur.Clock                     as C
import qualified ALife.Creatur.Counter                   as K
import qualified ALife.Creatur.Database                  as D
import qualified ALife.Creatur.Database.CachedFileSystem as CFS
import qualified ALife.Creatur.Database.FileSystem       as FS
import qualified ALife.Creatur.Logger                    as L
import qualified ALife.Creatur.Logger.SimpleLogger       as SL
import qualified ALife.Creatur.Namer                     as N
import           ALife.Creatur.Util                      (shuffle, stateMap)
import           Control.Exception                       (SomeException)
import           Control.Monad.Catch                     (catchAll)
import           Control.Monad.IO.Class                  (liftIO)
import           Control.Monad.Random                    (evalRandIO)
import           Control.Monad.State                     (StateT, get)
import           Data.Either                             (partitionEithers)
import           Data.Serialize                          (Serialize)
import           GHC.Stack
    (callStack, prettyCallStack)

-- | A habitat containing artificial life.
class (C.Clock (Clock u), L.Logger (Logger u), D.Database (AgentDB u),
  N.Namer (Namer u), CL.Checklist (Checklist u), A.Agent (Agent u),
  D.Record (Agent u), Agent u ~ D.DBRecord (AgentDB u))
      => Universe u where
  type Agent u
  type Clock u
  clock :: u -> Clock u
  setClock :: u -> Clock u -> u
  type Logger u
  logger :: u -> Logger u
  setLogger :: u -> Logger u -> u
  type AgentDB u
  agentDB :: u -> AgentDB u
  setAgentDB :: u -> AgentDB u -> u
  type Namer u
  agentNamer :: u -> Namer u
  setNamer :: u -> Namer u -> u
  type Checklist u
  checklist :: u -> Checklist u
  setChecklist :: u -> Checklist u -> u

withClock :: (Universe u, Monad m) => StateT (Clock u) m a -> StateT u m a
withClock :: StateT (Clock u) m a -> StateT u m a
withClock StateT (Clock u) m a
program = do
  u
u <- StateT u m u
forall s (m :: * -> *). MonadState s m => m s
get
  (Clock u -> u)
-> (u -> Clock u) -> StateT (Clock u) m a -> StateT u m a
forall (m :: * -> *) s t a.
Monad m =>
(s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap (u -> Clock u -> u
forall u. Universe u => u -> Clock u -> u
setClock u
u) u -> Clock u
forall u. Universe u => u -> Clock u
clock StateT (Clock u) m a
program

withLogger
  :: (Universe u, Monad m)
    => StateT (Logger u) m a -> StateT u m a
withLogger :: StateT (Logger u) m a -> StateT u m a
withLogger StateT (Logger u) m a
program = do
  u
u <- StateT u m u
forall s (m :: * -> *). MonadState s m => m s
get
  (Logger u -> u)
-> (u -> Logger u) -> StateT (Logger u) m a -> StateT u m a
forall (m :: * -> *) s t a.
Monad m =>
(s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap (u -> Logger u -> u
forall u. Universe u => u -> Logger u -> u
setLogger u
u) u -> Logger u
forall u. Universe u => u -> Logger u
logger StateT (Logger u) m a
program

withAgentDB
  :: (Universe u, Monad m)
    => StateT (AgentDB u) m a -> StateT u m a
withAgentDB :: StateT (AgentDB u) m a -> StateT u m a
withAgentDB StateT (AgentDB u) m a
program = do
  u
u <- StateT u m u
forall s (m :: * -> *). MonadState s m => m s
get
  (AgentDB u -> u)
-> (u -> AgentDB u) -> StateT (AgentDB u) m a -> StateT u m a
forall (m :: * -> *) s t a.
Monad m =>
(s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap (u -> AgentDB u -> u
forall u. Universe u => u -> AgentDB u -> u
setAgentDB u
u) u -> AgentDB u
forall u. Universe u => u -> AgentDB u
agentDB StateT (AgentDB u) m a
program

withNamer
  :: (Universe u, Monad m)
    => StateT (Namer u) m a -> StateT u m a
withNamer :: StateT (Namer u) m a -> StateT u m a
withNamer StateT (Namer u) m a
program = do
  u
u <- StateT u m u
forall s (m :: * -> *). MonadState s m => m s
get
  (Namer u -> u)
-> (u -> Namer u) -> StateT (Namer u) m a -> StateT u m a
forall (m :: * -> *) s t a.
Monad m =>
(s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap (u -> Namer u -> u
forall u. Universe u => u -> Namer u -> u
setNamer u
u) u -> Namer u
forall u. Universe u => u -> Namer u
agentNamer StateT (Namer u) m a
program

withChecklist
  :: (Universe u, Monad m)
    => StateT (Checklist u) m a -> StateT u m a
withChecklist :: StateT (Checklist u) m a -> StateT u m a
withChecklist StateT (Checklist u) m a
program = do
  u
u <- StateT u m u
forall s (m :: * -> *). MonadState s m => m s
get
  (Checklist u -> u)
-> (u -> Checklist u) -> StateT (Checklist u) m a -> StateT u m a
forall (m :: * -> *) s t a.
Monad m =>
(s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap (u -> Checklist u -> u
forall u. Universe u => u -> Checklist u -> u
setChecklist u
u) u -> Checklist u
forall u. Universe u => u -> Checklist u
checklist StateT (Checklist u) m a
program

-- | The current "time" (counter) in this universe
currentTime :: Universe u => StateT u IO A.Time
currentTime :: StateT u IO Time
currentTime = StateT (Clock u) IO Time -> StateT u IO Time
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Clock u) m a -> StateT u m a
withClock StateT (Clock u) IO Time
forall c. Clock c => StateT c IO Time
C.currentTime

-- | Increment the current "time" (counter) in this universe.
incTime :: Universe u => StateT u IO ()
incTime :: StateT u IO ()
incTime = StateT (Clock u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Clock u) m a -> StateT u m a
withClock StateT (Clock u) IO ()
forall c. Clock c => StateT c IO ()
C.incTime

-- | Write a message to the log file for this universe.
writeToLog :: Universe u => String -> StateT u IO ()
writeToLog :: String -> StateT u IO ()
writeToLog String
msg = do
  Time
t <- StateT u IO Time
forall u. Universe u => StateT u IO Time
currentTime
  let logMsg :: String
logMsg = Time -> String
forall a. Show a => a -> String
show Time
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  StateT (Logger u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Logger u) m a -> StateT u m a
withLogger (StateT (Logger u) IO () -> StateT u IO ())
-> StateT (Logger u) IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String -> StateT (Logger u) IO ()
forall l. Logger l => String -> StateT l IO ()
L.writeToLog String
logMsg

-- | Generate a unique name for a new agent.
genName :: Universe u => StateT u IO A.AgentId
genName :: StateT u IO String
genName = StateT (Namer u) IO String -> StateT u IO String
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Namer u) m a -> StateT u m a
withNamer StateT (Namer u) IO String
forall n. Namer n => StateT n IO String
N.genName

-- | Returns the list of agents in the population.
agentIds :: Universe u => StateT u IO [A.AgentId]
agentIds :: StateT u IO [String]
agentIds = StateT (AgentDB u) IO [String] -> StateT u IO [String]
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB StateT (AgentDB u) IO [String]
forall d. Database d => StateT d IO [String]
D.keys

-- | Returns the list of (dead) agents in the archive.
archivedAgentIds :: Universe u => StateT u IO [A.AgentId]
archivedAgentIds :: StateT u IO [String]
archivedAgentIds = StateT (AgentDB u) IO [String] -> StateT u IO [String]
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB StateT (AgentDB u) IO [String]
forall d. Database d => StateT d IO [String]
D.archivedKeys

-- | Returns the current size of the population.
popSize :: Universe u => StateT u IO Int
popSize :: StateT u IO Time
popSize = StateT (AgentDB u) IO Time -> StateT u IO Time
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB StateT (AgentDB u) IO Time
forall d. Database d => StateT d IO Time
D.numRecords

-- | Fetches the agent with the specified ID from the population.
--   Note: Changes made to this agent will not "take" until
--   @'store'@ is called.
getAgent
  :: (Universe u, Serialize (Agent u))
    => A.AgentId -> StateT u IO (Either String (Agent u))
getAgent :: String -> StateT u IO (Either String (Agent u))
getAgent String
name = do
  Either String (DBRecord (AgentDB u))
result <- StateT (AgentDB u) IO (Either String (DBRecord (AgentDB u)))
-> StateT u IO (Either String (DBRecord (AgentDB u)))
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB (String
-> StateT (AgentDB u) IO (Either String (DBRecord (AgentDB u)))
forall d.
(Database d, Serialize (DBRecord d)) =>
String -> StateT d IO (Either String (DBRecord d))
D.lookup String
name)
  case Either String (DBRecord (AgentDB u))
result of
    Left String
msg -> 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
"Unable to read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
      String -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
String -> StateT u IO ()
archive String
name
    Right DBRecord (AgentDB u)
_  -> () -> StateT u IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Either String (DBRecord (AgentDB u))
-> StateT u IO (Either String (DBRecord (AgentDB u)))
forall (m :: * -> *) a. Monad m => a -> m a
return Either String (DBRecord (AgentDB u))
result

-- | Fetches the agent with the specified ID from the archive.
getAgentFromArchive
  :: (Universe u, Serialize (Agent u))
    => A.AgentId -> StateT u IO (Either String (Agent u))
getAgentFromArchive :: String -> StateT u IO (Either String (Agent u))
getAgentFromArchive String
name = StateT (AgentDB u) IO (Either String (DBRecord (AgentDB u)))
-> StateT u IO (Either String (DBRecord (AgentDB u)))
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB (String
-> StateT (AgentDB u) IO (Either String (DBRecord (AgentDB u)))
forall d.
(Database d, Serialize (DBRecord d)) =>
String -> StateT d IO (Either String (DBRecord d))
D.lookupInArchive String
name)

-- | Fetches the agents with the specified IDs from the population.
getAgents
  :: (Universe u, Serialize (Agent u))
    => [A.AgentId] -> StateT u IO [Agent u]
getAgents :: [String] -> StateT u IO [Agent u]
getAgents [String]
names = do
  [Either String (DBRecord (AgentDB u))]
selected <- (String -> StateT u IO (Either String (DBRecord (AgentDB u))))
-> [String] -> StateT u IO [Either String (DBRecord (AgentDB u))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> StateT u IO (Either String (DBRecord (AgentDB u)))
forall u.
(Universe u, Serialize (Agent u)) =>
String -> StateT u IO (Either String (Agent u))
getAgent [String]
names
  let ([String]
msgs, [DBRecord (AgentDB u)]
agents) = [Either String (DBRecord (AgentDB u))]
-> ([String], [DBRecord (AgentDB u)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String (DBRecord (AgentDB u))]
selected
  (String -> StateT u IO ()) -> [String] -> StateT u IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> StateT u IO ()
forall u. Universe u => String -> StateT u IO ()
writeToLog [String]
msgs
  [DBRecord (AgentDB u)] -> StateT u IO [DBRecord (AgentDB u)]
forall (m :: * -> *) a. Monad m => a -> m a
return [DBRecord (AgentDB u)]
agents

-- | If the agent is alive, adds it to the population (replacing the
--   the previous copy of that agent, if any). If the agent is dead,
--   places it in the archive.
store
  :: (Universe u, Serialize (Agent u))
    => Agent u -> StateT u IO ()
store :: Agent u -> StateT u IO ()
store Agent u
a = do
  Bool
newAgent <- String -> StateT u IO Bool
forall u. Universe u => String -> StateT u IO Bool
isNew (DBRecord (AgentDB u) -> String
forall a. Agent a => a -> String
A.agentId DBRecord (AgentDB u)
Agent u
a)
  StateT (AgentDB u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB (DBRecord (AgentDB u) -> StateT (AgentDB u) IO ()
forall d.
(Database d, Record (DBRecord d), Serialize (DBRecord d)) =>
DBRecord d -> StateT d IO ()
D.store DBRecord (AgentDB u)
Agent u
a) -- Even dead agents should be stored (prior to archiving)
  if DBRecord (AgentDB u) -> Bool
forall a. Agent a => a -> Bool
A.isAlive DBRecord (AgentDB u)
Agent u
a
    then
      if Bool
newAgent
         then 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
$ DBRecord (AgentDB u) -> String
forall a. Agent a => a -> String
A.agentId DBRecord (AgentDB u)
Agent u
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" added to population"
         else 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
$ DBRecord (AgentDB u) -> String
forall a. Agent a => a -> String
A.agentId DBRecord (AgentDB u)
Agent u
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned to population"
    else String -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
String -> StateT u IO ()
archive (DBRecord (AgentDB u) -> String
forall a. Agent a => a -> String
A.agentId DBRecord (AgentDB u)
Agent u
a)

archive
  :: (Universe u, Serialize (Agent u))
    => A.AgentId -> StateT u IO ()
archive :: String -> StateT u IO ()
archive String
name = do
  StateT (AgentDB u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (AgentDB u) m a -> StateT u m a
withAgentDB (StateT (AgentDB u) IO () -> StateT u IO ())
-> StateT (AgentDB u) IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String -> StateT (AgentDB u) IO ()
forall d.
(Database d, Serialize (DBRecord d)) =>
String -> StateT d IO ()
D.delete String
name
  StateT (Checklist u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Checklist u) m a -> StateT u m a
withChecklist (StateT (Checklist u) IO () -> StateT u IO ())
-> StateT (Checklist u) IO () -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ String -> StateT (Checklist u) IO ()
forall t. Checklist t => String -> StateT t IO ()
CL.delete String
name
  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
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" archived and removed from lineup"

isNew :: Universe u => A.AgentId -> StateT u IO Bool
isNew :: String -> StateT u IO Bool
isNew String
name = ([String] -> Bool) -> StateT u IO [String] -> StateT u IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`) StateT u IO [String]
forall u. Universe u => StateT u IO [String]
agentIds

-- -- | Adds an agent to the universe.
-- addAgent
--   :: (Universe u, Serialize (Agent u))
--     => Agent u -> StateT u IO ()
-- addAgent a = withAgentDB $ D.store a

-- | A program involving one agent.
--   The input parameter is the agent.
--   The program must return the agent (which may have been modified).
type AgentProgram u = Agent u -> StateT u IO (Agent u)

-- | Run a program involving one agent
withAgent
  :: (Universe u, Serialize (Agent u))
    => AgentProgram u -> A.AgentId -> StateT u IO ()
withAgent :: AgentProgram u -> String -> StateT u IO ()
withAgent AgentProgram u
program String
name = do
  Either String (DBRecord (AgentDB u))
result <- String -> StateT u IO (Either String (Agent u))
forall u.
(Universe u, Serialize (Agent u)) =>
String -> StateT u IO (Either String (Agent u))
getAgent String
name
  case Either String (DBRecord (AgentDB u))
result of
    Left String
msg ->
      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
"Unable to read '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
    Right DBRecord (AgentDB u)
a ->
      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
program DBRecord (AgentDB u)
Agent u
a StateT u IO (DBRecord (AgentDB u))
-> (DBRecord (AgentDB u) -> StateT u IO ()) -> StateT u IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DBRecord (AgentDB u) -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
Agent u -> StateT u IO ()
store) (String -> SomeException -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
String -> SomeException -> StateT u IO ()
handleException (String -> SomeException -> StateT u IO ())
-> (DBRecord (AgentDB u) -> String)
-> DBRecord (AgentDB u)
-> SomeException
-> StateT u IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBRecord (AgentDB u) -> String
forall a. Agent a => a -> String
A.agentId (DBRecord (AgentDB u) -> SomeException -> StateT u IO ())
-> DBRecord (AgentDB u) -> SomeException -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ DBRecord (AgentDB u)
a)

-- | A program involving multiple agents.
--   The input parameter is a list of agents.
--   The program must return a list of agents that have been *modified*.
--   The order of the output list is not important.
type AgentsProgram u = [Agent u] -> StateT u IO [Agent u]

-- Run a program involving multiple agents.
withAgents
  :: (Universe u, Serialize (Agent u))
    => AgentsProgram u -> [A.AgentId] -> StateT u IO ()
withAgents :: AgentsProgram u -> [String] -> StateT u IO ()
withAgents AgentsProgram u
program [String]
names = do
  [DBRecord (AgentDB u)]
as <- [String] -> StateT u IO [Agent u]
forall u.
(Universe u, Serialize (Agent u)) =>
[String] -> StateT u IO [Agent u]
getAgents [String]
names
  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
program [DBRecord (AgentDB u)]
[Agent u]
as StateT u IO [DBRecord (AgentDB u)]
-> ([DBRecord (AgentDB u)] -> StateT u IO ()) -> StateT u IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (DBRecord (AgentDB u) -> StateT u IO ())
-> [DBRecord (AgentDB u)] -> StateT u IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DBRecord (AgentDB u) -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
Agent u -> StateT u IO ()
store)
      (String -> SomeException -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
String -> SomeException -> StateT u IO ()
handleException (String -> SomeException -> StateT u IO ())
-> ([DBRecord (AgentDB u)] -> String)
-> [DBRecord (AgentDB u)]
-> SomeException
-> StateT u IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBRecord (AgentDB u) -> String
forall a. Agent a => a -> String
A.agentId  (DBRecord (AgentDB u) -> String)
-> ([DBRecord (AgentDB u)] -> DBRecord (AgentDB u))
-> [DBRecord (AgentDB u)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DBRecord (AgentDB u)] -> DBRecord (AgentDB u)
forall a. [a] -> a
head ([DBRecord (AgentDB u)] -> SomeException -> StateT u IO ())
-> [DBRecord (AgentDB u)] -> SomeException -> StateT u IO ()
forall a b. (a -> b) -> a -> b
$ [DBRecord (AgentDB u)]
as)

handleException
  :: (Universe u, Serialize (Agent u))
    => A.AgentId -> SomeException -> StateT u IO ()
handleException :: String -> SomeException -> StateT u IO ()
handleException String
a 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
  String -> StateT u IO ()
forall u.
(Universe u, Serialize (Agent u)) =>
String -> StateT u IO ()
archive String
a

-- | Returns the current lineup of (living) agents in the universe.
--   Note: Check for @'endOfRound'@ and call @'refreshLineup'@ if needed
--   before invoking this function.
lineup :: Universe u => StateT u IO [A.AgentId]
lineup :: StateT u IO [String]
lineup = do
  ([String]
xs,[String]
ys) <- StateT (Checklist u) IO ([String], [String])
-> StateT u IO ([String], [String])
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Checklist u) m a -> StateT u m a
withChecklist StateT (Checklist u) IO ([String], [String])
forall t. Checklist t => StateT t IO ([String], [String])
CL.status
  [String] -> StateT u IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> StateT u IO [String])
-> [String] -> StateT u IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys

-- | Returns true if no agents have yet their turn at the CPU for this
--   round.
startOfRound :: Universe u => StateT u IO Bool
startOfRound :: StateT u IO Bool
startOfRound = StateT (Checklist u) IO Bool -> StateT u IO Bool
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Checklist u) m a -> StateT u m a
withChecklist StateT (Checklist u) IO Bool
forall t. Checklist t => StateT t IO Bool
CL.notStarted

-- | Returns true if the lineup is empty or if all of the agents in the
--   lineup have had their turn at the CPU for this round.
endOfRound :: Universe u => StateT u IO Bool
endOfRound :: StateT u IO Bool
endOfRound = StateT (Checklist u) IO Bool -> StateT u IO Bool
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Checklist u) m a -> StateT u m a
withChecklist StateT (Checklist u) IO Bool
forall t. Checklist t => StateT t IO Bool
CL.done

-- | Creates a fresh lineup containing all of the agents in the
--   population, in random order.
refreshLineup :: Universe u => StateT u IO ()
refreshLineup :: StateT u IO ()
refreshLineup = do
  [String]
as <- StateT u IO [String]
forall u. Universe u => StateT u IO [String]
shuffledAgentIds
  StateT (Checklist u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Checklist u) m a -> StateT u m a
withChecklist ([String] -> StateT (Checklist u) IO ()
forall t. Checklist t => [String] -> StateT t IO ()
CL.setItems [String]
as)

-- | Mark the current agent done. If it is still alive, it will move
--   to the end of the lineup.
markDone :: Universe u => A.AgentId -> StateT u IO ()
markDone :: String -> StateT u IO ()
markDone = StateT (Checklist u) IO () -> StateT u IO ()
forall u (m :: * -> *) a.
(Universe u, Monad m) =>
StateT (Checklist u) m a -> StateT u m a
withChecklist (StateT (Checklist u) IO () -> StateT u IO ())
-> (String -> StateT (Checklist u) IO ())
-> String
-> StateT u IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT (Checklist u) IO ()
forall t. Checklist t => String -> StateT t IO ()
CL.markDone

shuffledAgentIds :: Universe u => StateT u IO [String]
shuffledAgentIds :: StateT u IO [String]
shuffledAgentIds
  = StateT u IO [String]
forall u. Universe u => StateT u IO [String]
agentIds StateT u IO [String]
-> ([String] -> StateT u IO [String]) -> StateT u IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO [String] -> StateT u IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> StateT u IO [String])
-> ([String] -> IO [String]) -> [String] -> StateT u IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rand StdGen [String] -> IO [String]
forall a. Rand StdGen a -> IO a
evalRandIO (Rand StdGen [String] -> IO [String])
-> ([String] -> Rand StdGen [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Rand StdGen [String]
forall g a. RandomGen g => [a] -> Rand g [a]
shuffle

data SimpleUniverse a = SimpleUniverse
  {
    SimpleUniverse a -> PersistentCounter
suClock     :: K.PersistentCounter,
    SimpleUniverse a -> SimpleLogger
suLogger    :: SL.SimpleLogger,
    SimpleUniverse a -> FSDatabase a
suDB        :: FS.FSDatabase a,
    SimpleUniverse a -> SimpleNamer
suNamer     :: N.SimpleNamer,
    SimpleUniverse a -> PersistentChecklist
suChecklist :: CL.PersistentChecklist
  } deriving (Time -> SimpleUniverse a -> String -> String
[SimpleUniverse a] -> String -> String
SimpleUniverse a -> String
(Time -> SimpleUniverse a -> String -> String)
-> (SimpleUniverse a -> String)
-> ([SimpleUniverse a] -> String -> String)
-> Show (SimpleUniverse a)
forall a. Time -> SimpleUniverse a -> String -> String
forall a. [SimpleUniverse a] -> String -> String
forall a. SimpleUniverse a -> String
forall a.
(Time -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SimpleUniverse a] -> String -> String
$cshowList :: forall a. [SimpleUniverse a] -> String -> String
show :: SimpleUniverse a -> String
$cshow :: forall a. SimpleUniverse a -> String
showsPrec :: Time -> SimpleUniverse a -> String -> String
$cshowsPrec :: forall a. Time -> SimpleUniverse a -> String -> String
Show, SimpleUniverse a -> SimpleUniverse a -> Bool
(SimpleUniverse a -> SimpleUniverse a -> Bool)
-> (SimpleUniverse a -> SimpleUniverse a -> Bool)
-> Eq (SimpleUniverse a)
forall a. SimpleUniverse a -> SimpleUniverse a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleUniverse a -> SimpleUniverse a -> Bool
$c/= :: forall a. SimpleUniverse a -> SimpleUniverse a -> Bool
== :: SimpleUniverse a -> SimpleUniverse a -> Bool
$c== :: forall a. SimpleUniverse a -> SimpleUniverse a -> Bool
Eq)

instance (A.Agent a, D.Record a) => Universe (SimpleUniverse a) where
  type Agent (SimpleUniverse a) = a
  type Clock (SimpleUniverse a) = K.PersistentCounter
  clock :: SimpleUniverse a -> Clock (SimpleUniverse a)
clock = SimpleUniverse a -> Clock (SimpleUniverse a)
forall a. SimpleUniverse a -> PersistentCounter
suClock
  setClock :: SimpleUniverse a -> Clock (SimpleUniverse a) -> SimpleUniverse a
setClock SimpleUniverse a
u Clock (SimpleUniverse a)
c = SimpleUniverse a
u { suClock :: PersistentCounter
suClock=PersistentCounter
Clock (SimpleUniverse a)
c }
  type Logger (SimpleUniverse a) = SL.SimpleLogger
  logger :: SimpleUniverse a -> Logger (SimpleUniverse a)
logger = SimpleUniverse a -> Logger (SimpleUniverse a)
forall a. SimpleUniverse a -> SimpleLogger
suLogger
  setLogger :: SimpleUniverse a -> Logger (SimpleUniverse a) -> SimpleUniverse a
setLogger SimpleUniverse a
u Logger (SimpleUniverse a)
l = SimpleUniverse a
u { suLogger :: SimpleLogger
suLogger=SimpleLogger
Logger (SimpleUniverse a)
l }
  type AgentDB (SimpleUniverse a) = FS.FSDatabase a
  agentDB :: SimpleUniverse a -> AgentDB (SimpleUniverse a)
agentDB = SimpleUniverse a -> AgentDB (SimpleUniverse a)
forall a. SimpleUniverse a -> FSDatabase a
suDB
  setAgentDB :: SimpleUniverse a -> AgentDB (SimpleUniverse a) -> SimpleUniverse a
setAgentDB SimpleUniverse a
u AgentDB (SimpleUniverse a)
d = SimpleUniverse a
u { suDB :: FSDatabase a
suDB=FSDatabase a
AgentDB (SimpleUniverse a)
d }
  type Namer (SimpleUniverse a) = N.SimpleNamer
  agentNamer :: SimpleUniverse a -> Namer (SimpleUniverse a)
agentNamer = SimpleUniverse a -> Namer (SimpleUniverse a)
forall a. SimpleUniverse a -> SimpleNamer
suNamer
  setNamer :: SimpleUniverse a -> Namer (SimpleUniverse a) -> SimpleUniverse a
setNamer SimpleUniverse a
u Namer (SimpleUniverse a)
n = SimpleUniverse a
u { suNamer :: SimpleNamer
suNamer=SimpleNamer
Namer (SimpleUniverse a)
n }
  type Checklist (SimpleUniverse a) = CL.PersistentChecklist
  checklist :: SimpleUniverse a -> Checklist (SimpleUniverse a)
checklist = SimpleUniverse a -> Checklist (SimpleUniverse a)
forall a. SimpleUniverse a -> PersistentChecklist
suChecklist
  setChecklist :: SimpleUniverse a
-> Checklist (SimpleUniverse a) -> SimpleUniverse a
setChecklist SimpleUniverse a
u Checklist (SimpleUniverse a)
cl = SimpleUniverse a
u { suChecklist :: PersistentChecklist
suChecklist=PersistentChecklist
Checklist (SimpleUniverse a)
cl }

mkSimpleUniverse :: String -> FilePath -> SimpleUniverse a
mkSimpleUniverse :: String -> String -> SimpleUniverse a
mkSimpleUniverse String
name String
dir
  = PersistentCounter
-> SimpleLogger
-> FSDatabase a
-> SimpleNamer
-> PersistentChecklist
-> SimpleUniverse a
forall a.
PersistentCounter
-> SimpleLogger
-> FSDatabase a
-> SimpleNamer
-> PersistentChecklist
-> SimpleUniverse a
SimpleUniverse PersistentCounter
c SimpleLogger
l FSDatabase a
d SimpleNamer
n PersistentChecklist
cl
  where c :: PersistentCounter
c = String -> PersistentCounter
K.mkPersistentCounter (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/clock")
        l :: SimpleLogger
l = String -> SimpleLogger
SL.mkSimpleLogger (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/log/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".log")
        d :: FSDatabase a
d = String -> FSDatabase a
forall r. String -> FSDatabase r
FS.mkFSDatabase (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/db")
        n :: SimpleNamer
n = String -> String -> SimpleNamer
N.mkSimpleNamer (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/namer")
        cl :: PersistentChecklist
cl = String -> PersistentChecklist
CL.mkPersistentChecklist (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/todo")

data CachedUniverse a = CachedUniverse
  {
    CachedUniverse a -> PersistentCounter
cuClock     :: K.PersistentCounter,
    CachedUniverse a -> SimpleLogger
cuLogger    :: SL.SimpleLogger,
    CachedUniverse a -> CachedFSDatabase a
cuDB        :: CFS.CachedFSDatabase a,
    CachedUniverse a -> SimpleNamer
cuNamer     :: N.SimpleNamer,
    CachedUniverse a -> PersistentChecklist
cuChecklist :: CL.PersistentChecklist
  } deriving (Time -> CachedUniverse a -> String -> String
[CachedUniverse a] -> String -> String
CachedUniverse a -> String
(Time -> CachedUniverse a -> String -> String)
-> (CachedUniverse a -> String)
-> ([CachedUniverse a] -> String -> String)
-> Show (CachedUniverse a)
forall a. Show a => Time -> CachedUniverse a -> String -> String
forall a. Show a => [CachedUniverse a] -> String -> String
forall a. Show a => CachedUniverse a -> String
forall a.
(Time -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CachedUniverse a] -> String -> String
$cshowList :: forall a. Show a => [CachedUniverse a] -> String -> String
show :: CachedUniverse a -> String
$cshow :: forall a. Show a => CachedUniverse a -> String
showsPrec :: Time -> CachedUniverse a -> String -> String
$cshowsPrec :: forall a. Show a => Time -> CachedUniverse a -> String -> String
Show, CachedUniverse a -> CachedUniverse a -> Bool
(CachedUniverse a -> CachedUniverse a -> Bool)
-> (CachedUniverse a -> CachedUniverse a -> Bool)
-> Eq (CachedUniverse a)
forall a. Eq a => CachedUniverse a -> CachedUniverse a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CachedUniverse a -> CachedUniverse a -> Bool
$c/= :: forall a. Eq a => CachedUniverse a -> CachedUniverse a -> Bool
== :: CachedUniverse a -> CachedUniverse a -> Bool
$c== :: forall a. Eq a => CachedUniverse a -> CachedUniverse a -> Bool
Eq)

instance (A.Agent a, D.SizedRecord a) => Universe (CachedUniverse a) where
  type Agent (CachedUniverse a) = a
  type Clock (CachedUniverse a) = K.PersistentCounter
  clock :: CachedUniverse a -> Clock (CachedUniverse a)
clock = CachedUniverse a -> Clock (CachedUniverse a)
forall a. CachedUniverse a -> PersistentCounter
cuClock
  setClock :: CachedUniverse a -> Clock (CachedUniverse a) -> CachedUniverse a
setClock CachedUniverse a
u Clock (CachedUniverse a)
c = CachedUniverse a
u { cuClock :: PersistentCounter
cuClock=PersistentCounter
Clock (CachedUniverse a)
c }
  type Logger (CachedUniverse a) = SL.SimpleLogger
  logger :: CachedUniverse a -> Logger (CachedUniverse a)
logger = CachedUniverse a -> Logger (CachedUniverse a)
forall a. CachedUniverse a -> SimpleLogger
cuLogger
  setLogger :: CachedUniverse a -> Logger (CachedUniverse a) -> CachedUniverse a
setLogger CachedUniverse a
u Logger (CachedUniverse a)
l = CachedUniverse a
u { cuLogger :: SimpleLogger
cuLogger=SimpleLogger
Logger (CachedUniverse a)
l }
  type AgentDB (CachedUniverse a) = CFS.CachedFSDatabase a
  agentDB :: CachedUniverse a -> AgentDB (CachedUniverse a)
agentDB = CachedUniverse a -> AgentDB (CachedUniverse a)
forall a. CachedUniverse a -> CachedFSDatabase a
cuDB
  setAgentDB :: CachedUniverse a -> AgentDB (CachedUniverse a) -> CachedUniverse a
setAgentDB CachedUniverse a
u AgentDB (CachedUniverse a)
d = CachedUniverse a
u { cuDB :: CachedFSDatabase a
cuDB=CachedFSDatabase a
AgentDB (CachedUniverse a)
d }
  type Namer (CachedUniverse a) = N.SimpleNamer
  agentNamer :: CachedUniverse a -> Namer (CachedUniverse a)
agentNamer = CachedUniverse a -> Namer (CachedUniverse a)
forall a. CachedUniverse a -> SimpleNamer
cuNamer
  setNamer :: CachedUniverse a -> Namer (CachedUniverse a) -> CachedUniverse a
setNamer CachedUniverse a
u Namer (CachedUniverse a)
n = CachedUniverse a
u { cuNamer :: SimpleNamer
cuNamer=SimpleNamer
Namer (CachedUniverse a)
n }
  type Checklist (CachedUniverse a) = CL.PersistentChecklist
  checklist :: CachedUniverse a -> Checklist (CachedUniverse a)
checklist = CachedUniverse a -> Checklist (CachedUniverse a)
forall a. CachedUniverse a -> PersistentChecklist
cuChecklist
  setChecklist :: CachedUniverse a
-> Checklist (CachedUniverse a) -> CachedUniverse a
setChecklist CachedUniverse a
u Checklist (CachedUniverse a)
cl = CachedUniverse a
u { cuChecklist :: PersistentChecklist
cuChecklist=PersistentChecklist
Checklist (CachedUniverse a)
cl }

mkCachedUniverse :: String -> FilePath -> Int -> CachedUniverse a
mkCachedUniverse :: String -> String -> Time -> CachedUniverse a
mkCachedUniverse String
name String
dir Time
cacheSize
  = PersistentCounter
-> SimpleLogger
-> CachedFSDatabase a
-> SimpleNamer
-> PersistentChecklist
-> CachedUniverse a
forall a.
PersistentCounter
-> SimpleLogger
-> CachedFSDatabase a
-> SimpleNamer
-> PersistentChecklist
-> CachedUniverse a
CachedUniverse PersistentCounter
c SimpleLogger
l CachedFSDatabase a
d SimpleNamer
n PersistentChecklist
cl
  where c :: PersistentCounter
c = String -> PersistentCounter
K.mkPersistentCounter (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/clock")
        l :: SimpleLogger
l = String -> SimpleLogger
SL.mkSimpleLogger (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/log/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".log")
        d :: CachedFSDatabase a
d = String -> Time -> CachedFSDatabase a
forall r. String -> Time -> CachedFSDatabase r
CFS.mkCachedFSDatabase (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/db") Time
cacheSize
        n :: SimpleNamer
n = String -> String -> SimpleNamer
N.mkSimpleNamer (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/namer")
        cl :: PersistentChecklist
cl = String -> PersistentChecklist
CL.mkPersistentChecklist (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/todo")