{-# LANGUAGE BangPatterns, InstanceSigs #-}
-- | The optimal (shortest) binary code of a value in a domain of
-- uniform probability is simply the binary expansion of the index of
-- the value in that space. The optimal code of two such values is the
-- index of the pair in the cartesian product of both domains, and so on
-- for any number of values. This package defines a type `Value` with a
-- `Monoid` instance that performs this sort of composition. The only
-- difference with typical [arithmetic
-- coding](https://en.wikipedia.org/wiki/Arithmetic_coding) on a
-- rational number code is that for each operation, we operate on the
-- whole code with infinite precision. For an codec with finite
-- precision, see the
-- [Variety.Bounded](https://hackage-content.haskell.org/package/variety/docs/Codec-Arithmetic-Variety-Bounded.html)
-- module.
module Codec.Arithmetic.Variety
  ( -- * Value-base Interface

    encode
  , codeLen
  , decode
  , encode1
  , codeLen1
  , decode1

  -- * Value Type

  , Value(..)
  , mkValue
  , toBitVec
  , compose
  , maxValue
  ) where

import Codec.Arithmetic.Variety.BitVec (BitVec, bitVec)
import qualified Codec.Arithmetic.Variety.BitVec as BV

err :: String -> a
err :: forall a. String -> a
err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Variety." String -> String -> String
forall a. [a] -> [a] -> [a]
++)

-- | Encode a series of value-base pairs into a single bit vector. A
-- base must be at least equal to @1@ and the associated value must
-- exist in the range @[0..base-1]@.
encode :: [(Integer,Integer)] -> BitVec
encode :: [(Integer, Integer)] -> BitVec
encode = Value -> BitVec
toBitVec (Value -> BitVec)
-> ([(Integer, Integer)] -> Value)
-> [(Integer, Integer)]
-> BitVec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat ([Value] -> Value)
-> ([(Integer, Integer)] -> [Value])
-> [(Integer, Integer)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, Integer) -> Value) -> [(Integer, Integer)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Integer -> Integer -> Value) -> (Integer, Integer) -> Value
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Integer -> Integer -> Value
mkValue)

-- | Return the length of the code of a sequence of values in the given
-- list of bases in bits.
codeLen :: [Integer] -> Int
codeLen :: [Integer] -> Int
codeLen = Integer -> Int
codeLen1 (Integer -> Int) -> ([Integer] -> Integer) -> [Integer] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product

-- | Decode a bit vector given the same series of bases that was used to
-- encode it. Throws an error if the given vector's size doesn't match
-- the given bases.
decode :: [Integer] -> BitVec -> [Integer]
decode :: [Integer] -> BitVec -> [Integer]
decode [Integer]
bases BitVec
bv = case [Integer] -> [Integer]
forall a. HasCallStack => [a] -> [a]
init ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer -> Integer)
-> Integer -> [Integer] -> [Integer]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) Integer
1 [Integer]
bases of -- last is 1
  [] -> []
  (Integer
base:[Integer]
ns) -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
len Int
expectedLen of -- base == product bases
    Ordering
EQ -> Integer -> [Integer] -> [Integer]
forall {t}. Integral t => t -> [t] -> [t]
go (BitVec -> Integer
BV.toInteger BitVec
bv) [Integer]
ns
    Ordering
LT -> String -> [Integer]
forall a. String -> a
err String
"decode: not enough bits"
    Ordering
GT -> String -> [Integer]
forall a. String -> a
err String
"decode: too many bits"
    where
      len :: Int
len = BitVec -> Int
BV.length BitVec
bv
      expectedLen :: Int
expectedLen = Integer -> Int
codeLen1 Integer
base
  where
    go :: t -> [t] -> [t]
go t
i [] = [t
i]
    go t
i2 (t
n1:[t]
ns) = t
i0 t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
go t
i1 [t]
ns
      where (t
i0,t
i1) = t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
quotRem t
i2 t
n1

-- | Consider a positive integer as a bit vector, given its base. The
-- base is only required to determine the number of leading 0s.
encode1 :: Integer -> Integer -> BitVec
encode1 :: Integer -> Integer -> BitVec
encode1 = Value -> BitVec
toBitVec (Value -> BitVec)
-> (Integer -> Integer -> Value) -> Integer -> Integer -> BitVec
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Integer -> Integer -> Value
mkValue

-- | Return the length of the code of a single value in the given base
-- in bits.
codeLen1 :: Integer -> Int
codeLen1 :: Integer -> Int
codeLen1 Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
1 = String -> Int
forall a. String -> a
err String
"codeLen: base must be positive and non-zero"
           | Bool
otherwise = Integer -> Int
BV.bitLen (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

-- | Recover the value from a bit vector.
decode1 :: BitVec -> Integer
decode1 :: BitVec -> Integer
decode1 = BitVec -> Integer
BV.toInteger

----------------
-- VALUE TYPE --
----------------

-- | A value with its base, or the number of possible values that could
-- be (i.e. radix, or
-- [variety](https://en.wikipedia.org/wiki/Variety_(cybernetics\))). The
-- value is like an index and ranges from [0..base-1] while the base is
-- a cardinality is always positive and non-zero.
newtype Value = Value {
  -- | Recover the value and the base as @Integer@s
  Value -> (Integer, Integer)
fromValue :: (Integer, Integer)
} deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq,Int -> Value -> String -> String
[Value] -> String -> String
Value -> String
(Int -> Value -> String -> String)
-> (Value -> String) -> ([Value] -> String -> String) -> Show Value
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Value -> String -> String
showsPrec :: Int -> Value -> String -> String
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> String -> String
showList :: [Value] -> String -> String
Show,ReadPrec [Value]
ReadPrec Value
Int -> ReadS Value
ReadS [Value]
(Int -> ReadS Value)
-> ReadS [Value]
-> ReadPrec Value
-> ReadPrec [Value]
-> Read Value
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Value
readsPrec :: Int -> ReadS Value
$creadList :: ReadS [Value]
readList :: ReadS [Value]
$creadPrec :: ReadPrec Value
readPrec :: ReadPrec Value
$creadListPrec :: ReadPrec [Value]
readListPrec :: ReadPrec [Value]
Read)

-- | Construct from a value and a base. Throws an error if either is
-- negative or if the value is not strictly less than the base.
mkValue :: Integer -> Integer -> Value
mkValue :: Integer -> Integer -> Value
mkValue Integer
i Integer
n | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n = (Integer, Integer) -> Value
Value (Integer
i,Integer
n)
            | Bool
otherwise = String -> Value
forall a. String -> a
err (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"mkValue: out of bounds: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Integer, Integer) -> String
forall a. Show a => a -> String
show (Integer
i,Integer
n)

instance Semigroup Value where
  (<>) :: Value -> Value -> Value
  <> :: Value -> Value -> Value
(<>) = Value -> Value -> Value
compose

instance Monoid Value where
  mempty :: Value
  mempty :: Value
mempty = (Integer, Integer) -> Value
Value (Integer
0,Integer
1)

-- | Compose two values into a value of a greater base. This is
-- associative, but not commutative.
compose :: Value -> Value -> Value
compose :: Value -> Value -> Value
compose (Value (Integer
i0,Integer
n0)) (Value (Integer
i1,Integer
n1)) = (Integer, Integer) -> Value
Value (Integer
i2, Integer
n2)
  where
    !i2 :: Integer
i2 = Integer
i0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
i1
    !n2 :: Integer
n2 = Integer
n0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n1

-- | Maximal possible value as an @Integer@ in the given base.
maxValue :: Value -> Integer
maxValue :: Value -> Integer
maxValue = (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+(-Integer
1)) (Integer -> Integer) -> (Value -> Integer) -> Value -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Integer) -> Integer
forall a b. (a, b) -> b
snd ((Integer, Integer) -> Integer)
-> (Value -> (Integer, Integer)) -> Value -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> (Integer, Integer)
fromValue

-- | Drop the base and consider the value as a bit vector. The base
-- conceptually rounds to the next power of 2.
toBitVec :: Value -> BitVec
toBitVec :: Value -> BitVec
toBitVec (Value (Integer
i,Integer
n)) = Int -> Integer -> BitVec
bitVec (Integer -> Int
codeLen1 Integer
n) Integer
i

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
.: :: forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = ((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d)
-> ((c -> d) -> (b -> c) -> b -> d)
-> (c -> d)
-> (a -> b -> c)
-> a
-> b
-> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
infixr 8 .:
{-# INLINE (.:) #-}