Source

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

Full commit
-- | Gray code is a binary numeral system where two successive numbers
-- differ in only one bit.
--
-- Algorithm:
--   Haupt, R.L. and Haupt, S.E., Practical Genetic Algorithms,
--   Second ed. (2004),  5.4. Gray Codes.
module Codec.Binary.Gray
    (
      -- * Bitwise functions (for @Bits@ types)
      gray, binary
      -- * List functions (for @[Bool]@)
    , binaryToGray, grayToBinary
    , bitsToBinary, binaryToBits
      -- * Pretty printing
    , showBits, showBinary
    ) where

import Data.Bits
    ( Bits, testBit, setBit, clearBit, bitSize
    , shiftL, shiftR, complement, xor, (.&.), (.|.), isSigned)
import Debug.Trace
    
-- | 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.
-- 
-- As 'bitSize', 'gray' is undefined for negative numbers that do not
-- have fixed bitsize, like 'Integer'.
gray :: (Bits a) => a -> a
gray n = n `xor` (shiftR' n 1)

-- | Convert an integer number from Gray code to binary.
-- 
-- As 'bitSize', 'binary' is undefined for types that do not
-- have fixed bitsize, like '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)

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.
binaryToGray :: [Bool] -> [Bool]
binaryToGray (b:c:bs) = b `boolXOR` c : binaryToGray (c:bs)
binaryToGray [b] = [b]
binaryToGray [] = []

-- | Take a list of bits in Gray code and convert them to binary encoding
-- (most significant bit last).
grayToBinary :: [Bool] -> [Bool]
grayToBinary = 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).
-- 
-- As 'bitSize', 'bitsToBinary' is undefined for negative numbers 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 b) => [Bool] -> b
binaryToBits = sum . map fst . filter snd . zip (map (2^) [0..])

-- | 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

-- | Render a 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 = showBinary . bitsToBinary