-- | 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, toList', fromList
    , showBits
    ) where

import Data.Bits (FiniteBits, Bits, testBit, finiteBitSize, bitSizeMaybe, shiftR, isSigned)

boolXOR :: Bool -> Bool -> Bool
boolXOR :: Bool -> Bool -> Bool
boolXOR Bool
p Bool
q = (Bool
p Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
q) Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
p Bool -> Bool -> Bool
&& Bool
q)

-- | Take a list of bits (most significant last) in binary encoding
-- and convert them to Gray code.
gray :: [Bool] -> [Bool]
gray :: [Bool] -> [Bool]
gray (Bool
b:Bool
c:[Bool]
bs) = Bool
b Bool -> Bool -> Bool
`boolXOR` Bool
c Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool] -> [Bool]
gray (Bool
cBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:[Bool]
bs)
gray [Bool
b] = [Bool
b]
gray [] = []

-- | Take a list of bits in Gray code and convert them to binary encoding
-- (most significant bit last).
binary :: [Bool] -> [Bool]
binary :: [Bool] -> [Bool]
binary = (Bool -> [Bool] -> [Bool]) -> [Bool] -> [Bool] -> [Bool]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Bool -> [Bool] -> [Bool]
go []
  where go :: Bool -> [Bool] -> [Bool]
go Bool
c [] = [Bool
c]
        go Bool
c bs :: [Bool]
bs@(Bool
b:[Bool]
_) = Bool
b Bool -> Bool -> Bool
`boolXOR` Bool
c Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
bs

-- | Convert a number to a list of bits in usual binary encoding (most
-- significant bit last). Truncates unset major bits.
--
-- The function may be also applied to unbounded integral types (like
-- 'Integer'): it will return a list of bits for positive values, and
-- an empty list for negative values or zero.
toList :: (Bits b, Num b) => b -> [Bool]
toList :: b -> [Bool]
toList b
0 = []
toList b
i =
  let mbSize :: Maybe Int
mbSize = b -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe b
i
      isNegative :: Bool
isNegative = b -> Bool
forall a. Bits a => a -> Bool
isSigned b
i Bool -> Bool -> Bool
&& b -> b
forall a. Num a => a -> a
signum b
i b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== (-b
1)
  in  case (Maybe Int
mbSize, Bool
isNegative) of
        (Just Int
_, Bool
False) -> b -> [Bool]
forall b. (Bits b, Num b) => b -> [Bool]
positiveToList b
i
        (Just Int
size, Bool
True) -> Int -> b -> [Bool]
forall b. (Bits b, Num b) => Int -> b -> [Bool]
negativeToList Int
size b
i
        (Maybe Int
Nothing, Bool
False) -> b -> [Bool]
forall b. (Bits b, Num b) => b -> [Bool]
positiveToList b
i
        (Maybe Int
Nothing, Bool
True) -> []
  where
    positiveToList :: b -> [Bool]
positiveToList b
i =
      let rest :: [Bool]
rest = b -> [Bool]
forall b. (Bits b, Num b) => b -> [Bool]
toList (b -> [Bool]) -> b -> [Bool]
forall a b. (a -> b) -> a -> b
$ b -> Int -> b
forall a. Bits a => a -> Int -> a
shiftR b
i Int
1  -- works only for positive i
      in  (b -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit b
i Int
0 Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
rest)
    negativeToList :: Int -> b -> [Bool]
negativeToList Int
bsize b
i =
        let b :: [Bool]
b = (Bool -> Bool) -> [Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Bool -> Bool
not ([Bool] -> [Bool]) -> (b -> [Bool]) -> b -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [Bool]
forall b. (Bits b, Num b) => b -> [Bool]
toList (b -> [Bool]) -> b -> [Bool]
forall a b. (a -> b) -> a -> b
$ b -> b
forall a. Num a => a -> a
negate b
i b -> b -> b
forall a. Num a => a -> a -> a
- b
1
        in  [Bool]
b [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ (Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take (Int
bsize Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
b) ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True)
        --    ^^^ pad major bits

-- | Convert a number to a list of bits in usual binary encoding (most
-- significant bit last).
--
-- Like 'toList', but returns all unset major bits too. So the length
-- of the output is always the same length as @finiteBitSize i@.
toList' :: (FiniteBits b, Num b) => b -> [Bool]
toList' :: b -> [Bool]
toList' b
i = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (b -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit b
i) [Int
0..b -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize b
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- | Convert a list of bits in binary encoding to a number.
fromList :: (Bits b, Num b) => [Bool] -> b
fromList :: [Bool] -> b
fromList = [b] -> b
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([b] -> b) -> ([Bool] -> [b]) -> [Bool] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, Bool) -> b) -> [(b, Bool)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Bool) -> b
forall a b. (a, b) -> a
fst ([(b, Bool)] -> [b]) -> ([Bool] -> [(b, Bool)]) -> [Bool] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, Bool) -> Bool) -> [(b, Bool)] -> [(b, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (b, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(b, Bool)] -> [(b, Bool)])
-> ([Bool] -> [(b, Bool)]) -> [Bool] -> [(b, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> [Bool] -> [(b, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Integer -> b) -> [Integer] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b
2b -> Integer -> b
forall a b. (Num a, Integral b) => a -> b -> a
^) [Integer
0..])

-- | Render a list of bits as a string of @0@s and @1@s.
showBits :: [Bool] -> String
showBits :: [Bool] -> String
showBits [] = String
"0"
showBits [Bool]
bs = (Bool -> Char) -> [Bool] -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> if Bool
b then Char
'1' else Char
'0') ([Bool] -> String) -> ([Bool] -> [Bool]) -> [Bool] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [Bool]
forall a. [a] -> [a]
reverse ([Bool] -> String) -> [Bool] -> String
forall a b. (a -> b) -> a -> b
$ [Bool]
bs