-- | 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, finiteBitSize, bitSizeMaybe
    , 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).
--
-- Results on negative values of unbounded integral types (like 'Integer') may be wrong.
shiftR' :: (Bits a, Num a) => a -> Int -> a
shiftR' :: a -> Int -> a
shiftR' a
n Int
s =
  case (a -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe a
n, a -> a
forall a. Num a => a -> a
signum a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (-a
1)) of
    (Just Int
sz, Bool
True) ->
        let n' :: a
n' = a -> Int -> a
forall a. Bits a => a -> Int -> a
clearBit (a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
n Int
1) (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        in  a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
shiftR' a
n' (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    (Maybe Int
_, Bool
_) ->
        a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
n Int
s


-- | Convert an integer number from binary to Gray code.
--
-- Results on negative values of unbounded integral types (like 'Integer') may be wrong.
gray :: (Bits a, Num a) => a -> a
gray :: a -> a
gray a
n = a
n a -> a -> a
forall a. Bits a => a -> a -> a
`xor` (a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
shiftR' a
n Int
1)

-- | Convert an integer number from Gray code to binary.
--
-- Results on negative values of unbounded integral types (like 'Integer') may be wrong.
binary :: (Bits a, Num a) => a -> a
binary :: a -> a
binary a
0 = a
0
binary a
n =
    case Maybe Int
maybeSz of
      (Just Int
sz) ->
          let lastbit :: Int
lastbit = Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              mask0 :: (a, a)
mask0 = let m :: a
m = a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit a
0 Int
lastbit in (a
m, a
m)
              copyMSB :: a -> a
copyMSB a
n = (a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit a
0 Int
lastbit) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
n
          in  Int -> (a, a) -> a -> a -> a
forall t. (Bits t, Num t) => Int -> (t, t) -> t -> t -> t
binary' Int
lastbit (a, a)
mask0 a
n (a -> a
forall a. (Bits a, Num a) => a -> a
copyMSB a
n)
      Maybe Int
Nothing ->  -- unbounded and negative
          a
0
  where
    maybeSz :: Maybe Int
maybeSz = case a -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe a
n of
                (Just Int
bsz) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
bsz
                Maybe Int
Nothing -> a -> Maybe Int
forall a. (Bits a, Num a) => a -> Maybe Int
effectiveBitSize a
n


effectiveBitSize :: (Bits a, Num a) => a -> Maybe Int
effectiveBitSize :: a -> Maybe Int
effectiveBitSize a
n
    | a -> a
forall a. Num a => a -> a
signum a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (-a
1) = a -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe a
n
    | Bool
otherwise        = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ a -> Int -> Int
forall t t. (Bits t, Num t, Num t) => t -> t -> t
ebs a
n Int
0
  where
    ebs :: t -> t -> t
ebs t
n t
bsz
        | t -> t
forall a. Num a => a -> a
signum t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
1 = t
bsz
        | Bool
otherwise     = t -> t -> t
ebs (t
n t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) (t
bsz t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)


binary' :: Int -> (t, t) -> t -> t -> t
binary' Int
lastbit (t
maskReady, t
maskLast) t
ngray t
nbin
  | (t
maskReady t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
1) t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
0 = t
nbin
  | Bool
otherwise =
     let
       nReady :: t
nReady = t
maskReady t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
nbin
       maskReady' :: t
maskReady' = t -> Int -> t
forall a. Bits a => a -> Int -> a
setBit (t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftR t
maskReady Int
1) Int
lastbit
       maskLast' :: t
maskLast' = t -> Int -> t
forall a. (Bits a, Num a) => a -> Int -> a
shiftR' t
maskLast Int
1
       nNext :: t
nNext = (t -> Int -> t
forall a. (Bits a, Num a) => a -> Int -> a
shiftR' (t
maskLast t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
nReady) Int
1) t -> t -> t
forall a. Bits a => a -> a -> a
`xor` (t
maskLast' t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
ngray)
     in
       Int -> (t, t) -> t -> t -> t
binary' Int
lastbit (t
maskReady', t
maskLast') t
ngray (t
nReady t -> t -> t
forall a. Bits a => a -> a -> a
.|. t
nNext)

-- | Render binary code as a string of @0@s and @1@s.
-- For example, @(42::Int8)@ is formatted as @101010@.
showBits :: (Bits a, Num a) => a -> String
showBits :: a -> String
showBits = [Bool] -> String
L.showBits ([Bool] -> String) -> (a -> [Bool]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Bool]
forall b. (Bits b, Num b) => b -> [Bool]
L.toList