Propagator.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Data.Propagator where

import qualified Control.Monad.Cell.Class as Cell
import Data.Holmes
import qualified Data.Propagator as Prop
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Data.List (nub)
import Prelude hiding (read)
import Test.Control.Monad.Cell.Class (Lestrade, read, scotlandYardSays)

hprop_eqR_reflexivity :: Property
hprop_eqR_reflexivity = property do
  x <- forAll (Gen.int (Range.linear 0 10))

  let program :: Lestrade h ()
      program = Prop.down (Prop.lift x .== Prop.lift x)
            >>= \o -> Cell.write o (Exactly True)

  if scotlandYardSays program == Nothing
    then failure
    else success

hprop_eqR_negation :: Property
hprop_eqR_negation = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let this :: Lestrade h ()
      this = Prop.down (Prop.lift x .== Prop.lift y)
         >>= \o -> Cell.write o (Exactly True)

      that :: Lestrade h ()
      that = Prop.down (Prop.lift x ./= Prop.lift y)
         >>= \o -> Cell.write o (Exactly False)

  scotlandYardSays this === scotlandYardSays that

hprop_eqR_simple :: Property
hprop_eqR_simple = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let program :: Lestrade h (Defined Bool)
      program = Prop.down (Prop.lift x .== Prop.lift y) >>= read

  scotlandYardSays program === Just (Exactly (x == y))

hprop_eqR_symmetry :: Property
hprop_eqR_symmetry = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let this :: Lestrade h (Defined Bool)
      this = Prop.down (Prop.lift x .== Prop.lift y) >>= read

      that :: Lestrade h (Defined Bool)
      that = Prop.down (Prop.lift y .== Prop.lift x) >>= read

  scotlandYardSays this === scotlandYardSays that

hprop_ordR_negation :: Property
hprop_ordR_negation = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let this :: Lestrade h (Defined Bool)
      this = Prop.down (Prop.lift x .<= Prop.lift y) >>= read

      that :: Lestrade h (Defined Bool)
      that = Prop.down (Prop.lift x .> Prop.lift y) >>= read

  scotlandYardSays this === fmap (fmap not) (scotlandYardSays that)

hprop_ordR_lteR_symmetry :: Property
hprop_ordR_lteR_symmetry = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let this :: Lestrade h (Defined Bool)
      this = Prop.down (Prop.lift x .<= Prop.lift y) >>= read

      that :: Lestrade h (Defined Bool)
      that = Prop.down (Prop.lift y .>= Prop.lift x) >>= read

  scotlandYardSays this === scotlandYardSays that

hprop_ordR_ltR_symmetry :: Property
hprop_ordR_ltR_symmetry = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let this :: Lestrade h (Defined Bool)
      this = Prop.down (Prop.lift x .< Prop.lift y) >>= read

      that :: Lestrade h (Defined Bool)
      that = Prop.down (Prop.lift y .> Prop.lift x) >>= read

  scotlandYardSays this === scotlandYardSays that

hprop_ordR_simple :: Property
hprop_ordR_simple = property do
  x <- forAll (Gen.int (Range.linear 0 10))
  y <- forAll (Gen.int (Range.linear 0 10))

  let x', y' :: MonadCell m => Prop m (Defined Int)
      x' = Prop.lift x
      y' = Prop.lift y

      program :: Lestrade h (Defined Bool)
      program = Prop.down (x' .<= y') >>= read

  scotlandYardSays program === Just (Exactly (x <= y))

hprop_choice_unique_choices :: Property
hprop_choice_unique_choices = property do
  n <- forAll $ Gen.int (Range.linear 0 6)
  k <- forAll $ Gen.int (Range.linear 0 n)

  let choices = Prop.choose n k

  nub choices === choices

hprop_choice_correct_number_of_choices :: Property
hprop_choice_correct_number_of_choices = property do
  n <- forAll $ Gen.int (Range.linear 0 6)
  k <- forAll $ Gen.int (Range.linear 0 n)

  let choices = Prop.choose n k
      factorial 0 = 1
      factorial m = m * factorial (pred m)

  length choices === factorial n `div` (factorial k * factorial (n-k))

hprop_exactly_simple :: Property
hprop_exactly_simple = property do
  xs <- forAll (Gen.list (Range.linear 0 10) (Gen.int (Range.linear 0 10)))
  k  <- forAll (Gen.int (Range.linear 0 (length xs)))
  x  <- forAll (Gen.int (Range.linear 0 10))

  let x' :: MonadCell m => Prop m (Defined Int)
      x' = Prop.lift x
      
      xs' :: MonadCell m => [Prop m (Defined Int)]
      xs' = map Prop.lift xs

      program :: Lestrade h (Defined Bool)
      program = Prop.down (Prop.exactly k (.== x') xs') >>= read

      expected = length (filter (==x) xs) == k

  scotlandYardSays program === Just (Exactly expected)