module Data.RandProc (
ProbSpace(ProbSpace)
,Measure(Measure)
,Sample(Empty)
,TestResult(..)
,ErrType(..)
,checkProbMeas
,point
,range
,rangeBegin
,rangeEnd
,getProb
,getEvent
,getCompEvent
,sortSamps
,eventInt
,smplComp
,isElem
,noDupEvents
,smplInt
,smplSetInt
,smplUnion
,smplSetUnion
,checkSigma
,getRsltStr
) where
eps :: Double
eps = 0.000001
data ProbSpace = ProbSpace {
space :: [Sample]
,measure :: [Measure]
}
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) = not ((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)) = not ((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 <= s2 = not (s1 > s2)
s1 >= s2 = not (s1 < s2)
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 a = Point a
range :: (Double, Double) -> Sample
range (a, b)
| a == b = point a
| a < b = Range (a, b)
| otherwise = Range (b, a)
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 m = prob m
getEvent :: Measure -> Event
getEvent m = event m
getCompEvent :: [Sample] -> Event -> Event
getCompEvent [] _ = [Empty]
getCompEvent (s:ss) e = sortSamps $ smplSetUnion $ (foldl eventInt [s] (map (smplComp s) ( e))) ++ ( (getCompEvent ss e))
sortSamps :: [Sample] -> [Sample]
sortSamps [] = []
sortSamps (s:ss) = sortSamps([s' | s' <- ss, s' < s]) ++ [s] ++ sortSamps([s'' | s'' <- ss, s'' >= s])
eventInt :: Event -> Event -> Event
eventInt s1 s2
| length (filter (/= Empty) s1) == 0 = [Empty]
| length (filter (/= Empty) s2) == 0 = [Empty]
| otherwise = smplSetUnion $ concat $ map (\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) = not ((event m) `elem` 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]
| otherwise = [Point n, Point m]
smplUnion (Point n) (Range (a, b))
| (n > a) && (n < b) = [Range (a, b)]
| 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) || (a >= d) = [Range (a, b), Range (c, d)]
| otherwise = [Range (min a c, max b d)]
smplUnion Full _ = [Full]
smplUnion _ Full = [Full]
smplSetUnion :: [Sample] -> [Sample]
smplSetUnion [] = []
smplSetUnion ss = consolidateRPR $ smplSetUnionDraft ss
smplSetUnionDraft :: [Sample] -> [Sample]
smplSetUnionDraft [] = []
smplSetUnionDraft (x:xs)
| any (\y -> length y == 1) xs' = smplSetUnionDraft xs''
| otherwise = x : smplSetUnionDraft xs
where xs' = map (smplUnion x) xs
xs'' = map (selector x) xs
selector :: Sample -> Sample -> Sample
selector s1 s2
| length (smplUnion s1 s2) == 1 = head $ smplUnion s1 s2
| otherwise = s2
consolidateRPR :: [Sample] -> [Sample]
consolidateRPR [] = []
consolidateRPR ss = scanRPR $ sortSamps ss
scanRPR :: [Sample] -> [Sample]
scanRPR [] = []
scanRPR (s:ss)
| sampleType s == STRange = case (headIsPoint (rangeEnd (s)) ss) of
True -> case (headIsRange (tail ss) && (rangeBegin (head (tail ss))) == (rangeEnd (s))) of
True -> scanRPR $ Range ((rangeBegin (s)),rangeEnd(head (tail ss))) : (tail (tail ss))
_ -> s:(scanRPR ss)
_ -> 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
| length (filter (/= Empty) (space ps)) == 0 = Fail EmptySampleSpace
| length (es) == 0 = Fail EmptyEventSpace
| not (([Empty]) `elem` (es)) = Fail MissingNullEvent
| not (((space ps)) `elem` (es)) = Fail MissingCertainEvent
| not (and (map (and . map (\s -> (isElem (space ps) s) || (s == Empty))) (es)))
= Fail BadEventSamples
| not (and (map (\e -> ((getCompEvent (space ps) e) `elem` (es))) (es)))
= Fail MissingCompEvent
| not $ and $ map (`elem` es) $ removeDups $ map (sortSamps . smplSetUnion . concat) (filter (\s -> length s > 0) (subs ss))
= Fail MissingUnionEvent
| otherwise = Pass
where es = map (sortSamps . event) (measure ps)
ss = filter (\s -> length s > 0) $ map (filter (/= Empty) . event) (measure ps)
subs :: [a] -> [[a]]
subs [] = [[]]
subs (x:xs) = yss ++ map (x:) yss
where yss = subs 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
| checkSigma ps /= Pass = checkSigma ps
| not (length (es) == length (measure ps)) = Fail EventMeasLenMismatch
| not (noDupEvents (measure ps)) = Fail DupEventsInMeas
| not (length (filter (\m -> getEvent m `elem` (es)) (measure ps)) == length (es))
= Fail MissingEventsInMeas
| not (and $ map (\m -> getProb m == 0.0) (filter (\m -> getEvent m == []) (measure ps)))
= Fail NullEventNonZeroProb
| not (and $ map (\m -> getProb m == 1.0) (filter (\m -> getEvent m == (space ps)) (measure ps)))
= Fail CertainEventNonUnityProb
| not (and $ map (\m -> 1.0 (getProb m) ( (getProb (head (filter (\m' -> (sortSamps $ getEvent m') == (getCompEvent (space ps) (getEvent m))) (measure ps))))) < eps) (measure ps))
= Fail EventAndCompNoSumOne
| otherwise = Pass
where es = map event (measure ps)