Source

hs-gray-code / Codec / Binary / Gray_props.hs

-- | QuickCheck properties of Codec.Binary.Gray module.
module Codec.Binary.Gray_props where

import Test.QuickCheck
import Codec.Binary.Gray

import Data.Bits (testBit, bitSize, Bits)
import Data.Function (on)

---
--- Properties of list-based functions
---

prop_lists_num2bin_id_Int =
  label "binaryToBits . bitsToBinary == id [Int]" $
  forAll (arbitrary :: Gen Int) $ \i ->
      i == (binaryToBits . bitsToBinary $ i)

prop_lists_num2bin_id_Integer =
  label "binaryToBits . bitsToBinary == id [Integer+]" $
  let i = (arbitrary :: Gen (NonNegative Integer))
  in  forAll i (\(NonNegative i) -> i == (binaryToBits . bitsToBinary $ i))

prop_lists_correct_bits_Int =
  label "bitsToBinary is correct [Int]" $
  forAll (arbitrary :: Gen Int) $ \i ->
      let bts = map (testBit i) [0..(bitSize i)-1]
          padded = (bitsToBinary i) ++ (repeat False)
      in  all id $ zipWith (==) bts padded

prop_lists_bin2gray_id =
  label "grayToBinary . binaryToGray == binaryToGray . grayToBinary == id" $
  forAll (listOf $ (arbitrary :: Gen Bool)) $ \bs ->
      bs == (grayToBinary . binaryToGray $ bs) &&
      bs == (binaryToGray . grayToBinary $ bs)

prop_lists_gray_succ_Integer =
  label "hamming x (x+1) == 1 [Integer+]" $
  let i = (arbitrary :: Gen Integer) `suchThat` (>= 0)
  in  forAll i succ_test

prop_lists_gray_succ_Int =
  label "hamming x (x+1) == 1 [Int]" $
  let i = (arbitrary :: Gen Int)
  in  forAll i succ_test

succ_test :: (Bits a) => a -> Bool
succ_test = \i ->
      let n2g = binaryToGray . bitsToBinary
          g1 = n2g i
          g2 = n2g (i+1)
      in  hamming g1 g2 == 1

hamming :: [Bool] -> [Bool] -> Int
hamming xs ys = go 0 xs ys
  where
    go d [] [] = d
    go d [] ys = go d [False] ys  -- extension for different lengths
    go d xs [] = go d [False] xs
    go d (x:xs) (y:ys) =
        if x == y
           then go d xs ys
           else go (d+1) xs ys

---
--- Properties of functions for Bits types
---
prop_bits_id = label "binary . gray == gray . binary == id" $
  forAll (arbitrary :: Gen Int) $ \i ->
      (binary . gray $ i) == i && (gray . binary $ i) == i

prop_bits_same_as_lists =
  label "bitsToBinary . gray == binaryToGray . bitsToBinary [Int]" $
  forAll (arbitrary :: Gen Int) $ \i ->
      (binaryToGray . bitsToBinary $ i) == (bitsToBinary . gray $ i)

prop_bits_gray_succ_Int = label "hamming x (x+1) == 1 [Int]" $
  forAll (arbitrary :: Gen Int) $ \i -> (hammingBits `on` gray) i (i+1) == 1
     
prop_bits_gray_succ_Integer = label "hamming x (x+1) == 1 [Integer]" $
  forAll (arbitrary :: Gen (NonNegative Integer)) $ \(NonNegative i) ->
      (hammingBits `on` gray) i (i+1) == 1
     
hammingBits :: (Bits a) => a -> a -> Int
hammingBits = hamming `on` bitsToBinary

---
--- Test groups
---

prop_lists = label "[Bool]" $
  prop_lists_num2bin_id_Int .&.
  prop_lists_num2bin_id_Integer .&.
  prop_lists_correct_bits_Int .&.
  prop_lists_bin2gray_id .&.
  prop_lists_gray_succ_Int .&.
  prop_lists_gray_succ_Integer

prop_bits = label "Bits" $
  prop_bits_id .&.
  prop_bits_same_as_lists .&.
  prop_bits_gray_succ_Int .&.
  prop_bits_gray_succ_Integer

all_props =
  prop_lists .&. prop_bits