diff --git a/Codec/Binary/Gray.hs b/Codec/Binary/Gray.hs --- a/Codec/Binary/Gray.hs +++ b/Codec/Binary/Gray.hs @@ -1,60 +1,4 @@ --- | Gray code is a binary numeral system where two successive numbers --- differ in only one bit. module Codec.Binary.Gray - ( - -- * List functions (for @[Bool]@) - binaryToGray, grayToBinary - , bitsToBinary, binaryToBits - , showBinary - ) where - -import Data.Bits (Bits, testBit, shiftR, bitSize) - -xor :: Bool -> Bool -> Bool -xor p q = (p && not q) || (not p && q) - --- | Takes a list of bits (most significant last) in binary encoding --- and converts them to Gray code. --- --- Algorithm: --- Haupt, R.L. and Haupt, S.E., Practical Genetic Algorithms, --- Second ed. (2004), 5.4. Gray Codes. -binaryToGray :: [Bool] -> [Bool] -binaryToGray (b:c:bs) = b `xor` c : binaryToGray (c:bs) -binaryToGray [b] = [b] -binaryToGray [] = [] - --- | Takes a list of bits in Gray code and converts them to binary encoding --- (most significant bit last). --- --- Algorithm: --- Haupt, R.L. and Haupt, S.E., Practical Genetic Algorithms, --- Second ed. (2004), 5.4. Gray Codes. -grayToBinary :: [Bool] -> [Bool] -grayToBinary = foldr go [] - where go c [] = [c] - go c bs@(b:_) = b `xor` c : bs - --- | Convert a number to a list of bits in usual binary encoding (most --- significant last). --- --- As 'bitSize', 'bitsToBinary' is undefined for types that do not --- have fixed bitsize, like 'Integer'. -bitsToBinary :: (Bits b) => b -> [Bool] -bitsToBinary 0 = [] -bitsToBinary i - | signum i == (-1) = - let b = map not . bitsToBinary $ negate i - 1 - in b ++ (take (bitSize i - length b) $ repeat True) -- pad major bits - | otherwise = - let rest = bitsToBinary $ shiftR i 1 -- works only for positive i - in (testBit i 0 : rest) - --- | Convert a list of bits in binary encoding to a number. -binaryToBits :: (Bits a) => [Bool] -> a -binaryToBits = sum . map fst . filter snd . zip (map (2^) [0..]) + ( module Codec.Binary.Gray.Bits ) where --- | Render a list of bits as a 0-1 string. -showBinary :: [Bool] -> String -showBinary [] = "0" -showBinary bs = map (\b -> if b then '1' else '0') . reverse $ bs +import Codec.Binary.Gray.Bits diff --git a/Codec/Binary/Gray/Bits.hs b/Codec/Binary/Gray/Bits.hs new file mode 100644 --- /dev/null +++ b/Codec/Binary/Gray/Bits.hs @@ -0,0 +1,65 @@ +-- | Gray code is a binary numeral system where two successive numbers +-- differ in only one bit. +-- +-- This module provides an interface to encode/decode @'Bits'@ types. +-- +-- Algorithm: +-- Haupt, R.L. and Haupt, S.E., Practical Genetic Algorithms, +-- Second ed. (2004), 5.4. Gray Codes. +module Codec.Binary.Gray.Bits + ( gray + , binary + , showBits + ) where + +import Data.Bits + ( Bits, testBit, setBit, clearBit, bitSize + , shiftL, shiftR, complement, xor, (.&.), (.|.), isSigned) + +import qualified Codec.Binary.Gray.List as L + +-- | Right shift without extension of the sign bit (reset it to zero). +shiftR' :: (Bits a) => a -> Int -> a +shiftR' n 0 = n +shiftR' n s + | isSigned n && signum n == -1 = + let n' = clearBit (shiftR n 1) (bitSize n - 1) + in shiftR' n' (s-1) + | otherwise = shiftR n s + +-- | Convert an integer number from binary to Gray code. +-- +-- 'gray' is undefined for negative numbers of types that do not have +-- fixed bitsize, e.g. for negative 'Integer's. +gray :: (Bits a) => a -> a +gray n = n `xor` (shiftR' n 1) + +-- | Convert an integer number from Gray code to binary. +-- +-- 'binary' is undefined for types that do not have fixed bitsize, +-- e.g. for 'Integer'. +binary :: (Bits a) => a -> a +binary 0 = 0 +binary n = + binary' mask0 n (copyMSB n) + where + sz = bitSize n - 1 + mask0 = let m = setBit 0 sz in (m, m) + copyMSB n = (setBit 0 sz) .&. n + +binary' (maskReady, maskLast) ngray nbin + | complement maskReady == 0 = nbin + | otherwise = + let + sz = bitSize ngray - 1 + nReady = maskReady .&. nbin + maskReady' = setBit (shiftR maskReady 1) sz + maskLast' = shiftR' maskLast 1 + nNext = (shiftR' (maskLast .&. nReady) 1) `xor` (maskLast' .&. ngray) + in + binary' (maskReady', maskLast') ngray (nReady .|. nNext) + +-- | Render binary code as a string of @0@s and @1@s. +-- For example, @(42::Int8)@ is formatted as @101010@. +showBits :: (Bits a) => a -> String +showBits = L.showBits . L.toList diff --git a/Codec/Binary/Gray/List.hs b/Codec/Binary/Gray/List.hs new file mode 100644 --- /dev/null +++ b/Codec/Binary/Gray/List.hs @@ -0,0 +1,57 @@ +-- | Gray code is a binary numeral system where two successive numbers +-- differ in only one bit. +-- +-- This module provides an interface to encode/decode numbers +-- represented as lists of @Bool@. +-- +-- Algorithm: +-- Haupt, R.L. and Haupt, S.E., Practical Genetic Algorithms, +-- Second ed. (2004), 5.4. Gray Codes. +module Codec.Binary.Gray.List + ( gray, binary + , toList, fromList + , showBits + ) where + +import Data.Bits (Bits, testBit, bitSize, shiftR, isSigned) + +boolXOR :: Bool -> Bool -> Bool +boolXOR p q = (p && not q) || (not p && q) + +-- | Take a list of bits (most significant last) in binary encoding +-- and convert them to Gray code. +gray :: [Bool] -> [Bool] +gray (b:c:bs) = b `boolXOR` c : gray (c:bs) +gray [b] = [b] +gray [] = [] + +-- | Take a list of bits in Gray code and convert them to binary encoding +-- (most significant bit last). +binary :: [Bool] -> [Bool] +binary = foldr go [] + where go c [] = [c] + go c bs@(b:_) = b `boolXOR` c : bs + +-- | Convert a number to a list of bits in usual binary encoding (most +-- significant last). +-- +-- This function is undefined for negative numbers of types that do not +-- have fixed bitsize, like 'Integer'. +toList :: (Bits b) => b -> [Bool] +toList 0 = [] +toList i + | isSigned i && signum i == (-1) = + let b = map not . toList $ negate i - 1 + in b ++ (take (bitSize i - length b) $ repeat True) -- pad major bits + | otherwise = + let rest = toList $ shiftR i 1 -- works only for positive i + in (testBit i 0 : rest) + +-- | Convert a list of bits in binary encoding to a number. +fromList :: (Bits b) => [Bool] -> b +fromList = sum . map fst . filter snd . zip (map (2^) [0..]) + +-- | Render a list of bits as a string of @0@s and @1@s. +showBits :: [Bool] -> String +showBits [] = "0" +showBits bs = map (\b -> if b then '1' else '0') . reverse $ bs diff --git a/Codec/Binary/Gray_props.hs b/Codec/Binary/Gray_props.hs --- a/Codec/Binary/Gray_props.hs +++ b/Codec/Binary/Gray_props.hs @@ -2,46 +2,52 @@ module Codec.Binary.Gray_props where import Test.QuickCheck -import Codec.Binary.Gray +import qualified Codec.Binary.Gray.Bits as B +import qualified Codec.Binary.Gray.List as L import Data.Bits (testBit, bitSize, Bits) +import Data.Function (on) -prop_num2bin2num_id_Int = - label "binaryToBits . bitsToBinary == id [Int]" $ +--- +--- Properties of list-based functions +--- + +prop_lists_num2bin_id_Int = + label "fromList . toList == id [Int]" $ forAll (arbitrary :: Gen Int) $ \i -> - i == (binaryToBits . bitsToBinary $ i) + i == (L.fromList . L.toList $ i) -prop_num2bin2num_id_Integer = - label "binaryToBits . bitsToBinary == id [Integer+]" $ - let i = (arbitrary :: Gen Integer) `suchThat` (>= 0) - in forAll i (\i -> i == (binaryToBits . bitsToBinary $ i)) +prop_lists_num2bin_id_Integer = + label "fromList . toList == id [Integer+]" $ + let i = (arbitrary :: Gen (NonNegative Integer)) + in forAll i (\(NonNegative i) -> i == (L.fromList . L.toList $ i)) -prop_correct_bits_Int = - label "bitsToBinary is correct [Int]" $ +prop_lists_correct_bits_Int = + label "toList is correct [Int]" $ forAll (arbitrary :: Gen Int) $ \i -> let bts = map (testBit i) [0..(bitSize i)-1] - padded = (bitsToBinary i) ++ (repeat False) + padded = (L.toList i) ++ (repeat False) in all id $ zipWith (==) bts padded -prop_bin2gray2bin_id = - label "grayToBinary . binaryToGray == binaryToGray . grayToBinary == id" $ +prop_lists_bin2gray_id = + label "binary . gray == gray . binary == id" $ forAll (listOf $ (arbitrary :: Gen Bool)) $ \bs -> - bs == (grayToBinary . binaryToGray $ bs) && - bs == (binaryToGray . grayToBinary $ bs) + bs == (L.binary . L.gray $ bs) && + bs == (L.gray . L.binary $ bs) -prop_gray_succ_Integer = - label "Two successive numbers differ in only one bit [Integer+]" $ - let i = (arbitrary :: Gen Integer) `suchThat` (>= 0) - in forAll i succ_test +prop_lists_gray_succ_Integer = + label "hamming x (x+1) == 1 [Integer+]" $ + let i = (arbitrary :: Gen (NonNegative Integer)) + in forAll i $ \(NonNegative i) -> succ_test i -prop_gray_succ_Int = - label "Two successive numbers differ in only one bit [Int]" $ +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 + let n2g = L.gray . L.toList g1 = n2g i g2 = n2g (i+1) in hamming g1 g2 == 1 @@ -57,10 +63,46 @@ 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 -> + (B.binary . B.gray $ i) == i && (B.gray . B.binary $ i) == i + +prop_bits_same_as_lists = + label "bitsToBinary . gray == binaryToGray . bitsToBinary [Int]" $ + forAll (arbitrary :: Gen Int) $ \i -> + (L.gray . L.toList $ i) == (L.toList . B.gray $ i) + +prop_bits_gray_succ_Int = label "hamming x (x+1) == 1 [Int]" $ + forAll (arbitrary :: Gen Int) $ \i -> + (hammingBits `on` B.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` B.gray) i (i+1) == 1 + +hammingBits :: (Bits a) => a -> a -> Int +hammingBits = hamming `on` L.toList + +--- +--- 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_num2bin2num_id_Int .&. - prop_num2bin2num_id_Integer .&. - prop_correct_bits_Int .&. - prop_bin2gray2bin_id .&. - prop_gray_succ_Int .&. - prop_gray_succ_Integer + prop_lists .&. prop_bits diff --git a/gray-code.cabal b/gray-code.cabal --- a/gray-code.cabal +++ b/gray-code.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1 +Version: 0.2 -- A short (one-line) description of the package. Synopsis: Gray code encoder/decoder. @@ -15,8 +15,12 @@ -- A longer description of the package. Description: Gray code is a binary numeral system where two successive numbers - differ in only one bit. This package allows to convert Haskell - numbers to one of the possible Gray codes and back. + differ in only one bit. + . + This package allows to convert numbers to one of the possible Gray + codes and back. Two binary representations of a number are supported: + @[Bool]@ and types of @Bits@ type class. + @Bits@ is the default implementation. -- URL for the project homepage or repository. Homepage: http://bitbucket.org/jetxee/hs-gray-code @@ -57,6 +61,8 @@ -- Modules exported by the library. Exposed-modules: Codec.Binary.Gray + , Codec.Binary.Gray.Bits + , Codec.Binary.Gray.List -- Packages needed in order to build this package. Build-depends: