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