module Data.RandProc (
ProbSpace(ProbSpace)
,Measure(Measure)
,Sample(Empty)
,TestResult(..)
,ErrType(..)
,checkProbMeas
,point
,range
,makeProbSpace
,rangeBegin
,rangeEnd
,getProb
,getEvent
,getCompEvent
,eventInt
,smplComp
,isElem
,noDupEvents
,smplInt
,smplSetInt
,smplUnion
,smplSetUnion
,checkSigma
,getRsltStr
) where
import Data.List
eps :: Double
eps = 0.000001
data ProbSpace = ProbSpace {
space :: [Sample]
,measure :: [Measure]
} deriving (Show)
data Sample = Point Double
| Range (Double, Double)
| Empty
| Full
deriving (Eq, Show)
instance Ord Sample where
_ < Empty = False
Empty < _ = True
Full < _ = False
_ < Full = True
(Point p) < (Point p') = p < p'
(Point p) < (Range (r1, _)) = p <= r1
(Range (r1, r2)) < (Point p) = Point p >= Range (r1, r2)
(Range (r1, r2)) < (Range (r3, r4))
| r1 == r3 = r2 < r4
| otherwise = r1 < r3
Empty > _ = False
_ > Empty = True
_ > Full = False
Full > _ = True
(Point p) > (Point p') = p > p'
(Point p) > (Range (r1, r2)) = Point p >= Range (r1, r2)
(Range (r1, r2)) > (Point p) = Point p < Range (r1, r2)
(Range (r1, r2)) > (Range (r3, r4))
| r1 == r3 = r2 > r4
| otherwise = r1 > r3
(<=) s1 = not . (s1 >)
(>=) s1 = not . (s1 <)
data SampleType = STPoint
| STRange
| STEmpty
| STFull
deriving (Eq, Show)
sampleType :: Sample -> SampleType
sampleType (Point _) = STPoint
sampleType (Range _) = STRange
sampleType Empty = STEmpty
sampleType Full = STFull
type Event = [Sample]
data Measure = Measure {
event :: Event
,prob :: Double
}
deriving (Eq, Ord, Show)
point :: Double -> Sample
point = Point
range :: (Double, Double) -> Sample
range (a, b)
| a == b = point a
| a < b = Range (a, b)
| otherwise = Range (b, a)
makeProbSpace :: [(Sample, Double)] -> ProbSpace
makeProbSpace [] = ProbSpace {
space = [
Empty
,Full
]
,measure = [
Measure {
event = [Empty]
,prob = 0
}
,Measure {
event = [Full]
,prob = 1
}
]
}
makeProbSpace ps = ProbSpace {
space = [fst p | p <- ps]
,measure = Measure {
event = [Empty]
,prob = 0
}
: [Measure e (sum [snd p | p <- ps, fst p `elem` e]) | e <- ss]
}
where ss = filter (not . null) $ subs $ map fst ps
rangeBegin :: Sample -> Double
rangeBegin (Point _) = undefined
rangeBegin (Range (a,_)) = a
rangeBegin Empty = undefined
rangeBegin Full = undefined
rangeEnd :: Sample -> Double
rangeEnd (Point _) = undefined
rangeEnd (Range (_,b)) = b
rangeEnd Empty = undefined
rangeEnd Full = undefined
getProb :: Measure -> Double
getProb = prob
getEvent :: Measure -> Event
getEvent = event
getCompEvent :: [Sample] -> Event -> Event
getCompEvent [] _ = [Empty]
getCompEvent (s:ss) e = smplSetUnion $ foldl eventInt [s] (map (smplComp s) e) ++ getCompEvent ss e
eventInt :: Event -> Event -> Event
eventInt s1 s2
| null (filter (/= Empty) s1) = [Empty]
| null (filter (/= Empty) s2) = [Empty]
| otherwise = smplSetUnion $ concatMap (\s -> (map (smplInt s) s1)) s2
smplComp :: Sample -> Sample -> [Sample]
smplComp Empty _ = [Empty]
smplComp s Empty = [s]
smplComp (Point n) (Point m)
| m == n = [Empty]
| otherwise = [Point n]
smplComp (Point n) (Range (a, b))
| (n > a) && (n < b) = [Empty]
| otherwise = [Point n]
smplComp (Range (a, b)) (Point n)
| (n > a) && (n < b) = [Range (a, n), Range (n, b)]
| otherwise = [Range (a, b)]
smplComp (Range (a, b)) (Range (c, d))
| (c >= b) || (a >= d) = [Range (a, b)]
| (c <= a) && (d >= b) = [Empty]
| (c > a) && (d < b) = [Range (a, c), Range (d, b), Point c, Point d]
| a < c = [Range (a, c), Point c]
| otherwise = [Range (d, b), Point d]
smplComp _ Full = [Empty]
smplComp Full _ = undefined
isElem :: [Sample] -> Sample -> Bool
isElem [] _ = False
isElem _ Empty = True
isElem (s:ss) s' = testElem s s' || isElem ss s'
testElem :: Sample -> Sample -> Bool
testElem Empty _ = False
testElem _ Empty = True
testElem (Point x) (Point y) = x == y
testElem (Point _) (Range _) = False
testElem (Range (x, y)) (Point z) = (z > x) && (z < y)
testElem (Range (x, y)) (Range (w, z)) = (w >= x) && (z <= y)
testElem Full _ = True
testElem _ Full = False
noDupEvents :: [Measure] -> Bool
noDupEvents [] = True
noDupEvents (m:ms) = notElem (event m) es && noDupEvents ms
where es = map event ms
smplInt :: Sample -> Sample -> Sample
smplInt Empty _ = Empty
smplInt _ Empty = Empty
smplInt Full s = s
smplInt s Full = s
smplInt (Point n) (Point m)
| m == n = Point n
| otherwise = Empty
smplInt (Point n) (Range (a, b))
| (n > a) && (n < b) = Point n
| otherwise = Empty
smplInt (Range (a, b)) (Point n) = smplInt (Point n) (Range (a, b))
smplInt (Range (a, b)) (Range (c, d))
| (c >= b) || (a >= d) = Empty
| otherwise = Range (max a c, min b d)
smplSetInt :: [Sample] -> Sample
smplSetInt = foldl smplInt Full
smplUnion :: Sample -> Sample -> [Sample]
smplUnion Empty s = [s]
smplUnion s Empty = [s]
smplUnion (Point n) (Point m)
| m == n = [Point n]
| m < n = [Point m, Point n]
| otherwise = [Point n, Point m]
smplUnion (Point n) (Range (a, b))
| (n > a) && (n < b) = [Range (a, b)]
| n >= b = [Range (a, b), Point n]
| otherwise = [Point n, Range (a, b)]
smplUnion (Range (a, b)) (Point n) = smplUnion (Point n) (Range (a, b))
smplUnion (Range (a, b)) (Range (c, d))
| c >= b = [Range (a, b), Range (c, d)]
| a >= d = [Range (c, d), Range (a, b)]
| otherwise = [Range (min a c, max b d)]
smplUnion Full _ = [Full]
smplUnion _ Full = [Full]
smplUnionRecursRev :: [Sample] -> Sample -> [Sample]
smplUnionRecursRev [] s = [s]
smplUnionRecursRev (Empty : ss) s = smplUnionRecursRev ss s
smplUnionRecursRev (s : ss) Empty = smplUnionRecursRev ss s
smplUnionRecursRev (Point m : ss) (Point n)
| m == n = smplUnionRecursRev ss (Point n)
| otherwise = Point n : Point m : ss
smplUnionRecursRev ((Range (a, b)) : ss) (Point n)
| (n > a) && (n < b) = smplUnionRecursRev ss (Range (a, b))
| otherwise = Point n : Range (a, b) : ss
smplUnionRecursRev ((Point n) : ss) (Range (a, b)) = Range (a, b) : Point n : ss
smplUnionRecursRev ((Range (c, d)) : ss) (Range (a, b))
| a >= d = Range (a, b) : Range (c, d) : ss
| otherwise = smplUnionRecursRev ss (Range (c, max b d))
smplUnionRecursRev _ Full = [Full]
smplUnionRecursRev (Full : _) _ = [Full]
smplSetUnion :: [Sample] -> [Sample]
smplSetUnion = consolidateRPR . foldl smplUnionRecursRev [] . sort
consolidateRPR :: [Sample] -> [Sample]
consolidateRPR = scanRPR . sort
scanRPR :: [Sample] -> [Sample]
scanRPR [] = []
scanRPR (s:ss)
| sampleType s == STRange =
if headIsPoint (rangeEnd s) ss &&
headIsRange (tail ss) &&
rangeBegin (head (tail ss)) == rangeEnd s
then
scanRPR $ Range (rangeBegin s, rangeEnd (head (tail ss))) : tail (tail ss)
else s : scanRPR ss
| otherwise = s : scanRPR ss
headIsPoint :: Double -> [Sample] -> Bool
headIsPoint _ [] = False
headIsPoint a (s:_) = s == Point a
headIsRange :: [Sample] -> Bool
headIsRange [] = False
headIsRange (s:_) = sampleType s == STRange
data TestResult = Fail {err :: ErrType}
| Pass
deriving (Show)
instance Eq TestResult where
Pass == Pass = True
Fail e == Fail e' = e == e'
_ == _ = False
data ErrType = UnknownErr
| EmptySampleSpace
| EmptyEventSpace
| MissingNullEvent
| MissingCertainEvent
| BadEventSamples
| MissingCompEvent
| MissingUnionEvent
| EventMeasLenMismatch
| DupEventsInMeas
| MissingEventsInMeas
| NullEventNonZeroProb
| CertainEventNonUnityProb
| EventAndCompNoSumOne
deriving (Eq, Show)
getErrStr :: ErrType -> String
getErrStr UnknownErr = "Unknown error"
getErrStr EmptySampleSpace = "Empty sample space"
getErrStr EmptyEventSpace = "Empty event space"
getErrStr MissingNullEvent = "The null event is missing from the event space."
getErrStr MissingCertainEvent = "The certain event is missing from the event space."
getErrStr BadEventSamples = "At least one event contains samples not in the sample space."
getErrStr MissingCompEvent = "At least one event's compliment is missing from the event space."
getErrStr MissingUnionEvent = "At least one union of events is missing from the event space."
getErrStr EventMeasLenMismatch = "Lengths of event and measure lists don't match."
getErrStr DupEventsInMeas = "There are duplicate events in the measure list."
getErrStr MissingEventsInMeas = "Some events aren't covered in the measure list."
getErrStr NullEventNonZeroProb = "The null event has been assigned a non-zero probability."
getErrStr CertainEventNonUnityProb = "The certain event has been assigned a probability other than 1."
getErrStr EventAndCompNoSumOne = "At least one pair of event and compliment have probabillities that don't add to 1."
getRsltStr :: TestResult -> String
getRsltStr Pass = "Ok"
getRsltStr tr = getErrStr $ err tr
checkSigma :: ProbSpace -> TestResult
checkSigma ps
| null (filter (/= Empty) sp) = Fail EmptySampleSpace
| null es = Fail EmptyEventSpace
| notElem [Empty] es = Fail MissingNullEvent
| notElem sp es && notElem [Full] es = Fail MissingCertainEvent
| not $ all (all (\ s -> isElem sp s || (s == Empty))) es
= Fail BadEventSamples
| not $ all (\e -> getCompEvent sp e `elem` es) es
= Fail MissingCompEvent
| not $ all (`elem` es) (eventUnions es)
= Fail MissingUnionEvent
| otherwise = Pass
where es = map (sort . event) (measure ps)
ss = filter (not . null) $ map (filter (/= Empty) . event) (measure ps)
sp = space ps
eventUnions :: [Event] -> [Event]
eventUnions es = concat $ foldl' (\xs x -> removeDups (map (smplSetUnion . concat . (x:)) xs : xs )) [[]] es'
where es' = filter (not . null) $ map (filter (/= Empty)) es
subs :: [a] -> [[a]]
subs = foldl' (\xs x -> xs ++ map (x:) xs) [[]]
removeDups :: (Eq a) => [a] -> [a]
removeDups [] = []
removeDups (x:xs) = x : removeDups ys
where ys = [y | y <- xs, y /= x]
checkProbMeas :: ProbSpace -> TestResult
checkProbMeas ps
| cs /= Pass = cs
| not (noDupEvents (measure ps)) = Fail DupEventsInMeas
| not $ all (\m -> getProb m == 0.0) (filter (\m -> getEvent m == [] || getEvent m == [Empty]) (measure ps))
= Fail NullEventNonZeroProb
| not $ all (\m -> getProb m == 1.0) (filter (\m -> getEvent m == space ps) (measure ps))
= Fail CertainEventNonUnityProb
| not $ all (\m -> 1.0 getProb m getProb (head (filter (\m' -> sort (getEvent m') == getCompEvent (space ps) (getEvent m)) (measure ps))) < eps) (measure ps)
= Fail EventAndCompNoSumOne
| otherwise = Pass
where cs = checkSigma ps