namin / spots

various code snippets in various languages

This URL has Read+Write access

spots / probabilisticModeling / probabilisticModeling.hs
raw normal view history
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 1 import System.Random
c587052e » namin 2008-12-18 added support as plain list... 2 import Data.Set (Set)
3 import qualified Data.Set as Set
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 4
5 data Sample a =
6 Sample (IO a)
7
c587052e » namin 2008-12-18 added support as plain list... 8 data Support a =
9 Support ([a])
10
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 11 data Expectation a =
12 Expectation ((a -> Double) -> Double)
13
14 data Distribution a =
c587052e » namin 2008-12-18 added support as plain list... 15 Distribution (Sample a) (Support a) (Expectation a)
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 16
17 always x =
c587052e » namin 2008-12-18 added support as plain list... 18 Distribution (Sample sample) (Support support) (Expectation expectation)
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 19 where sample = return x
c587052e » namin 2008-12-18 added support as plain list... 20 support = [x]
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 21 expectation h = h(x)
22
23 rnd :: IO Double
24 rnd = getStdRandom (randomR (0.0,1.0))
25
26 coinFlip p
c587052e » namin 2008-12-18 added support as plain list... 27 (Distribution (Sample sample1) (Support support1) (Expectation expectation1))
28 (Distribution (Sample sample2) (Support support2) (Expectation expectation2)) =
29 Distribution (Sample sample) (Support support) (Expectation expectation)
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 30 where sample = do rndProb <- rnd; if rndProb < p then sample1 else sample2
c587052e » namin 2008-12-18 added support as plain list... 31 support = support1 ++ support2
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 32 expectation h = p * expectation1(h) + (1.0-p) * expectation2(h)
33
c587052e » namin 2008-12-18 added support as plain list... 34 distSample (Distribution (Sample sample) (Support support) (Expectation expectation)) = sample
35 distSupport (Distribution (Sample sample) (Support support) (Expectation expectation)) = support
36 distExpectation (Distribution (Sample sample) (Support support) (Expectation expectation)) = expectation
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 37
38 (|>) x f = f x
39
40 bind dist k =
c587052e » namin 2008-12-18 added support as plain list... 41 Distribution (Sample sample) (Support support) (Expectation expectation)
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 42 where sample = do d <- dist |> distSample; k d |> distSample
c587052e » namin 2008-12-18 added support as plain list... 43 support = dist |> distSupport |> concatMap (\d -> (k d) |> distSupport)
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 44 expectation h = (dist |> distExpectation)(\x -> ((k x) |> distExpectation)(h))
45
c587052e » namin 2008-12-18 added support as plain list... 46 distWithCleanSupport (Distribution s (Support support) e) =
47 Distribution s (Support support') e
48 where support' = support |> Set.fromList |> Set.toList
49
6c5a3b78 » namin 2008-12-18 added probabilistic modelin... 50 instance Monad Distribution where
51 (>>=) = bind
52 return = always
53
54 weightedCases inp =
55 coinFlips 0.0 inp
56 where coinFlips w l =
57 case l of
58 [] -> error "no coinFlips"
59 [(d,_)] -> always d
60 (d,p):rest -> coinFlip (p/(1.0-w)) (always d) (coinFlips (w+p) rest)
61
62 countedCases inp =
63 weightedCases (inp |> map (\(x,v) -> (x,v/total)))
64 where total = 1.0*(inp |> map (\(_,v) -> v) |> sum)
65
66 data Outcome = Even | Odd | Zero deriving (Show,Eq,Ord)
67
68 roulette = countedCases [(Even,18),(Odd,18),(Zero,1)]
69
70 printSample d =
71 do r <- distSample d
72 putStrLn $ show $ r
73
74 printExpectation d h =
75 putStrLn $ show $ (distExpectation d) h
76
77 data Light = Red | Green | Yellow deriving (Show,Eq,Ord)
78
79 trafficLightD = weightedCases [(Red,0.50),(Yellow,0.10),(Green,0.40)]
80
81 data Action = Stop | Drive deriving (Show,Eq,Ord)
82
83 cautiousDriver light =
84 case light of
85 Red -> always Stop
86 Yellow -> weightedCases [(Stop,0.9),(Drive,0.1)]
87 Green -> always Drive
88
89 aggressiveDriver light =
90 case light of
91 Red -> weightedCases [(Stop,0.9),(Drive,0.1)]
92 Yellow -> weightedCases [(Stop,0.1),(Drive,0.9)]
93 Green -> always Drive
94
95 otherLight light =
96 case light of
97 Red -> Green
98 Yellow -> Red
99 Green -> Red
100
101 data CrashResult = Crash | NoCrash deriving (Show,Eq,Ord)
102
103 crash driverOneD driverTwoD lightD =
104 do light <- lightD
105 driverOne <- driverOneD light
106 driverTwo <- driverTwoD (otherLight light)
107 case (driverOne,driverTwo) of
108 (Drive,Drive) -> weightedCases [(Crash,0.9),(NoCrash,0.1)]
109 _ -> return NoCrash
110
111 model = crash cautiousDriver aggressiveDriver trafficLightD
112
113 model2 = crash aggressiveDriver aggressiveDriver trafficLightD
114
115 main =
116 do printSample roulette
117 -- Odd
118 printSample roulette
119 -- Even
120 printExpectation roulette (\x -> case x of
121 Even -> 10.0
122 Odd -> 0.0
123 Zero -> 0.0)
124 -- 4.864864864864865
125 printSample model
126 -- NoCrash
127 printSample model
128 -- NoCrash
129 printExpectation model (\x -> case x of
130 Crash -> 1.0
131 NoCrash -> 0.0)
132 -- 0.036899999999999995
133 printExpectation model2 (\x -> case x of
134 Crash -> 1.0
135 NoCrash -> 0.0)
136 -- 0.08909999999999998