A demo of some properties of Shannon entropy

.gitignore

entropy-demo

entropy-demo.hs

-- Imports
import qualified Data.Vector.Unboxed as U

-- A type to represent a probability distribution
type ProbabilityDistribution = U.Vector Double

-- Represent a statement by a vector of bools (which atoms are included)
type Statement = U.Vector Bool

-- Input a probability distribution p(x) and a statement S
-- Return p(x | S)
given :: ProbabilityDistribution -> Statement -> ProbabilityDistribution
given p s = normalise p' where
  p'    = U.zipWith f p s
  f x y = if y then x else 0.0

-- x*log(x) for non-negative x
xlogx :: Double -> Double
xlogx x
  | x == 0.0  = 0.0
  | otherwise = x * log x

-- Normalise a vector
normalise :: U.Vector Double -> U.Vector Double
normalise vec = U.map ( * (1.0/tot) ) vec where
  tot = U.sum vec

-- Entropy of a probability distribution
entropy :: ProbabilityDistribution -> Double
entropy p = let minusPlogp = U.map (negate . xlogx) p in
  U.sum minusPlogp

-- x -> exp(-x)
expMinus :: Double -> Double
expMinus = exp . negate

-- Main IO action
main :: IO ()
main = do
  -- A probability distribution
  let p = normalise $ U.fromList [1, 1, 1]

  -- Show the probability distribution
  putStrLn $ "Atom probabilities:"
  putStrLn $ "p = " ++ show p
  putStrLn ""

  -- Entropy of central issue
  putStrLn $ "Entropy of central issue:"
  putStrLn $ "H(A|B|C; top) = " ++ show (entropy p)
  putStrLn ""

  -- (A v B), C
  let pAB_C = U.fromList [p U.! 0 + p U.! 1, p U.! 2]
  putStrLn $ "Entropy of partition question 1:"
  putStrLn $ "H(AB|C; top) = " ++ show (entropy pAB_C)
  putStrLn ""

  -- (A v C), B
  let pAC_B = U.fromList [p U.! 0 + p U.! 2, p U.! 1]
  putStrLn $ "Entropy of partition question 2:"
  putStrLn $ "H(AC|B; top) = " ++ show (entropy pAC_B)
  putStrLn ""

  -- (B v C), A
  let pBC_A = U.fromList [p U.! 1 + p U.! 2, p U.! 0]
  putStrLn $ "Entropy of partition question 3:"
  putStrLn $ "H(BC|A; top) = " ++ show (entropy pBC_A)
  putStrLn ""

  let h = negate $ log d
      d = expMinus (entropy pAB_C) + expMinus (entropy pAC_B)
            - expMinus (entropy p) 
  putStrLn $ "d(precisional; top) = " ++ show d

  return ()

Makefile

default:
	stack ghc -- -Wall -fforce-recomp entropy-demo
	rm *.hi *.o