Semiring.hs

-- | Tests the four WMC semirings directly.
module Test.Semiring (tests) where

import qualified Data.Map.Strict as Map
import qualified Data.Vector as V
import Test.Tasty
import Test.Tasty.HUnit

import Imp.Semiring

-- | Monomial keys are bitmasks, so @x0@ is @bit 0@.
x0, x1, notX0 :: PolyS
x0    = PolyS (Map.singleton 1 1)
x1    = PolyS (Map.singleton 2 1)
notX0 = PolyS (Map.fromList [(0, 1), (1, -1)])

tests :: TestTree
tests = testGroup "Semiring"
  [ testGroup "ProbS"
    [ testCase "sumS adds" $ unProb (sumS [ProbS 0.1, ProbS 0.2, ProbS 0.3]) @?= 0.6000000000000001

    , testCase "sumS of nothing is zero" $ unProb (sumS []) @?= 0.0

    , testCase "identities" $ do
        (zero .+. ProbS 0.25) @?= ProbS 0.25
        (one .*. ProbS 0.25) @?= ProbS 0.25
        (zero .*. ProbS 0.25) @?= ProbS 0.0
    ]

  , testGroup "IntervalS"
    [ testCase "componentwise product and sum" $ do
        (IntervalS 0.2 0.4 .*. IntervalS 0.5 0.6) @?= IntervalS 0.1 0.24
        (IntervalS 0.2 0.4 .+. IntervalS 0.5 0.6) @?= IntervalS 0.7 1.0

    , testCase "identities" $ do
        (zero .+. IntervalS 0.2 0.4) @?= IntervalS 0.2 0.4
        (one .*. IntervalS 0.2 0.4) @?= IntervalS 0.2 0.4
    ]

  , testGroup "DualS"
    [ testCase "product rule" $
        (DualS 2 (V.fromList [1, 0]) .*. DualS 3 (V.fromList [0, 1]))
          @?= DualS 6 (V.fromList [3, 2])

    , testCase "sum adds gradients" $
        (DualS 2 (V.fromList [1, 0]) .+. DualS 3 (V.fromList [0, 1]))
          @?= DualS 5 (V.fromList [1, 1])

    , testCase "empty gradient is absorbed, not zipped away" $ do
        (zero .+. DualS 5 (V.fromList [1, 2])) @?= DualS 5 (V.fromList [1, 2])
        (one .*. DualS 5 (V.fromList [1, 2])) @?= DualS 5 (V.fromList [1, 2])
    ]

  , testGroup "PolyS"
    [ testCase "monomials are idempotent" $
        (x0 .*. x0) @?= x0

    , testCase "distinct monomials union their masks" $
        unPoly (x0 .*. x1) @?= Map.singleton 3 1.0

    , testCase "addition drops cancelling terms" $
        (PolyS (Map.singleton 0 1) .+. PolyS (Map.singleton 0 (-1))) @?= zero

    , testCase "identities" $ do
        unPoly (one :: PolyS) @?= Map.singleton 0 1.0
        unPoly (zero :: PolyS) @?= Map.empty
        (one .*. notX0) @?= notX0
        (zero .+. notX0) @?= notX0
        (notX0 .*. x0) @?= zero
    ]
  ]