Commit 357eec18 authored by Nicola Botta's avatar Nicola Botta
Browse files

Added old Haskell software components from ~/svn_pc98/sc.lhs to zombies.

parent d12e3c38
> module Agent where
One would like to write something like
-------------------------------------------------------------------
-- > class Agent a where --
-- > type State a --
-- > type Action a --
-- > type Reaction a --
-- > observe :: AgentEnvironment a e => a -> e > State a --
-- > select :: a -> State a -> Action a --
-- > adapt :: a -> State a -> Action a -> Reaction a -> a --
-- --
-- > class Agent a => AgentEnvironment a e where --
-- > react :: e -> Action a -> (e, Reaction a) --
-- --
-- > step :: (Agent a, AgentEnvironment a e) => (a, e) -> (a, e) --
-- --
-- > step (a,e) = (a',e') --
-- > where a' = adapt a state action reaction --
-- > (e',reaction) = react e action --
-- > action = select a state --
-- > state = observe a e --
-------------------------------------------------------------------
The problem here is the type of 'step':
-----------------------------------------------------------------------
-- > :l Agent --
-- [1 of 1] Compiling Agent ( Agent.lhs, interpreted ) --
-- --
-- Agent.lhs:20:36: --
-- Couldn't match expected type `Reaction a1' --
-- against inferred type `Reaction a' --
-- NB: `Reaction' is a type function, and may not be injective --
-- In the fourth argument of `adapt', namely `reaction' --
-- In the expression: adapt a state action reaction --
-- In the definition of `a'': a' = adapt a state action reaction --
-- --
-- Agent.lhs:21:26: --
-- Could not deduce (AgentEnvironment a e) --
-- from the context (Agent a1, AgentEnvironment a1 e) --
-- arising from a use of `react' at Agent.lhs:21:26-39 --
-- Possible fix: --
-- add (AgentEnvironment a e) to the context of --
-- the type signature for `step' --
-- In the expression: react e action --
-- In a pattern binding: (e', reaction) = react e action --
-- In the definition of `step': --
-- step (a, e) --
-- = (a', e') --
-- where --
-- a' = adapt a state action reaction --
-- (e', reaction) = react e action --
-- action = select a state --
-- state = observe a e --
-- --
-- Agent.lhs:21:34: --
-- Couldn't match expected type `Action a' --
-- against inferred type `Action a1' --
-- NB: `Action' is a type function, and may not be injective --
-- In the second argument of `react', namely `action' --
-- In the expression: react e action --
-- In a pattern binding: (e', reaction) = react e action --
-- Failed, modules loaded: none. --
-- Prelude> --
-----------------------------------------------------------------------
If one does not explicitely provide a type for 'step', the type system
deduces:
-------------------------------------
-- *Agent> :t step --
-- step --
-- :: forall a t t1. --
-- (Reaction a ~ Reaction t, --
-- Action t ~ Action a, --
-- AgentEnvironment t t1, --
-- AgentEnvironment a t1) => --
-- (t, t1) -> (t, t1) --
-- *Agent> --
-------------------------------------
One possibility is to define 'Agent' and 'AgentEnvironment' as
independent type classes and explicitely enforce the relationships
between type families in the context:
> class Agent a where
> type Environment a
> type State a
> type Action a
> type Reaction a
> observe :: a -> Environment a -> State a
> select :: a -> State a -> Action a
> adapt :: a -> State a -> Action a -> Reaction a -> a
> class AgentEnvironment e where
> type AgentAction e
> type AgentReaction e
> react :: e -> AgentAction e -> (e, AgentReaction e)
> step :: (Agent a,
> AgentEnvironment e,
> Environment a ~ e,
> Action a ~ AgentAction e,
> Reaction a ~ AgentReaction e) => (a, e) -> (a, e)
> step (a,e) = (a',e')
> where a' = adapt a state action reaction
> (e',reaction) = react e action
> action = select a state
> state = observe a e
> class Agent a => CoAgent a where
> type CoAction a
> type CoReaction a
> coselect :: a -> State a -> CoAction a -> CoReaction a
> costep :: (CoAgent a,
> CoAgent b,
> Environment a ~ b,
> Environment b ~ a,
> Action a ~ CoAction b,
> Action b ~ CoAction a,
> Reaction a ~ CoReaction b,
> Reaction b ~ CoReaction a) => (a,b) -> (a,b)
> costep (a,b) = (a',b')
> where a' = adapt a sa aa crb
> b' = adapt b sb ab cra
> sa = observe a b
> sb = observe b a
> aa = select a sa
> ab = select b sb
> crb = coselect b sb aa
> cra = coselect a sa ab
> module AdaptationBasedProgramming.RLAgent where
> class RLAgent a where
> type Action a
> type Reaction a
> policy :: a -> Action a
> update :: a -> Reaction a -> a
'update' should possibly be a function but 'policy' shouldn' t. Policies
usually require actions (controls) to be drawn randomly (exploration).
> step :: RLAgent a => (Action a -> Reaction a) -> a -> [a]
> step f a = a:(step f a')
> where a' = update a reaction
> reaction = f action
> action = policy a
Example: the multi-armed bandit player
> type Arm = Int
> type Counter = Int
> type Reward = Float
> type MAB_Player = [(Arm,Counter,Reward)]
> instance RLAgent MAB_Player where
> type Action MAB_Player = Arm
> type Reaction MAB_Player = Reward
> policy player = 1
> update player _ = player
-- > mk_MAB_Player :: Int -> MAB_Player
-- > mk_MAB_Player n = [(i,0,0.0) | i <- [1..n]]
-- > ps :: [MAB_Player]
-- > ps = take 3 (step (\ a -> 1.0) (mk_MAB_Player 3))
> module ThreeArmedBandit where
> import Agent
> import List (sortBy)
Arms, counters and rewards
> data Arm = A | B | C deriving (Eq, Show)
> type Counter = Int
> type Reward = Float
The player type
> type Player = Arm -> (Counter,Reward)
The three-armed bandit type
> type Bandit = Arm -> Reward
'Player' is an 'Agent'
> instance Agent Player where
> type Environment Player = Bandit
> type State Player = Player
> type Action Player = Arm
> type Reaction Player = Reward
> observe p _ = p
> select p _ = a
> where ((a,_,_):_) = zeroPulls ++ sortDesc ucb m
> zeroPulls = filter ((==0) . pulls) m
> n = fromIntegral (sum (map pulls m))
> ucb (_,c,r) = r/ni + sqrt (log n/ni)
> where ni = fromIntegral c
> pulls (_,c,_) = c
> m = [(a,fst (p a), snd (p a)) | a <- [A,B,C]]
> adapt p _ a' r = \ a -> if (a == a')
> then (fst (p a) + 1, snd (p a) + r)
> else p a
'Bandit' is an AgentEnvironment
> instance AgentEnvironment Bandit where
> type AgentAction Bandit = Arm
> type AgentReaction Bandit = Reward
> react b a = (b,b a)
Helper functions
> sortDesc :: Ord b => (a -> b) -> [a] -> [a]
> sortDesc f = sortBy (\x y->compare (f y) (f x))
> pulls :: Player -> Arm -> Int
> pulls p a = fst (p a)
> rewards :: Player -> Arm -> Reward
> rewards p a = snd (p a)
> total_pulls :: Player -> Int
> total_pulls p = pulls p A + pulls p B + pulls p C
> total_rewards :: Player -> Reward
> total_rewards p = rewards p A + rewards p B + rewards p C
> pull_freq :: Player -> Arm -> Float
> pull_freq p a = (fromIntegral (pulls p a)) / (fromIntegral (total_pulls p))
> pull_freqs :: Player -> [Float]
> pull_freqs p = [pull_freq p a | a <- [A,B,C]]
Example:
Initial player and bandit
> p :: Player
> p = \ a -> (0, 0.0)
> b :: Bandit
> b = \ a -> case a of
> A -> 0.1
> B -> 0.2
> C -> 0.3
> m, n :: Int
> m = 10
> n = 10000
> lala = map (pull_freqs . fst) (drop (n - m) (take n (iterate step (p,b))))
> module Agent.Agent(Agent(Agent),
> showAgent,
> showlAgent,
> iteratelAgent,
> printTrj
> ) where
> import List
> import Maybe
> import NumericTypes.Nat
The Agent ADT
-- > data Agent m = forall s . Agent (s -> Nat)
-- > (s -> [(m, Nat)])
-- > (s -> [(m, Nat)] -> s)
-- > (s -> IO ())
-- > s
> data Agent m = forall s . Agent (s -> Nat) -- (Nat)
> (s -> [(m, Nat)])
> (s -> [(m, Nat)] -> s)
> (s -> String -> String)
> s
Auxiliary functions (core)
> ident :: Agent m -> Nat -- :: Nat
> ident (Agent i o t p s) = i s -- i
> outs :: Agent m -> [(m, Nat)] -- ParFinMap AgentId (Bag m)
> outs (Agent i o t p s) = o s
> step :: Agent m -> [(m, Nat)] -> Agent m -- Nat AgentId
> step (Agent i o t p s) ins = (Agent i o t p s')
> where s' = t s ins
> showAgent :: String -> Agent m -> String -- Cmd -> Agent m -> Obs
> showAgent tag (Agent i o t p s) = p s tag -- showAgent cmd
Auxiliary functions (helpers)
> showlAgent :: String -> [Agent m] -> [String]
> showlAgent tag = map (showAgent tag)
Exchange messages. For the moment we do not use the D module and the
|exch| primitive. Instead, we implement an ad-hoc finction
|exchMsgs|. We will introduce distributed data when it becomes clear
what it makes most sense to distribute (single agents, groups of agents,
etc.) in a SPMD model.
> inMsgs :: [Agent m] -> (Nat -> [(m, Nat)])
> inMsgs ags = \i -> outs (fromJust (find ((i ==) . ident) ags))
> outMsgs :: [Agent m] -> (Nat -> [(m, Nat)])
> outMsgs ags = \i -> [(rr, i') | i' <- map ident ags,
> (rr, i'') <- (inMsgs ags) i',
> i'' == i]
|inMsgs| and |outMsgs| have to fulfill the following specification:
(rr, j) elem (outMsgs ags i) <=> (rr, i) elem (inMsgs ags j)
> exchMsgs :: [Agent m] -> [[(m, Nat)]]
> exchMsgs ags = [outMsgs ags i | i <- map ident ags]
Iterate a list of agents
> iteratelAgent :: [Agent m] -> Nat -> [Agent m]
> iteratelAgent ags 0 = ags
> iteratelAgent ags (n + 1) = iteratelAgent ags' n
> where ags' = [step ag msgs | (ag, msgs) <- zip ags msgss]
> msgss = exchMsgs ags
Print trajectory
> printTrj :: ([Agent m] -> Bool) ->
> ([Agent m] -> String) ->
> [Agent m] ->
> Nat ->
> IO [Agent m]
> printTrj pred showl ags 0 =
> do print ("iter: " ++ (show 0) ++ "; " ++ showl ags)
> return ags
> printTrj pred showl ags (n + 1) =
> do ags' <- printTrj pred showl ags n
> ags'' <- return (iteratelAgent ags' 1)
> f ags''
> where -- f :: [Agent m] -> IO [Agent m]
> f agents = if (pred agents)
> then do print ("iter: " ++ (show (n + 1)) ++ "; " ++ showl agents)
> return agents
> else return agents
> import Prob.SimpleProb
> import Prob.SimpleProbOps
> import Util.Random.Ops
> import Util.Unsafe.Random.Ops
> import NumericTypes.Nat
> import Agent.Agent
Common producer / consumer
> type Stock = Double
> type Msg = (Double, Nat)
Producer State
> type ExpectedDemand = Double
> type ExpectedProductionFluctuation = Double
> type ProducerState = (Nat,
> [Nat],
> Stock,
> Nat,
> ExpectedDemand,
> ExpectedProductionFluctuation,
> SimpleProb Double)
Producer constructor
> makeProducer :: Nat ->
> [Nat] ->
> Stock ->
> SimpleProb Double ->
> Agent Double
> makeProducer i is stock productionFluctuationSP
> = Agent identProducer
> outMsgsProducer
> stepProducer
> printProducer
> (i,
> is,
> stock,
> expectedNumberOfConsumers,
> expectedDemand,
> expectedProductionFluctuation,
> productionFluctuationSP)
> where expectedNumberOfConsumers = max 1 (div (length is) 2)
> expectedDemand = stock
> expectedProductionFluctuation = unsafeRandomize productionFluctuationSP
Producer auxiliary functions (core)
> identProducer :: ProducerState -> Nat
> identProducer (i,
> is,
> stock,
> expectedNumberOfConsumers,
> expectedDemand,
> expectedProductionFluctuation,
> productionFluctuationSP) = i
> outMsgsProducer :: ProducerState -> [Msg]
> outMsgsProducer (i,
> is,
> stock,
> expectedNumberOfConsumers,
> expectedDemand,
> expectedProductionFluctuation,
> productionFluctuationSP)
> = [(deliver, i) | i <- is]
> where deliver = - (min stock expectedDemand) / (realToFrac n)
> n = expectedNumberOfConsumers
> stepProducer :: ProducerState -> [Msg] -> ProducerState
> stepProducer (i,
> is,
> stock,
> expectedNumberOfConsumers,
> expectedDemand,
> expectedProductionFluctuation,
> productionFluctuationSP) ins
> = (i,
> is,
> stock',
> expectedNumberOfConsumers',
> expectedDemand',
> expectedProductionFluctuation',
> productionFluctuationSP)
> where stock'
> = stock + production + productionFluctuation - deliver
> production
> = max 0 (expectedDemand - (stock + expectedProductionFluctuation - deliver))
> deliver = min stock expectedDemand
> expectedNumberOfConsumers' = max 1 (div (expectedNumberOfConsumers + numberOfConsumers) 2)
> expectedDemand' = 0.5 * (expectedDemand + demand)
> expectedProductionFluctuation'
> = 0.5 * (expectedProductionFluctuation + productionFluctuation)
> numberOfConsumers = length (filter ((> 0.0) . fst) ins)
> demand = sum (map ((max 0.0) . fst) ins)
> productionFluctuation = unsafeRandomize productionFluctuationSP
> printProducer :: ProducerState -> IO ()
> printProducer (i,
> is,
> stock,
> expectedNumberOfConsumers,
> expectedDemand,
> expectedProductionFluctuation,
> productionFluctuationSP)
> = do print ("id: " ++ (show i))
> print ("is: " ++ (show is))
> print ("stock: " ++ (show stock))
> print ("expectedNumberOfConsumers: " ++ (show expectedNumberOfConsumers))
> print ("expectedDemand: " ++ (show expectedDemand))
> print ("expectedProductionFluctuation: " ++ (show expectedProductionFluctuation))
Consumer State
> type ExpectedDeliver = Double
> type ExpectedConsume = Double
> type ConsumerState = (Nat,
> [Nat],
> Stock,
> Nat,
> ExpectedDeliver,
> ExpectedConsume,
> SimpleProb Double)
Consumer constructor
> makeConsumer :: Nat ->
> [Nat] ->
> Stock ->
> SimpleProb Double ->
> Agent Double
> makeConsumer i is stock consumeSP
> = Agent identConsumer
> outMsgsConsumer
> stepConsumer
> printConsumer
> (i,
> is,
> stock,
> expectedNumberOfProducers,
> expectedDeliver,
> expectedConsume,
> consumeSP)
> where expectedNumberOfProducers = max 1 (div (length is) 2)
> expectedDeliver = expectedConsume
> expectedConsume = unsafeRandomize consumeSP
Consumer auxiliary functions (core)
> identConsumer :: ConsumerState -> Nat
> identConsumer (i,
> is,
> stock,
> expectedNumberOfProducers,
> expectedDeliver,
> expectedConsume,
> consumeSP) = i
> outMsgsConsumer :: ConsumerState -> [Msg]
> outMsgsConsumer (i,
> is,
> stock,
> expectedNumberOfProducers,
> expectedDeliver,
> expectedConsume,
> consumeSP)
> = [(demand, i) | i <- is]
> where demand = (max 0.0 (stockTarget - expectedStock)) / (realToFrac n)
> expectedStock = stock + expectedDeliver - expectedConsume
> stockTarget = 10.0
> n = expectedNumberOfProducers
> stepConsumer :: ConsumerState -> [Msg] -> ConsumerState
> stepConsumer (i,
> is,
> stock,
> expectedNumberOfProducers,
> expectedDeliver,
> expectedConsume,
> consumeSP) ins
> = (i,
> is,
> stock',
> expectedNumberOfProducers',
> expectedDeliver',
> expectedConsume',
> consumeSP)
> where stock' = stock + deliver - consume
> expectedNumberOfProducers' = max 1 (div (expectedNumberOfProducers + numberOfProducers) 2)
> expectedDeliver' = 0.5 * (expectedDeliver + deliver)
> expectedConsume' = 0.5 * (expectedConsume + consume)
> numberOfProducers = length (filter ((< 0.0) . fst) ins)
> deliver = - sum (map ((min 0.0) . fst) ins)
> consume = min (unsafeRandomize consumeSP) (stock + deliver)
> printConsumer :: ConsumerState -> IO ()
> printConsumer (i,
> is,
> stock,
> expectedNumberOfProducers,
> expectedDeliver,
> expectedConsume,
> consumeSP)
> = do print ("id: " ++ (show i))