{-
 - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>
 -
 - This program is free software: you can redistribute it and/or modify
 - it under the terms of the GNU General Public License as published by
 - the Free Software Foundation, either version 3 of the License, or
 - (at your option) any later version.
 -
 - This program is distributed in the hope that it will be useful,
 - but WITHOUT ANY WARRANTY; without even the implied warranty of
 - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 - GNU General Public License for more details.
 -
 - You should have received a copy of the GNU General Public License
 - along with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module:        Data.Finitary.PackBits
-- Description:   Scheme for bit-packing @Finitary@ types.
-- Copyright:     (C) Koz Ross 2019
-- License:       GPL version 3.0 or later
-- Maintainer:    koz.ross@retro-freedom.nz
-- Stability:     Experimental
-- Portability:   GHC only
--
-- From the [Kraft-McMillan
-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality),
-- the fact that we are not able to have \'fractional\' bits, we can derive a
-- fixed-length code into a bitstring for any 'Finitary' type @a@, with code
-- length \(\lceil \log_{2}(\texttt{Cardinality a}) \rceil\) bits. This code is
-- essentially a binary representation of the index of each inhabitant of @a@.
-- On that basis, we can derive an 'VU.Unbox' instance, representing
-- the entire 'VU.Vector' as an unboxed [bit
-- array](https://en.wikipedia.org/wiki/Bit_array).
--
-- This encoding is advantageous from the point of view of space - there is no
-- tighter possible packing that preserves \(\Theta(1)\) random access and also
-- allows the full range of 'VU.Vector' operations. If you are concerned about
-- space usage above all, this is the best choice for you. 
--
-- Because access to individual bits is slower than whole bytes or words, this
-- encoding adds some overhead. Additionally, a primary advantage of bit arrays
-- (the ability to perform \'bulk\' operations on bits efficiently) is not made
-- use of here. Therefore, if speed matters more than compactness, this encoding
-- is suboptimal.
--
-- This encoding is __thread-safe__, and thus slightly slower. If you are certain 
-- that race conditions cannot occur for your code, you can gain a speed improvement 
-- by using "Data.Finitary.PackBits.Unsafe" instead.
module Data.Finitary.PackBits 
(
  PackBits, pattern Packed
) where

import GHC.TypeLits.Extra
import Data.Proxy (Proxy(..))
import Numeric.Natural (Natural)
import GHC.TypeNats
import CoercibleUtils (op, over, over2)
import Data.Kind (Type)
import Data.Hashable (Hashable(..))
import Data.Vector.Instances ()
import Data.Vector.Binary ()
import Control.DeepSeq (NFData(..))
import Data.Finitary(Finitary(..))
import Data.Finite (Finite)
import Control.Monad.Trans.State.Strict (evalState, get, modify, put)

import qualified Data.Binary as Bin
import qualified Data.Bit.ThreadSafe as BT
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Unboxed as VU

-- | An opaque wrapper around @a@, representing each value as a 'bit-packed'
-- encoding.
newtype PackBits (a :: Type) = PackBits (VU.Vector BT.Bit)
  deriving (PackBits a -> PackBits a -> Bool
(PackBits a -> PackBits a -> Bool)
-> (PackBits a -> PackBits a -> Bool) -> Eq (PackBits a)
forall a. PackBits a -> PackBits a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackBits a -> PackBits a -> Bool
$c/= :: forall a. PackBits a -> PackBits a -> Bool
== :: PackBits a -> PackBits a -> Bool
$c== :: forall a. PackBits a -> PackBits a -> Bool
Eq, Eq (PackBits a)
Eq (PackBits a) =>
(PackBits a -> PackBits a -> Ordering)
-> (PackBits a -> PackBits a -> Bool)
-> (PackBits a -> PackBits a -> Bool)
-> (PackBits a -> PackBits a -> Bool)
-> (PackBits a -> PackBits a -> Bool)
-> (PackBits a -> PackBits a -> PackBits a)
-> (PackBits a -> PackBits a -> PackBits a)
-> Ord (PackBits a)
PackBits a -> PackBits a -> Bool
PackBits a -> PackBits a -> Ordering
PackBits a -> PackBits a -> PackBits a
forall a. Eq (PackBits a)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. PackBits a -> PackBits a -> Bool
forall a. PackBits a -> PackBits a -> Ordering
forall a. PackBits a -> PackBits a -> PackBits a
min :: PackBits a -> PackBits a -> PackBits a
$cmin :: forall a. PackBits a -> PackBits a -> PackBits a
max :: PackBits a -> PackBits a -> PackBits a
$cmax :: forall a. PackBits a -> PackBits a -> PackBits a
>= :: PackBits a -> PackBits a -> Bool
$c>= :: forall a. PackBits a -> PackBits a -> Bool
> :: PackBits a -> PackBits a -> Bool
$c> :: forall a. PackBits a -> PackBits a -> Bool
<= :: PackBits a -> PackBits a -> Bool
$c<= :: forall a. PackBits a -> PackBits a -> Bool
< :: PackBits a -> PackBits a -> Bool
$c< :: forall a. PackBits a -> PackBits a -> Bool
compare :: PackBits a -> PackBits a -> Ordering
$ccompare :: forall a. PackBits a -> PackBits a -> Ordering
$cp1Ord :: forall a. Eq (PackBits a)
Ord)

type role PackBits nominal

-- | To provide (something that resembles a) data constructor for 'PackBits', we
-- provide the following pattern. It can be used like any other data
-- constructor:
--
-- > import Data.Finitary.PackBits
-- >
-- > anInt :: PackBits Int
-- > anInt = Packed 10
-- >
-- > isPackedEven :: PackBits Int -> Bool
-- > isPackedEven (Packed x) = even x
--
-- __Every__ pattern match, and data constructor call, performs a
-- \(\Theta(\log_{2}(\texttt{Cardinality a}))\) encoding or decoding operation. 
-- Use with this in mind.
pattern Packed :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  PackBits a -> a
pattern $bPacked :: PackBits a -> a
$mPacked :: forall r a.
(Finitary a, 1 <= Cardinality a) =>
a -> (PackBits a -> r) -> (Void# -> r) -> r
Packed x <- (packBits -> x)
  where Packed x :: PackBits a
x = PackBits a -> a
forall a. (Finitary a, 1 <= Cardinality a) => PackBits a -> a
unpackBits PackBits a
x

instance Bin.Binary (PackBits a) where
  {-# INLINE put #-}
  put :: PackBits a -> Put
put = Vector Word -> Put
forall t. Binary t => t -> Put
Bin.put (Vector Word -> Put)
-> (PackBits a -> Vector Word) -> PackBits a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Bit -> Vector Word
BT.cloneToWords (Vector Bit -> Vector Word)
-> (PackBits a -> Vector Bit) -> PackBits a -> Vector Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Bit -> PackBits a) -> PackBits a -> Vector Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits
  {-# INLINE get #-}
  get :: Get (PackBits a)
get = Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits (Vector Bit -> PackBits a)
-> (Vector Word -> Vector Bit) -> Vector Word -> PackBits a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word -> Vector Bit
BT.castFromWords (Vector Word -> PackBits a)
-> Get (Vector Word) -> Get (PackBits a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Vector Word)
forall t. Binary t => Get t
Bin.get

instance Hashable (PackBits a) where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> PackBits a -> Int
hashWithSalt salt :: Int
salt = Int -> Vector Word -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Vector Word -> Int)
-> (PackBits a -> Vector Word) -> PackBits a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Bit -> Vector Word
BT.cloneToWords (Vector Bit -> Vector Word)
-> (PackBits a -> Vector Bit) -> PackBits a -> Vector Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Bit -> PackBits a) -> PackBits a -> Vector Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits

instance NFData (PackBits a) where
  {-# INLINE rnf #-}
  rnf :: PackBits a -> ()
rnf = Vector Bit -> ()
forall a. NFData a => a -> ()
rnf (Vector Bit -> ())
-> (PackBits a -> Vector Bit) -> PackBits a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Bit -> PackBits a) -> PackBits a -> Vector Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits

instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBits a) where
  type Cardinality (PackBits a) = Cardinality a
  {-# INLINE fromFinite #-}
  fromFinite :: Finite (Cardinality (PackBits a)) -> PackBits a
fromFinite = Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits (Vector Bit -> PackBits a)
-> (Finite (Cardinality a) -> Vector Bit)
-> Finite (Cardinality a)
-> PackBits a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite (Cardinality a) -> Vector Bit
forall (n :: Nat). (KnownNat n, 1 <= n) => Finite n -> Vector Bit
intoBits
  {-# INLINE toFinite #-}
  toFinite :: PackBits a -> Finite (Cardinality (PackBits a))
toFinite = Vector Bit -> Finite (Cardinality a)
forall (n :: Nat). KnownNat n => Vector Bit -> Finite n
outOfBits (Vector Bit -> Finite (Cardinality a))
-> (PackBits a -> Vector Bit)
-> PackBits a
-> Finite (Cardinality a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Bit -> PackBits a) -> PackBits a -> Vector Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits

instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBits a) where
  {-# INLINE minBound #-}
  minBound :: PackBits a
minBound = PackBits a
forall a. (Finitary a, 1 <= Cardinality a) => a
start
  {-# INLINE maxBound #-}
  maxBound :: PackBits a
maxBound = PackBits a
forall a. (Finitary a, 1 <= Cardinality a) => a
end

newtype instance VU.MVector s (PackBits a) = MV_PackBits (VU.MVector s BT.Bit)

instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (PackBits a) where
  {-# INLINE basicLength #-}
  basicLength :: MVector s (PackBits a) -> Int
basicLength = (MVector s Bit -> MVector s (PackBits a))
-> (MVector s Bit -> Int) -> MVector s (PackBits a) -> Int
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over MVector s Bit -> MVector s (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (Int -> Int) -> (MVector s Bit -> Int) -> MVector s Bit -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Bit -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
VGM.basicLength)
  {-# INLINE basicOverlaps #-}
  basicOverlaps :: MVector s (PackBits a) -> MVector s (PackBits a) -> Bool
basicOverlaps = (MVector s Bit -> MVector s (PackBits a))
-> (MVector s Bit -> MVector s Bit -> Bool)
-> MVector s (PackBits a)
-> MVector s (PackBits a)
-> Bool
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a -> a') -> b -> b -> b'
over2 MVector s Bit -> MVector s (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits MVector s Bit -> MVector s Bit -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
VGM.basicOverlaps
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> MVector s (PackBits a) -> MVector s (PackBits a)
basicUnsafeSlice i :: Int
i len :: Int
len = (MVector s Bit -> MVector s (PackBits a))
-> (MVector s Bit -> MVector s Bit)
-> MVector s (PackBits a)
-> MVector s (PackBits a)
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over MVector s Bit -> MVector s (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits (Int -> Int -> MVector s Bit -> MVector s Bit
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.basicUnsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a))
  {-# INLINE basicUnsafeNew #-}
  basicUnsafeNew :: Int -> m (MVector (PrimState m) (PackBits a))
basicUnsafeNew len :: Int
len = (MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a))
-> m (MVector (PrimState m) Bit)
-> m (MVector (PrimState m) (PackBits a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits (Int -> m (MVector (PrimState m) Bit)
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> m (v (PrimState m) a)
VGM.basicUnsafeNew (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a))
  {-# INLINE basicInitialize #-}
  basicInitialize :: MVector (PrimState m) (PackBits a) -> m ()
basicInitialize = MVector (PrimState m) Bit -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
VGM.basicInitialize (MVector (PrimState m) Bit -> m ())
-> (MVector (PrimState m) (PackBits a)
    -> MVector (PrimState m) Bit)
-> MVector (PrimState m) (PackBits a)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a))
-> MVector (PrimState m) (PackBits a) -> MVector (PrimState m) Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeRead :: MVector (PrimState m) (PackBits a) -> Int -> m (PackBits a)
basicUnsafeRead (MV_PackBits v) i :: Int
i = (Vector Bit -> PackBits a) -> m (Vector Bit) -> m (PackBits a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits (m (Vector Bit) -> m (PackBits a))
-> (MVector (PrimState m) Bit -> m (Vector Bit))
-> MVector (PrimState m) Bit
-> m (PackBits a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState m) Bit -> m (Vector Bit)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
VG.freeze (MVector (PrimState m) Bit -> m (Vector Bit))
-> (MVector (PrimState m) Bit -> MVector (PrimState m) Bit)
-> MVector (PrimState m) Bit
-> m (Vector Bit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int -> MVector (PrimState m) Bit -> MVector (PrimState m) Bit
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.unsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (MVector (PrimState m) Bit -> m (PackBits a))
-> MVector (PrimState m) Bit -> m (PackBits a)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState m) Bit
v
  {-# INLINE basicUnsafeWrite #-}
  basicUnsafeWrite :: MVector (PrimState m) (PackBits a) -> Int -> PackBits a -> m ()
basicUnsafeWrite (MV_PackBits v) i :: Int
i (PackBits x :: Vector Bit
x) = let slice :: MVector (PrimState m) Bit
slice = Int
-> Int -> MVector (PrimState m) Bit -> MVector (PrimState m) Bit
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.unsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) MVector (PrimState m) Bit
v in
                                                      Mutable Vector (PrimState m) Bit -> Vector Bit -> m ()
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> v a -> m ()
VG.unsafeCopy MVector (PrimState m) Bit
Mutable Vector (PrimState m) Bit
slice Vector Bit
x

newtype instance VU.Vector (PackBits a) = V_PackBits (VU.Vector BT.Bit)

instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackBits a) where
  {-# INLINE basicLength #-}
  basicLength :: Vector (PackBits a) -> Int
basicLength = (Vector Bit -> Vector (PackBits a))
-> (Vector Bit -> Int) -> Vector (PackBits a) -> Int
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over Vector Bit -> Vector (PackBits a)
forall a. Vector Bit -> Vector (PackBits a)
V_PackBits ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (Int -> Int) -> (Vector Bit -> Int) -> Vector Bit -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Bit -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.basicLength)
  {-# INLINE basicUnsafeFreeze #-}
  basicUnsafeFreeze :: Mutable Vector (PrimState m) (PackBits a)
-> m (Vector (PackBits a))
basicUnsafeFreeze = (Vector Bit -> Vector (PackBits a))
-> m (Vector Bit) -> m (Vector (PackBits a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector Bit -> Vector (PackBits a)
forall a. Vector Bit -> Vector (PackBits a)
V_PackBits (m (Vector Bit) -> m (Vector (PackBits a)))
-> (MVector (PrimState m) (PackBits a) -> m (Vector Bit))
-> MVector (PrimState m) (PackBits a)
-> m (Vector (PackBits a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState m) Bit -> m (Vector Bit)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
VG.basicUnsafeFreeze (MVector (PrimState m) Bit -> m (Vector Bit))
-> (MVector (PrimState m) (PackBits a)
    -> MVector (PrimState m) Bit)
-> MVector (PrimState m) (PackBits a)
-> m (Vector Bit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a))
-> MVector (PrimState m) (PackBits a) -> MVector (PrimState m) Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits
  {-# INLINE basicUnsafeThaw #-}
  basicUnsafeThaw :: Vector (PackBits a)
-> m (Mutable Vector (PrimState m) (PackBits a))
basicUnsafeThaw = (MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a))
-> m (MVector (PrimState m) Bit)
-> m (MVector (PrimState m) (PackBits a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVector (PrimState m) Bit -> MVector (PrimState m) (PackBits a)
forall s a. MVector s Bit -> MVector s (PackBits a)
MV_PackBits (m (MVector (PrimState m) Bit)
 -> m (MVector (PrimState m) (PackBits a)))
-> (Vector (PackBits a) -> m (MVector (PrimState m) Bit))
-> Vector (PackBits a)
-> m (MVector (PrimState m) (PackBits a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Bit -> m (MVector (PrimState m) Bit)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
v a -> m (Mutable v (PrimState m) a)
VG.basicUnsafeThaw (Vector Bit -> m (MVector (PrimState m) Bit))
-> (Vector (PackBits a) -> Vector Bit)
-> Vector (PackBits a)
-> m (MVector (PrimState m) Bit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Bit -> Vector (PackBits a))
-> Vector (PackBits a) -> Vector Bit
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Bit -> Vector (PackBits a)
forall a. Vector Bit -> Vector (PackBits a)
V_PackBits
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> Vector (PackBits a) -> Vector (PackBits a)
basicUnsafeSlice i :: Int
i len :: Int
len = (Vector Bit -> Vector (PackBits a))
-> (Vector Bit -> Vector Bit)
-> Vector (PackBits a)
-> Vector (PackBits a)
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over Vector Bit -> Vector (PackBits a)
forall a. Vector Bit -> Vector (PackBits a)
V_PackBits (Int -> Int -> Vector Bit -> Vector Bit
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.basicUnsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a))
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeIndexM :: Vector (PackBits a) -> Int -> m (PackBits a)
basicUnsafeIndexM (V_PackBits v) i :: Int
i = PackBits a -> m (PackBits a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackBits a -> m (PackBits a))
-> (Vector Bit -> PackBits a) -> Vector Bit -> m (PackBits a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Bit -> PackBits a
forall a. Vector Bit -> PackBits a
PackBits (Vector Bit -> PackBits a)
-> (Vector Bit -> Vector Bit) -> Vector Bit -> PackBits a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Vector Bit -> Vector Bit
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.unsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (Vector Bit -> m (PackBits a)) -> Vector Bit -> m (PackBits a)
forall a b. (a -> b) -> a -> b
$ Vector Bit
v

instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackBits a)

-- Helpers

type BitLength a = CLog 2 (Cardinality a)

{-# INLINE packBits #-}
packBits :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  a -> PackBits a
packBits :: a -> PackBits a
packBits = Finite (Cardinality a) -> PackBits a
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite (Finite (Cardinality a) -> PackBits a)
-> (a -> Finite (Cardinality a)) -> a -> PackBits a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Finite (Cardinality a)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite

{-# INLINE unpackBits #-}
unpackBits :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  PackBits a -> a
unpackBits :: PackBits a -> a
unpackBits = Finite (Cardinality a) -> a
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite (Finite (Cardinality a) -> a)
-> (PackBits a -> Finite (Cardinality a)) -> PackBits a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackBits a -> Finite (Cardinality a)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite

{-# INLINE bitLength #-}
bitLength :: forall (a :: Type) (b :: Type) . 
  (Finitary a, 1 <= Cardinality a, Num b) => 
  b
bitLength :: b
bitLength = Natural -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> b)
-> (Proxy (CLog 2 (Cardinality a)) -> Natural)
-> Proxy (CLog 2 (Cardinality a))
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (CLog 2 (Cardinality a)) -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy (CLog 2 (Cardinality a)) -> b)
-> Proxy (CLog 2 (Cardinality a)) -> b
forall a b. (a -> b) -> a -> b
$ (Proxy (CLog 2 (Cardinality a))
forall k (t :: k). Proxy t
Proxy :: Proxy (BitLength a))

{-# INLINE intoBits #-}
intoBits :: forall (n :: Nat) .
  (KnownNat n, 1 <= n) =>  
  Finite n -> VU.Vector BT.Bit
intoBits :: Finite n -> Vector Bit
intoBits = State Natural (Vector Bit) -> Natural -> Vector Bit
forall s a. State s a -> s -> a
evalState (Int -> StateT Natural Identity Bit -> State Natural (Vector Bit)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM (forall b.
(Finitary (Finite n), 1 <= Cardinality (Finite n), Num b) =>
b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @(Finite n)) StateT Natural Identity Bit
go) (Natural -> Vector Bit)
-> (Finite n -> Natural) -> Finite n -> Vector Bit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integral (Finite n), Num Natural) => Finite n -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Natural
  where go :: StateT Natural Identity Bit
go = do Natural
remaining <- StateT Natural Identity Natural
forall (m :: * -> *) s. Monad m => StateT s m s
get
                let (d :: Natural
d, r :: Natural
r) = Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
quotRem Natural
remaining 2
                Natural -> StateT Natural Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Natural
d StateT Natural Identity ()
-> StateT Natural Identity Bit -> StateT Natural Identity Bit
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bit -> StateT Natural Identity Bit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bit
BT.Bit (Bool -> Bit) -> (Natural -> Bool) -> Natural -> Bit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool
forall a. Enum a => Int -> a
toEnum (Int -> Bool) -> (Natural -> Int) -> Natural -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Bit) -> Natural -> Bit
forall a b. (a -> b) -> a -> b
$ Natural
r)
                
{-# INLINE outOfBits #-}
outOfBits :: forall (n :: Nat) .
  (KnownNat n) =>  
  VU.Vector BT.Bit -> Finite n
outOfBits :: Vector Bit -> Finite n
outOfBits v :: Vector Bit
v = State (Finite n) (Finite n) -> Finite n -> Finite n
forall s a. State s a -> s -> a
evalState ((Finite n -> Bit -> State (Finite n) (Finite n))
-> Finite n -> Vector Bit -> State (Finite n) (Finite n)
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m a
VU.foldM' Finite n -> Bit -> State (Finite n) (Finite n)
forall (m :: * -> *) b.
(Monad m, Num b) =>
b -> Bit -> StateT b m b
go 0 Vector Bit
v) 1
  where go :: b -> Bit -> StateT b m b
go old :: b
old (BT.Bit b :: Bool
b) = do b
power <- StateT b m b
forall (m :: * -> *) s. Monad m => StateT s m s
get
                               let placeValue :: b
placeValue = b
power b -> b -> b
forall a. Num a => a -> a -> a
* (Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> (Bool -> Int) -> Bool -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> b) -> Bool -> b
forall a b. (a -> b) -> a -> b
$ Bool
b)
                               (b -> b) -> StateT b m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (b -> b -> b
forall a. Num a => a -> a -> a
* 2)
                               b -> StateT b m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
old b -> b -> b
forall a. Num a => a -> a -> a
+ b
placeValue)