module ALife.Creatur.Universe
(
Universe(..),
SimpleUniverse,
CachedUniverse,
mkSimpleUniverse,
mkCachedUniverse,
currentTime,
incTime,
writeToLog,
agentIds,
archivedAgentIds,
popSize,
getAgent,
getAgentFromArchive,
getAgents,
store,
genName,
AgentProgram,
withAgent,
AgentsProgram,
withAgents,
isNew,
lineup,
startOfRound,
endOfRound,
refreshLineup,
markDone,
replenishEnergyPool,
withdrawEnergy
) where
import Prelude hiding (lookup)
import qualified ALife.Creatur as A
import qualified ALife.Creatur.Namer as N
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.FileSystem as FS
import qualified ALife.Creatur.Database.CachedFileSystem as CFS
import qualified ALife.Creatur.Logger as L
import qualified ALife.Creatur.Logger.SimpleLogger as SL
import qualified ALife.Creatur.EnergyPool as E
import ALife.Creatur.Util (stateMap, shuffle)
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)
class (C.Clock (Clock u), L.Logger (Logger u), D.Database (AgentDB u),
N.Namer (Namer u), CL.Checklist (Checklist u),
E.EnergyPool (EnergyPool 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
type EnergyPool u
energyPool :: u -> EnergyPool u
setEnergyPool :: u -> EnergyPool u -> u
withClock :: (Universe u, Monad m) => StateT (Clock u) m a -> StateT u m a
withClock program = do
u <- get
stateMap (setClock u) clock program
withLogger
:: (Universe u, Monad m)
=> StateT (Logger u) m a -> StateT u m a
withLogger program = do
u <- get
stateMap (setLogger u) logger program
withAgentDB
:: (Universe u, Monad m)
=> StateT (AgentDB u) m a -> StateT u m a
withAgentDB program = do
u <- get
stateMap (setAgentDB u) agentDB program
withNamer
:: (Universe u, Monad m)
=> StateT (Namer u) m a -> StateT u m a
withNamer program = do
u <- get
stateMap (setNamer u) agentNamer program
withChecklist
:: (Universe u, Monad m)
=> StateT (Checklist u) m a -> StateT u m a
withChecklist program = do
u <- get
stateMap (setChecklist u) checklist program
withEnergyPool
:: (Universe u, Monad m)
=> StateT (EnergyPool u) m a -> StateT u m a
withEnergyPool program = do
u <- get
stateMap (setEnergyPool u) energyPool program
currentTime :: Universe u => StateT u IO A.Time
currentTime = withClock C.currentTime
incTime :: Universe u => StateT u IO ()
incTime = withClock C.incTime
writeToLog :: Universe u => String -> StateT u IO ()
writeToLog msg = do
t <- currentTime
let logMsg = show t ++ "\t" ++ msg
withLogger $ L.writeToLog logMsg
genName :: Universe u => StateT u IO A.AgentId
genName = withNamer N.genName
agentIds :: Universe u => StateT u IO [A.AgentId]
agentIds = withAgentDB D.keys
archivedAgentIds :: Universe u => StateT u IO [A.AgentId]
archivedAgentIds = withAgentDB D.archivedKeys
popSize :: Universe u => StateT u IO Int
popSize = withAgentDB D.numRecords
getAgent
:: (Universe u, Serialize (Agent u))
=> A.AgentId -> StateT u IO (Either String (Agent u))
getAgent name = withAgentDB (D.lookup name)
getAgentFromArchive
:: (Universe u, Serialize (Agent u))
=> A.AgentId -> StateT u IO (Either String (Agent u))
getAgentFromArchive name = withAgentDB (D.lookupInArchive name)
getAgents
:: (Universe u, Serialize (Agent u))
=> [A.AgentId] -> StateT u IO (Either String [Agent u])
getAgents names = do
selected <- mapM getAgent names
let (msgs, agents) = partitionEithers selected
if null msgs
then return $ Right agents
else return . Left $ show msgs
store
:: (Universe u, Serialize (Agent u))
=> Agent u -> StateT u IO ()
store a = do
newAgent <- isNew (A.agentId a)
withAgentDB (D.store a)
if A.isAlive a
then
if newAgent
then writeToLog $ A.agentId a ++ " added to population"
else writeToLog $ A.agentId a ++ " returned to population"
else do
withAgentDB (D.delete $ A.agentId a)
withChecklist $ CL.delete (A.agentId a)
writeToLog $ (A.agentId a) ++ " archived and removed from lineup"
isNew :: Universe u => A.AgentId -> StateT u IO Bool
isNew name = fmap (name `notElem`) agentIds
type AgentProgram u = Agent u -> StateT u IO (Agent u)
withAgent
:: (Universe u, Serialize (Agent u))
=> AgentProgram u -> A.AgentId -> StateT u IO ()
withAgent program name = do
result <- getAgent name
case result of
Left msg ->
writeToLog $ "Unable to read '" ++ name ++ "': " ++ msg
Right a ->
program a >>= store
type AgentsProgram u = [Agent u] -> StateT u IO [Agent u]
withAgents
:: (Universe u, Serialize (Agent u))
=> AgentsProgram u -> [A.AgentId] -> StateT u IO ()
withAgents program names = do
result <- getAgents names
case result of
Left msg ->
writeToLog $ "Unable to read '" ++ show names ++ "': " ++ msg
Right as ->
program as >>= mapM_ store
lineup :: Universe u => StateT u IO [A.AgentId]
lineup = do
(xs,ys) <- withChecklist CL.status
return $ xs ++ ys
startOfRound :: Universe u => StateT u IO Bool
startOfRound = withChecklist CL.notStarted
endOfRound :: Universe u => StateT u IO Bool
endOfRound = withChecklist CL.done
refreshLineup :: Universe u => StateT u IO ()
refreshLineup = do
as <- shuffledAgentIds
withChecklist (CL.setItems as)
markDone :: Universe u => A.AgentId -> StateT u IO ()
markDone = withChecklist . CL.markDone
shuffledAgentIds :: Universe u => StateT u IO [String]
shuffledAgentIds
= agentIds >>= liftIO . evalRandIO . shuffle
replenishEnergyPool :: Universe u => Double -> StateT u IO ()
replenishEnergyPool e = do
withEnergyPool (E.replenish e)
y <- withEnergyPool E.available
writeToLog $ "Replenished energy pool, " ++ show y ++ " available"
withdrawEnergy :: Universe u => Double -> StateT u IO Double
withdrawEnergy e = do
x <- withEnergyPool (E.withdraw e)
y <- withEnergyPool E.available
writeToLog $ "Withdrew " ++ show x ++ " from energy pool, "
++ show y ++ " available"
return x
data SimpleUniverse a = SimpleUniverse
{
suClock :: K.PersistentCounter,
suLogger :: SL.SimpleLogger,
suDB :: FS.FSDatabase a,
suNamer :: N.SimpleNamer,
suChecklist :: CL.PersistentChecklist,
suEnergyPool :: E.PersistentEnergyPool
} deriving (Show, Eq)
instance (A.Agent a, D.Record a) => Universe (SimpleUniverse a) where
type Agent (SimpleUniverse a) = a
type Clock (SimpleUniverse a) = K.PersistentCounter
clock = suClock
setClock u c = u { suClock=c }
type Logger (SimpleUniverse a) = SL.SimpleLogger
logger = suLogger
setLogger u l = u { suLogger=l }
type AgentDB (SimpleUniverse a) = FS.FSDatabase a
agentDB = suDB
setAgentDB u d = u { suDB=d }
type Namer (SimpleUniverse a) = N.SimpleNamer
agentNamer = suNamer
setNamer u n = u { suNamer=n }
type Checklist (SimpleUniverse a) = CL.PersistentChecklist
checklist = suChecklist
setChecklist u cl = u { suChecklist=cl }
type EnergyPool (SimpleUniverse a) = E.PersistentEnergyPool
energyPool = suEnergyPool
setEnergyPool u cl = u { suEnergyPool=cl }
mkSimpleUniverse :: String -> FilePath -> SimpleUniverse a
mkSimpleUniverse name dir
= SimpleUniverse c l d n cl e
where c = K.mkPersistentCounter (dir ++ "/clock")
l = SL.mkSimpleLogger (dir ++ "/log/" ++ name ++ ".log")
d = FS.mkFSDatabase (dir ++ "/db")
n = N.mkSimpleNamer (name ++ "_") (dir ++ "/namer")
cl = CL.mkPersistentChecklist (dir ++ "/todo")
e = E.mkPersistentEnergyPool (dir ++ "/energy")
data CachedUniverse a = CachedUniverse
{
cuClock :: K.PersistentCounter,
cuLogger :: SL.SimpleLogger,
cuDB :: CFS.CachedFSDatabase a,
cuNamer :: N.SimpleNamer,
cuChecklist :: CL.PersistentChecklist,
cuEnergyPool :: E.PersistentEnergyPool
} deriving (Show, Eq)
instance (A.Agent a, D.SizedRecord a) => Universe (CachedUniverse a) where
type Agent (CachedUniverse a) = a
type Clock (CachedUniverse a) = K.PersistentCounter
clock = cuClock
setClock u c = u { cuClock=c }
type Logger (CachedUniverse a) = SL.SimpleLogger
logger = cuLogger
setLogger u l = u { cuLogger=l }
type AgentDB (CachedUniverse a) = CFS.CachedFSDatabase a
agentDB = cuDB
setAgentDB u d = u { cuDB=d }
type Namer (CachedUniverse a) = N.SimpleNamer
agentNamer = cuNamer
setNamer u n = u { cuNamer=n }
type Checklist (CachedUniverse a) = CL.PersistentChecklist
checklist = cuChecklist
setChecklist u cl = u { cuChecklist=cl }
type EnergyPool (CachedUniverse a) = E.PersistentEnergyPool
energyPool = cuEnergyPool
setEnergyPool u cl = u { cuEnergyPool=cl }
mkCachedUniverse :: String -> FilePath -> Int -> CachedUniverse a
mkCachedUniverse name dir cacheSize
= CachedUniverse c l d n cl e
where c = K.mkPersistentCounter (dir ++ "/clock")
l = SL.mkSimpleLogger (dir ++ "/log/" ++ name ++ ".log")
d = CFS.mkCachedFSDatabase (dir ++ "/db") cacheSize
n = N.mkSimpleNamer (name ++ "_") (dir ++ "/namer")
cl = CL.mkPersistentChecklist (dir ++ "/todo")
e = E.mkPersistentEnergyPool (dir ++ "/energy")