Dempster-Shafer theory of evidence in Haskell

DST.hs

-- | Simple implementation of DST
module DST where

import Control.Applicative
import Data.Foldable
import Data.Monoid
import Data.Semigroup
import qualified Data.Set as S

-- | Belief structure, mass function, basic belief assignment
type BeliefStructure a = S.Set a -> Double

-- | Compute the degree belief in a set of propositions
belief :: Ord a => BeliefStructure a -> S.Set a -> Double
belief bs = sum . fmap getSum . fmap (Sum . bs) . subsets

-- | Compute the plausibility of a set of propositions
plausibility :: (Bounded a, Enum a, Ord a) => BeliefStructure a -> S.Set a -> Double
plausibility bs a = sum $ fmap getSum $ fmap (Sum . bs) otherSets where
  theSet = S.fromList [minBound..maxBound]
  otherSets = filter (not . S.null . S.intersection a) $ subsets theSet

-- | Combination rule for belief structures 
-- cf. Dubois and Prade: Representation and combination of uncertainty with
-- belief functions and possibility measures. Computational Intelligence 4
-- pp. 244-264 (1988)
combineMYCIN :: (Bounded a, Enum a, Ord a) => BeliefStructure a -> BeliefStructure a -> BeliefStructure a
combineMYCIN l r = \a -> (mlt a) / bottom where
  mlt = (*) <$> l <*> r
  bottom = maximum $ fmap mlt $ subsets theSet
  theSet = S.fromList [minBound .. maxBound]

-- | Dempster's rule of combination
-- cf. Halpern: Reasoning about Uncertainty. MIT Press 2005
combineDS :: (Bounded a, Enum a, Ord a) => BeliefStructure a -> BeliefStructure a -> BeliefStructure a
combineDS l r a = tp where
  allSubsets = [ (ls, rs) | ls <- subsets', rs <- subsets']
  tp = if (S.null a) then 0 else (sum $ fmap (\(ls, rs) -> (l ls) * (r rs)) $ filter (\(ls, rs) -> S.intersection ls rs == a) allSubsets) / bt
  bt = sum $ fmap (\(ls, rs) -> l ls * r rs) $ filter (\(ls, rs) -> not $ S.null $ S.intersection ls rs) allSubsets
  theSet = S.fromList [minBound .. maxBound]
  subsets' = subsets theSet

-- | Get all subsets of a list
choose :: [b] -> Int -> [[b]]
_      `choose` 0       = [[]]
[]     `choose` _       =  []
(x:xs) `choose` k       =  (x:) `fmap` (xs `choose` (k-1)) ++ xs `choose` k

-- | Get all subsets of a set
subsets :: Ord a => S.Set a -> [S.Set a]
subsets s = fmap S.fromList ss where
  ss = concat $ fmap ch [0..n]
  sss = S.toList s
  ch = choose sss
  n = S.size s