module PRODEMO
where
import Data.List
type Prob = Rational
certain :: Prob
certain = 1/1
type Dist = [Prob]
normalize :: Dist -> Dist
normalize ps = [ p / s | p <- ps ] where s = sum ps
norm :: [(a,Prob)] -> [(a,Prob)]
norm xs = let
ps = map snd xs
s = sum ps
in [ (x, p / s ) | (x,p) <- xs ]
indif :: [a] -> [(a,Prob)]
indif xs = map (\ x -> (x,p)) xs
where p = 1 / fromIntegral (length xs)
type Erel a = [[a]]
bl :: Eq a => Erel a -> a -> [a]
bl r x = head (filter (elem x) r)
restrict :: Eq a => [a] -> Erel a -> Erel a
restrict domain = nub . filter (/= [])
. map (filter (flip elem domain))
type Lottery a = [(a,Prob)]
table2fct :: Eq a => [(a,b)] -> a -> b
table2fct t = \ x -> maybe undefined id (lookup x t)
enum :: Eq a => [a] -> a -> Int
enum xs = table2fct (zip xs [0..])
restrictL :: Eq a => [a] -> Lottery a -> Lottery a
restrictL domain lot = let
lot0 = filter (\ (w,_) -> elem w domain) lot
in
norm lot0
eventProb :: Eq a => [a] -> Lottery a -> Prob
eventProb xs ys = let
zs = norm ys
ps = map (table2fct zs) xs
in
sum ps
data Agent = Ag Int deriving (Eq,Ord)
a,b,c,d,e :: Agent
a = Ag 0; b = Ag 1; c = Ag 2; d = Ag 3; e = Ag 4
instance Show Agent where
show (Ag 0) = "a"; show (Ag 1) = "b";
show (Ag 2) = "c"; show (Ag 3) = "d" ;
show (Ag 4) = "e";
show (Ag n) = 'a': show n
data Prp = P Int | Q Int | R Int | S Int deriving (Eq,Ord)
instance Show Prp where
show (P 0) = "p"; show (P i) = "p" ++ show i
show (Q 0) = "q"; show (Q i) = "q" ++ show i
show (R 0) = "r"; show (R i) = "r" ++ show i
show (S 0) = "s"; show (S i) = "s" ++ show i
type World = Int
data EM a = Mo
[Agent]
[World]
[(World,[a])]
[(Agent,Erel World)]
[World] deriving (Eq,Show)
data Pem a = MO
[Agent]
[World]
[(World,[a])]
[(Agent,Erel World)]
[World]
[(Agent,Lottery World)]
deriving (Eq,Show)
rel :: Agent -> Pem a -> Erel World
rel ag (MO _ _ _ rels _ _) = table2fct rels ag
lot :: Agent -> Pem a -> Lottery World
lot ag (MO _ _ _ _ _ lots) = table2fct lots ag
actual :: Pem a -> [World]
actual (MO _ _ _ _ as _ ) = as
lookupLot :: Eq a => Lottery a -> [a] -> a -> Prob
lookupLot lot xs x = let
v = table2fct lot x
vs = map (table2fct lot) xs
in
v / (sum vs)
liftEM :: EM a -> Pem a
liftEM (Mo agents worlds val rels actuals) =
MO agents worlds val rels actuals lots
where
lots = [ (a,indif worlds) | a <- agents ]
ex0 :: EM Prp
ex0 = Mo
[a,b,c]
[0,1]
[(0,[P 0]),(1,[])]
[(a,[[0],[1]]),
(b,[[0,1]]),
(c,[[0,1]])]
[0,1]
example0 = liftEM ex0
ex1 :: EM Prp
ex1 = Mo
[a,b,c]
[0..3]
[(0,[P 0,Q 0]),(1,[P 0]),(2,[Q 0]),(3,[])]
[(a,[[0,1],[2,3]]),
(b,[[0,2],[1,3]]),
(c,[[0..3]])]
[0..3]
example1 = liftEM ex1
example2 :: Pem Prp
example2 = MO
[a,b,c]
[0,1,2,3]
[(0,[P 0]), (1,[]),(2,[P 0]), (3,[])]
[(a,[[0,2],[1,3]]),
(b,[[0,1,2,3]]),
(c,[[0,1],[2,3]])]
[0,1,2,3]
[(a,[(0,1/2),(1,1/2),(2,1/3),(3,2/3)]),
(b,[(0,1/2),(1,1/2),(2,1/3),(3,2/3)]),
(c,[(0,1/2),(1,1/2),(2,1/3),(3,2/3)])]
initM :: Ord a => [Agent] -> [a] -> EM a
initM ags props = (Mo ags worlds val accs points)
where
worlds = [0..(2^k-1)]
k = length props
val = zip worlds (sortL (powerList props))
accs = [ (ag,[worlds]) | ag <- ags ]
points = worlds
powerList :: [a] -> [[a]]
powerList [] = [[]]
powerList (x:xs) =
(powerList xs) ++ (map (x:) (powerList xs))
sortL :: Ord a => [[a]] -> [[a]]
sortL = sortBy
(\ xs ys -> if length xs > length ys
then LT
else if length xs < length ys
then GT
else compare xs ys)
initPM :: Ord a => [Agent] -> [a] -> Pem a
initPM as ps = liftEM (initM as ps)
distMarbles :: Int -> [(Int,Int)]
distMarbles k = [ (m,n)
| m <- [0..k], n <- [0..k], m+n == k ]
initU :: [Agent] -> Int -> EM (Int,Int)
initU ags k = (Mo ags worlds val accs points)
where
worlds = [0..k]
urns = map (\ xs -> [xs]) (distMarbles k)
val = zip worlds urns
accs = [ (ag,[worlds]) | ag <- ags ]
points = worlds
initU0 :: [Agent] -> Int -> Pem (Int,Int)
initU0 as k = liftEM (initU as k)
initURN :: [Agent] -> Int -> Pem (Int,Int)
initURN ags k =
(MO ags worlds val accs points lots)
where
worlds = [0..k]
urns = map (\ xs -> [xs]) (distMarbles k)
val = zip worlds urns
accs = [ (ag,[worlds]) | ag <- ags ]
points = worlds
lot = zip [0..]
(map (\ [(m,n)] -> fromIntegral $ binom (m+n) m) urns)
lots = [ (a,lot) | a <- ags ]
binom n 0 = 1
binom n k | n < k = 0
| otherwise =
(n * binom (n-1) (k-1)) `div` k
data Marble = W | B deriving (Eq,Show)
distMarbles2 :: Int -> [[Marble]]
distMarbles2 0 = [[]]
distMarbles2 k = map (W:) (distMarbles2 (k-1))
++ map (B:) (distMarbles2 (k-1))
initU2 :: [Agent] -> Int -> EM Marble
initU2 ags k = (Mo ags worlds val accs points)
where
worlds = [0..2^k-1]
urns = distMarbles2 k
val = zip worlds urns
accs = [ (ag,[worlds]) | ag <- ags ]
points = worlds
initURN2 :: [Agent] -> Int -> Pem Marble
initURN2 as k = liftEM (initU2 as k)
data Inf a = Inf ([a] -> Bool)
instance Show (Inf a) where
show (Inf f) = "..."
instance Eq (Inf a) where
(Inf f) == (Inf g) = True
data Form a = Top
| Info (Inf a)
| Prp a
| Ng (Form a)
| Conj [Form a]
| Disj [Form a]
| Kn Agent (Form a)
| Geq (Term a) (Term a)
| Eq (Term a) (Term a)
| Pr Agent (Form a) Rational
deriving (Eq,Show)
data Term a = Rat Rational
| Prb Agent (Form a)
| Cprb Agent (Form a) (Form a)
| Cmpl (Term a)
| Prod [Term a]
deriving (Eq,Show)
p,q,r, p_or_q :: Form Prp
p = Prp (P 0); q = Prp (Q 0); r = Prp (R 0)
p_or_q = Disj [p,q]
hasWhite, hasBlack :: Form (Int,Int)
hasWhite = Info (Inf (\ [(m,n)] -> m > 0))
hasBlack = Info (Inf (\ [(m,n)] -> n > 0))
impl :: Form a -> Form a -> Form a
impl form1 form2 = Disj [Ng form1, form2]
isTrueAt :: Eq a => Pem a -> World ->
Form a -> Bool
isTrueAt m w Top = True
isTrueAt
m@(MO agents worlds val acc points lots)
w (Info (Inf f)) = let
value = table2fct val w
in
f value
isTrueAt
m@(MO agents worlds val acc points lots)
w (Prp p) = let
props = table2fct val w
in
elem p props
isTrueAt m w (Ng f) = not (isTrueAt m w f)
isTrueAt m w (Conj fs) = and (map (isTrueAt m w) fs)
isTrueAt m w (Disj fs) = or (map (isTrueAt m w) fs)
isTrueAt
m@(MO agents worlds val acc points lots)
w (Kn ag f) = let
r = rel ag m
wb = bl r w
in
and (map (\ x -> isTrueAt m x f) wb)
isTrueAt m w (Geq t1 t2) =
(eval m w t1) >= (eval m w t2)
isTrueAt m w (Eq t1 t2) =
(eval m w t1) == (eval m w t2)
isTrueAt
m@(MO agents worlds val acc points lots) w
(Pr ag f q) = prob m ag w f == q
eval :: Eq a => Pem a -> World ->
Term a -> Prob
eval _ _ (Rat q) = q
eval m w (Prb a form) = prob m a w form
eval m w (Cprb a f1 f2) = let
p1 = eval m w (Prb a (Conj [f1,f2]))
p2 = eval m w (Prb a f2)
in
if p2 == 0 then 0 else p1 / p2
eval m w (Cmpl t) = 1 - (eval m w t)
eval m w (Prod ts) = product (map (eval m w) ts)
prob :: Eq a =>
Pem a ->
Agent -> World -> Form a -> Prob
prob m@(MO agents worlds val acc points lots)
ag w f = let
r = rel ag m
wb = bl r w
g = table2fct (lot ag m)
ps = [ (x, g x) | x <- wb ]
qs = filter (\ (x,_) -> isTrueAt m x f) ps
in
sum (map snd qs) / sum (map snd ps)
gnedenko :: Pem Prp
gnedenko = MO
[a] [0..9]
[(0,[P 0,Q 1]),(1,[Q 1]),
(2,[P 0,Q 2]),(3,[Q 2]),
(4,[P 0,Q 3]),(5,[Q 3]),
(6,[P 0,Q 4]),(7,[Q 4]),
(8,[P 0,Q 5]),(9,[Q 5])]
[(a,[[0..9]])] [0..9]
[(a,[(0,3/5),(1,2/5),(2,3/5),(3,2/5),
(4,4/5),(5,1/5),(6,4/5),(7,1/5),
(8,1/5),(9,4/5)])]
gnedenkoT :: Term Prp
gnedenkoT = Cprb a (Prp (Q 5)) (Ng p)
upd_pa :: Eq a => Pem a -> Form a -> Pem a
upd_pa
m@(MO agents states val rels actual lots) f =
(MO agents states1 val1 rels1 actual1 lots1)
where
states1 = [ s | s <- states, isTrueAt m s f ]
val1 = [ (s,ps) | (s,ps) <- val, elem s states1 ]
rels1 = [(ag,restrict states1 r) | (ag,r) <- rels ]
actual1 = filter (flip elem states1) actual
g = norm . filter (\ (w,p) -> elem w states1)
lots1 = [(a, g lot) | (a,lot) <- lots ]
example1a = upd_pa example1 p_or_q
rename :: Pem a -> Pem a
rename (MO agents states val rels actual lots) =
MO agents states1 val1 rels1 actual1 lots1
where
f = enum states
states1 = map f states
val1 = map (\ (x,y) -> (f x,y)) val
rels1 = map (\ (x,r) -> (x, map (map f) r)) rels
actual1 = map f actual
lots1 = map
(\ (x,lot) -> (x, map (\ (x,p) -> (f x,p)) lot)) lots
upds_pa :: Eq a =>
Pem a -> [Form a] -> Pem a
upds_pa = foldl upd_pa
type Subst a = [(a,Form a)]
sub :: Eq a => Subst a -> a -> Form a
sub subst x =
if elem x (map fst subst) then
table2fct subst x else (Prp x)
upd_pc :: Eq a => [a] -> Pem a
-> Subst a -> Pem a
upd_pc
ps
m@(MO agents states val rels actual lots)
sb =
(MO agents states val1 rels actual lots)
where
val1 = [ (s, [p | p <- ps,
isTrueAt m s (sub sb p)])
| s <- states ]
upds_pc :: Eq a => [a] -> Pem a
-> [Subst a] -> Pem a
upds_pc ps = foldl (upd_pc ps)
exampleprops = [P i | i <- [0..3 ]]
++
[Q i | i <- [0..3 ]]
sexample = [(P i, Prp (P 0)) | i <- [0..3 ]]
++
[(Q i, Prp (Q 0)) | i <- [0..3 ]]
exmple :: Pem Prp
exmple = initPM [a,b,c] [P 0,Q 0]
type Event = Int
data UM a = UM
[Agent]
[Event]
[(Event,(Form a, Subst a))]
[(Agent,Erel Event)]
[Event]
[(Agent, Lottery Event)]
deriving (Eq,Show)
ssp :: Agent -> UM a -> Erel Event
ssp ag (UM _ _ _ susps _ _) = table2fct susps ag
elot :: Agent -> UM a -> Lottery Event
elot ag (UM _ _ _ _ _ lots) = table2fct lots ag
type FUM a = [Agent] -> UM a
fum1 :: FUM Prp
fum1 = \ ags -> UM
ags
[0,1]
[(0,(p_or_q,[])),(1,(Top,[]))]
((a,[[0],[1]]) : [ (x,[[0,1]]) | x <- ags \\ [a] ])
[0]
[(x, [(0,1/2),(1,1/2)]) | x <- ags ]
fum2 :: FUM Prp
fum2 = \ ags -> UM
ags
[0,1,2,3]
[(0,(Top,[(P 0,Top)])),(1,(Top,[(P 0,Ng Top)])),
(2,(Top,[(P 0,Top)])),(3,(Top,[(P 0,Ng Top)]))]
((a,[[0,1],[2,3]]) : [ (x,[[0,1,2,3]]) | x <- ags\\[a]])
[0,1]
[(x, [(0,1/4),(1,1/4),(2,1/3),(3,1/6)]) | x <- ags ]
precond :: Eq a => [(Event,(Form a, Subst a))]
-> Event -> Form a
precond table = fst . table2fct table
action :: Eq a => [(Event,(Form a, Subst a))]
-> Event -> Subst a
action table = snd . table2fct table
cP :: [a] -> [b] -> [(a,b)]
cP xs ys = [(x,y) | x <- xs, y <- ys ]
prod :: (Eq a,Eq b) => Erel a -> Erel b -> Erel (a,b)
prod r s =
[ [ (x,y) | x <- b, y <- c ] | b <- r, c <- s ]
prodD :: (Eq a,Eq b) =>
[(a,b)] -> Erel a -> Erel b -> Erel (a,b)
prodD domain r s =
[ [ (x,y) | x <- b, y <- c, elem (x,y) domain ] |
b <- r, c <- s ]
upd :: Eq a => [a] ->
Pem a -> FUM a -> Pem a
upd ps
m@(MO agents states val rels actual lots)
fum =
MO agents1 states1 val1 rels1 actual1 lots1
where
um@(UM agents1 events pat susp aevents elots)
= fum agents
states0 =
[ (s,e) | s <- states, e <- events,
isTrueAt m s (precond pat e) ]
f = enum states0
states1 = map f states0
val1 = [ (f (s,e),[ p | p <- ps,
isTrueAt m s
(sub (action pat e) p)]) |
s <- states,
e <- events,
elem (s,e) states0 ]
rels1 = [ (a,map (map f)
(prodD states0 (rel a m) (ssp a um))) |
a <- agents1 ]
actual1 = map f [ (s,e) | (s,e) <- states0,
elem s actual,
elem e aevents ]
lots1 = [ (x, newLot states0 lot elot) |
(x, lot) <- lots,
(y,elot) <- elots, x == y ]
newLot :: [(World,Event)] -> Lottery World
-> Lottery Event -> Lottery World
newLot domain lot1 lot2 = let
ws = map fst lot1
es = map fst lot2
f = enum domain
g = \ (w,e) ->
(table2fct lot1 w) * (table2fct lot2 e)
in
norm $ map (\ (w,e) -> (f (w,e), g (w,e))) domain
m0 :: Pem Prp
m0 = initPM [a,b] []
m1 :: Pem Prp
m1 = initPM [a,b] [P 0]
um1 :: FUM Prp
um1 = \ ags -> UM
ags
[0,1]
[(0,(p,[])),(1,(Ng p,[]))]
((a,[[0],[1]]) : [ (x,[[0,1]]) | x <- ags \\ [a] ])
[0,1]
[(x,[(0,1/2),(1,1/2)]) | x <- ags ]
m2 :: Pem Prp
m2 = upd [P 0] m1 um1
m3 :: Pem Prp
m3 = upd_pc [P 0,Q 0] m2 [(Q 0,Top)]
um2 :: FUM Prp
um2 = \ ags -> UM
ags
[0,1]
[(0,(p,[(P 0,Ng Top)])),(1,(q,[(Q 0,Ng Top)]))]
[ (x,[[0,1]]) | x <- ags ]
[0,1]
[(x, [(0,1/2),(1,1/2)]) | x <- ags ]
m4 :: Pem Prp
m4 = upd [P 0,Q 0] m3 um2
disease0 :: Pem Prp
disease0 = MO
[a]
[0,1]
[(0,[P 0]),(1,[])]
[(a,[[0,1]])]
[0,1]
[(a, [(0,(1/100000)),(1,(99999/100000))])]
gland :: FUM Prp
gland = \ ags -> UM
ags
[0,1,2]
[(0,(p,[(Q 0,Top)])),(1,(p,[(Q 0,Ng Top)])),
(2,(Ng p,[(Q 0,Ng Top)]))]
[ (x,[[0,1,2]]) | x <- ags ]
[0,1,2]
[ (x, [(0,97/100),(1,3/100),(2,1)]) | x <- ags ]
disease1 = upd [P 0, Q 0] disease0 gland
observation :: FUM Prp
observation = \ ags -> UM
ags
[0,1]
[(0,(q,[])),(1,(Ng q,[]))]
[ (x,[[0,1]]) | x <- ags ]
[0,1]
[ (x,[(0,1/2),(1,1/2)]) | x <- ags ]
disease2 = upd [P 0, Q 0] disease1 observation
expert :: FUM Prp
expert = \ ags -> UM
ags
[0,1]
[(0,(q,[])),(1,(Ng q,[]))]
[ (x,[[0,1]]) | x <- ags ]
[0,1]
[ (x, [(0,99/100),(1,1/100)]) | x <- ags ]
disease3 = upd [P 0, Q 0] disease1 expert
p1,p2,p3,q1,q2,q3 :: Form Prp
p1 = Prp (P 1); p2 = Prp (P 2); p3 = Prp (P 3)
q1 = Prp (Q 1); q2 = Prp (Q 2); q3 = Prp (Q 3)
montyFum :: FUM Prp
montyFum = \ags -> UM
ags
[0..11]
[(0,(Conj [p1,q1,Ng p2],[])),
(1,(Conj [p1,q3,Ng p2],[])),
(2,(Conj [p3,q1,Ng p2],[])),
(3,(Conj [p3,q3,Ng p2],[])),
(4,(Conj [p1,q1,Ng p3],[])),
(5,(Conj [p1,q2,Ng p3],[])),
(6,(Conj [p2,q1,Ng p3],[])),
(7,(Conj [p2,q2,Ng p3],[])),
(8,(Conj [p2,q2,Ng p1],[])),
(9,(Conj [p2,q3,Ng p1],[])),
(10,(Conj [p3,q2,Ng p1],[])),
(11,(Conj [p3,q3,Ng p1],[]))]
[ (a,[[0..3],[4..7],[8..11]]) | a <- ags ]
[0..11]
[ (x, [(0,(1/2)),(1,1),(2,1),(3,(1/2)),(4,(1/2)),(5,1),
(6,1),(7,(1/2)),(8,(1/2)),(9,1),(10,1),(11,(1/2))])
| x <- ags ]
montyInit :: Pem Prp
montyInit =
MO
[a]
[0..2]
[(0,[P 1]),(1,[P 2]),(2,[P 3])]
[(a,[[0..2]])]
[0..2]
[(a , indif [0..2])]
aChoice :: FUM Prp
aChoice = \ags -> UM
ags
[0..2]
[(0,(Top,[(Q 1,Top)])),
(1,(Top,[(Q 2,Top)])),
(2,(Top,[(Q 3,Top)]))]
[(x,[[0],[1],[2]]) | x <- ags ]
[0..2]
[(x, indif [0..2]) | x <- ags ]
monty1 =
upd [P 1, P 2, P 3, Q 1, Q 2, Q 3] montyInit aChoice
monty2 =
upd [P 1, P 2, P 3, Q 1, Q 2, Q 3] monty1 montyFum
correct :: Form Prp
correct = Disj [Conj [p1,q1],Conj [p2,q2], Conj [p3,q3]]
mapPEM :: ([a] -> [b]) -> Pem a -> Pem b
mapPEM
f
m@(MO agents states val rels actual lots) =
MO agents states val1 rels actual lots
where
val1 = map (\ (x,ps) -> (x, f ps)) val
gmapPEM :: (Eq a,Eq b)
=> ([a] -> Lottery [b]) -> Pem a -> Pem b
gmapPEM
lotf
m@(MO agents states val rels actual lots) =
MO agents states1 val1 rels1 actual1 lots1
where
table0 =
[ ((s,i),(x,p)) | s <- states,
value <- [table2fct val s],
((x,p),i) <- zip (lotf value) [0..] ]
k = \w -> [ (w,i) |
((v,i),(x,p)) <- table0, v == w ]
l = concat . map k
states0 = l states
f = enum states0
states1 = map f states0
actual1 = map f $ l actual
h = map (map f) . (map l)
rels1 = [(ag, h r) | (ag,r) <- rels ]
val1 = zip [0..] (map (\ ((s,i),(x,p)) -> x) table0)
lots1 = [ (ag, norm [ (f (s,j), p * q) |
((s,j),(x,p)) <- table0,
q <- [table2fct (lot ag m) s] ]) |
ag <- agents ]
data Coin = H | T | F | U deriving (Eq,Ord,Show)
fairToss = \ xs -> [(H:xs, 1/2),(T:xs, 1/2)]
toss1 = gmapPEM fairToss (initPM [a] [])
urn :: (Int,Int) -> Pem (Int,Int)
urn (m,n) = liftEM u where
u :: EM (Int,Int)
u = Mo
[a,b]
[0]
[(0,[(m,n)])]
[(a,[[0]]),(b,[[0]])]
[0]
putWhite :: Pem (Int,Int) -> Pem (Int,Int)
putWhite = mapPEM (\ [(m,n)] -> [(m+1,n)])
putBlack :: Pem (Int,Int) -> Pem (Int,Int)
putBlack = mapPEM (\ [(m,n)] -> [(m,n+1)])
putMarble :: Pem (Int,Int) -> Pem (Int,Int)
putMarble = gmapPEM putM
putM :: [(Int,Int)] -> Lottery [(Int,Int)]
putM [(m,n)] = [([(m+1,n)],1),([(m,n+1)],1)]
drawMarble :: Pem (Int,Int) -> Pem (Int,Int)
drawMarble = gmapPEM drawM
drawM :: [(Int,Int)] -> Lottery [(Int,Int)]
drawM [(m,n)] = let
m1 = fromIntegral m
n1 = fromIntegral n
in
if (m+n) <= 0 then []
else if m == 0 then [([(0,n-1)],n1)]
else if n == 0 then [([(m-1,0)],m1)]
else [([(m-1,n)],m1),([(m,n-1)],n1)]
drawWhite :: Pem (Int,Int) -> Pem (Int,Int)
drawWhite = gmapPEM drawW
drawW :: [(Int,Int)] -> Lottery [(Int,Int)]
drawW [(m,n)] = let m1 = fromIntegral m
in
if (m+n) <= 0 then []
else if m == 0 then []
else [([(m-1,n)],m1)]
drawBlack :: Pem (Int,Int) -> Pem (Int,Int)
drawBlack = gmapPEM drawB
drawB :: [(Int,Int)] -> Lottery [(Int,Int)]
drawB [(m,n)] = let n1 = fromIntegral n
in
if (m+n) <= 0 then []
else if n == 0 then []
else [([(m,n-1)],n1)]
carroll = drawWhite $ putWhite $ putMarble $ urn (0,0)
carrollF :: Form (Int,Int)
carrollF = Info
(Inf (\ [(m,n)] -> (m,n) == (1,0)))
probWhite :: Pem (Int,Int) -> Prob
probWhite
m@(MO _ states val _ actual lots) = let
f = table2fct val
g = table2fct (lot a m)
h = \ p -> (f p, g p)
k = \ ([(m,n)],prb) -> let
m1 = fromIntegral m
n1 = fromIntegral n
in prb * (m1/(m1+n1))
fs = map (k.h) actual
in
sum fs
distMarbles3 :: Int -> Int -> [[Marble]]
distMarbles3 0 0 = [[]]
distMarbles3 m 0 = [take m (repeat W)]
distMarbles3 0 n = [take n (repeat B)]
distMarbles3 m n = map (W:) (distMarbles3 (m-1) n)
++ map (B:) (distMarbles3 m (n-1))
initU3 :: [Agent] -> (Int,Int) -> EM Marble
initU3 ags (m,n) = (Mo ags worlds val accs points)
where
k = binom (m+n) m
worlds = [0..k-1]
urns = distMarbles3 m n
val = zip worlds urns
accs = [ (ag,[worlds]) | ag <- ags ]
points = worlds
urn2 :: (Int,Int) -> Pem Marble
urn2 (m,n) = liftEM (initU3 [a,b] (m,n))
putWhite2 :: Pem Marble -> Pem Marble
putWhite2 = mapPEM (\ xs -> W:xs)
putBlack2 :: Pem Marble -> Pem Marble
putBlack2 = mapPEM (\ xs -> B:xs)
putMarble2 :: Pem Marble -> Pem Marble
putMarble2 = gmapPEM putM2
putM2 :: [Marble] -> Lottery [Marble]
putM2 xs = [(W:xs,1),(B:xs,1)]
remove :: Eq a => a -> [a] -> [[a]]
remove x [] = []
remove x (y:ys) = if x == y then
ys : map (y:) (remove x ys)
else map (y:) (remove x ys)
drawMarble2 :: Pem Marble -> Pem Marble
drawMarble2 = gmapPEM (\xs ->
zip (remove W xs ++ remove B xs) (repeat 1))
drawWhite2 :: Pem Marble -> Pem Marble
drawWhite2 = gmapPEM
(\ xs -> zip (remove W xs) (repeat 1))
drawBlack2 :: Pem Marble -> Pem Marble
drawBlack2 = gmapPEM
(\ xs -> zip (remove B xs) (repeat 1))
carroll2 = drawWhite2 $ putWhite2 $ putMarble2 $ urn2 (0,0)
bitTransfer :: Prob -> FUM Prp
bitTransfer = \ noise ags -> UM
ags
[0,1,2,3]
[(0,(p,[(Q 0,Top)])),(1,(p,[(Q 0,Ng Top)])),
(2,(Ng p,[(Q 0,Ng Top)])),(3,(Ng p,[(Q 0,Top)]))]
[ (x, [[0,1,2,3]]) | x <- ags ]
[0,1,2,3]
[ (x, [(0,1-noise), (1,noise), (2,1-noise), (3,noise)])
| x <- ags ]
bitTransf :: Prob -> Pem ([Bool],[Bool])
-> Pem ([Bool],[Bool])
bitTransf= \ noise -> gmapPEM
(\ [(x:xs,ys)] ->
[ ([(xs,x:ys)], 1 - noise), ([(xs,not x:ys)], noise)])
bitm :: [Agent] -> [Bool] -> EM ([Bool],[Bool])
bitm ags bits = Mo ags [0] val accs [0]
where
val = [(0,[(bits,[])])]
accs = [ (a,[[0]]) | a <- ags ]
bitM :: [Agent] -> [Bool] -> Pem ([Bool],[Bool])
bitM ags bits = liftEM (bitm ags bits)
transfer :: Prob -> Pem ([Bool],[Bool])
-> Pem ([Bool],[Bool])
transfer noise m@(MO _ _ ((_,[([],_)]):_) _ _ _) = m
transfer noise m = let m1 = bitTransf noise m in
transfer noise m1
tr :: [Bool] -> Prob -> Pem ([Bool],[Bool])
tr bits noise = transfer noise (bitM [a] bits)
repeatToss :: Int -> Pem Coin
repeatToss 0 =
MO [a] [0,1] [(0,[F]),(1,[U])] [(a,[[0,1]])] [0,1]
[(a,[(0,1/2),(1,1/2)])]
repeatToss n = let
m@(MO [a] ws val rel points lots) =
repeatToss (n-1)
k = length ws
wsh = ws
wst = map (+k) ws
ws1 = wsh ++ wst
val1 = map (\ (w,x:xs) -> (w,x:H:xs)) val
++
map (\ (w,x:xs) -> (w+k,x:T:xs)) val
rel1 = [(a,[ws1])]
points1 = ws1
f = \ (w,p) -> (w,1/2 * p)
g = \ (w,p) -> (w,2/3 * p)
h = \ (w,p) -> (w+k,1/2 * p)
j = \ (w,p) -> (w+k,1/3 * p)
lots1 = [(a,
amap f g (lot a m)
++
amap h j (lot a m))]
in
MO [a] ws1 val1 rel1 points1 lots1
amap :: (a -> b) -> (a -> b) -> [a] -> [b]
amap f g [] = []
amap f g (x:xs) = f x : amap g f xs
fair :: Form Coin
fair = Info (Inf (\xs -> head xs == F))
value :: [Coin] -> Form Coin
value xs = Info (Inf (\ys -> tail ys == xs))
genSequence :: [Coin] -> Pem Coin
genSequence [] =
MO [a] [0,1] [(0,[F]),(1,[U])] [(a,[[0,1]])] [0,1]
[(a,[(0,1/2),(1,1/2)])]
genSequence (H:xs) = let
m@(MO [a] ws val rel points lots) = genSequence xs
val1 = [(0,F:H:xs),(1,U:H:xs)]
p = table2fct (lot a m)
lots1 = [(a, [(0,p 0 * 1/2),(1, p 1 * 2/3)])]
in
MO [a] ws val1 rel points lots1
genSequence (T:xs) = let
m@(MO [a] ws val rel points lots) = genSequence xs
val1 = [(0,F:T:xs),(1,U:T:xs)]
p = table2fct (lot a m)
lots1 = [(a, [(0,p 0 * 1/2),(1, p 1 * 1/3)])]
in
MO [a] ws val1 rel points lots1