------------------------------------------------------------------------
-- |
-- Module      :  Codec.Gray
-- Copyright   :  (c) 2011-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- Gray encoding schemes. A Gray code is a list of values such that two
-- successive values differ in only one digit. Usually the term /Gray
-- code/ refers to the Binary Reflected Gray code (BRGC), but non-binary
-- Gray codes have also been discovered. Some Gray codes are also
-- /cyclic/: the last and first values differ in only one digit.
--
------------------------------------------------------------------------
module Codec.Gray 
  (
    grayCodes,
    integralToGray,
    grayToIntegral,
    naryGrayCodes
  ) where

import Data.List (foldl')
import Data.Bits (Bits, shiftR, xor)

{-# INLINABLE grayCodes #-}
-- | @'grayCodes' k@ generates the list of Binary Reflected Gray Code
--   (BRGC) numbers of length k. This code is cyclic.
grayCodes :: Int -> [[Bool]]
grayCodes :: Int -> [[Bool]]
grayCodes Int
0 = [[]]
grayCodes Int
k = 
  let xs :: [[Bool]]
xs = Int -> [[Bool]]
grayCodes (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) in ([Bool] -> [Bool]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
FalseBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:) [[Bool]]
xs [[Bool]] -> [[Bool]] -> [[Bool]]
forall a. [a] -> [a] -> [a]
++ ([Bool] -> [Bool]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
TrueBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:) ([[Bool]] -> [[Bool]]
forall a. [a] -> [a]
reverse [[Bool]]
xs)

{-# INLINABLE integralToGray #-}
-- | @'integralToGray' n@ encodes @n@ using a BRGC, and returns the
--   resulting bits as an integer. For example, encoding @17@ in BRGC
--   results in @11001@, or 25. So @integralToGray 17@ returns @25@.
integralToGray :: Bits a => a -> a
integralToGray :: a -> a
integralToGray a
n = (a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a
n

{-# INLINABLE grayToIntegral #-}
-- | @'grayToIntegral' n@ decodes @n@ using a BRGC, and returns the
--   resulting integer. For example, 25 is @11001@, which is the code
--   for 17. So @grayToIntegral 25@ returns @17@.
grayToIntegral :: (Num a, Bits a) => a -> a
grayToIntegral :: a -> a
grayToIntegral a
n = a -> a -> a
forall p. (Num p, Bits p) => p -> p -> p
f a
n (a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
  where f :: p -> p -> p
f p
k p
m | p
m p -> p -> Bool
forall a. Eq a => a -> a -> Bool
/= p
0     = p -> p -> p
f (p
k p -> p -> p
forall a. Bits a => a -> a -> a
`xor` p
m) (p
m p -> Int -> p
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
              | Bool
otherwise = p
k
  
{-# INLINABLE naryGrayCodes #-}
-- | @'naryGrayCodes' xs k@ generates a non-Boolean (or n-ary) Gray code
--   of length @k@ using the elements of @xs@ as \"digits\". This code
--   is cyclic.
--
--   Ex: @'naryGrayCodes' \"012\" 4@ generates a ternary Gray code that
--   is four digits long.
naryGrayCodes :: [a] -> Int -> [[a]]
naryGrayCodes :: [a] -> Int -> [[a]]
naryGrayCodes [a]
xs Int
1 = (a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> [a
x]) [a]
xs
naryGrayCodes [a]
xs Int
k = ([[a]], [[a]]) -> [[a]]
forall a b. (a, b) -> b
snd (([[a]], [[a]]) -> [[a]]) -> ([[a]], [[a]]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([[a]], [[a]]) -> [a] -> ([[a]], [[a]]))
-> ([[a]], [[a]]) -> [[a]] -> ([[a]], [[a]])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([[a]], [[a]]) -> [a] -> ([[a]], [[a]])
forall a. ([[a]], [[a]]) -> [a] -> ([[a]], [[a]])
prefixAndShift ([[a]]
ys,[]) [[a]]
xs'
  where ys :: [[a]]
ys = [a] -> Int -> [[a]]
forall a. [a] -> Int -> [[a]]
naryGrayCodes [a]
xs Int
1
        xs' :: [[a]]
xs' = [a] -> Int -> [[a]]
forall a. [a] -> Int -> [[a]]
naryGrayCodes [a]
xs (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

-- | Shift elements right.
shift :: [a] -> [a]
shift :: [a] -> [a]
shift [a]
as = [a] -> a
forall a. [a] -> a
last [a]
as a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. [a] -> [a]
init [a]
as

prefixAndShift :: ([[a]],[[a]]) -> [a] -> ([[a]],[[a]])
prefixAndShift :: ([[a]], [[a]]) -> [a] -> ([[a]], [[a]])
prefixAndShift ([[a]]
ys,[[a]]
zs) [a]
xs = ([[a]] -> [[a]]
forall a. [a] -> [a]
shift [[a]]
ys, [[a]]
zs [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([a]
xs[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) [[a]]
ys))