{-
 - 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 #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |

-- Module:        Data.Finitary.PackBits

-- Description:   Scheme for bit-packing @Finitary@ types.

-- Copyright:     (C) Koz Ross 2019

-- License:       GPL version 3.0 or later

-- Stability:     Experimental

-- Portability:   GHC only

--

-- From the [Kraft-McMillan

-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality)

-- and 

-- 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,
  BulkPack, exposeVector
) 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 Data.Semigroup (Dual(..))

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, Int -> PackBits a -> ShowS
[PackBits a] -> ShowS
PackBits a -> String
(Int -> PackBits a -> ShowS)
-> (PackBits a -> String)
-> ([PackBits a] -> ShowS)
-> Show (PackBits a)
forall a. Int -> PackBits a -> ShowS
forall a. [PackBits a] -> ShowS
forall a. PackBits a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackBits a] -> ShowS
$cshowList :: forall a. [PackBits a] -> ShowS
show :: PackBits a -> String
$cshow :: forall a. PackBits a -> String
showsPrec :: Int -> PackBits a -> ShowS
$cshowsPrec :: forall a. Int -> PackBits a -> ShowS
Show)

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) => 
  a -> PackBits a
pattern $bPacked :: forall a. (Finitary a, 1 <= Cardinality a) => a -> PackBits a
$mPacked :: forall {r} {a}.
(Finitary a, 1 <= Cardinality a) =>
PackBits a -> (a -> r) -> (Void# -> r) -> r
Packed x <- (unpackBits -> x)
  where Packed a
x = a -> PackBits a
forall a. (Finitary a, 1 <= Cardinality a) => a -> PackBits a
packBits a
x

instance Ord (PackBits a) where
  compare :: PackBits a -> PackBits a -> Ordering
compare (PackBits Vector Bit
v1) (PackBits Vector Bit
v2) = Dual Ordering -> Ordering
forall a. Dual a -> a
getDual (Dual Ordering -> Ordering)
-> (Vector Bit -> Dual Ordering) -> Vector Bit -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bit, Bit) -> Dual Ordering -> Dual Ordering)
-> Dual Ordering -> Vector (Bit, Bit) -> Dual Ordering
forall a b. Unbox a => (a -> b -> b) -> b -> Vector a -> b
VU.foldr (Bit, Bit) -> Dual Ordering -> Dual Ordering
forall {b}. Ord b => (b, b) -> Dual Ordering -> Dual Ordering
go (Ordering -> Dual Ordering
forall a. a -> Dual a
Dual Ordering
EQ) (Vector (Bit, Bit) -> Dual Ordering)
-> (Vector Bit -> Vector (Bit, Bit)) -> Vector Bit -> Dual Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bit -> Bit -> (Bit, Bit))
-> Vector Bit -> Vector Bit -> Vector (Bit, Bit)
forall a b c.
(Unbox a, Unbox b, Unbox c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
VU.zipWith (,) Vector Bit
v1 (Vector Bit -> Ordering) -> Vector Bit -> Ordering
forall a b. (a -> b) -> a -> b
$ Vector Bit
v2
    where go :: (b, b) -> Dual Ordering -> Dual Ordering
go (b, b)
input Dual Ordering
order = (Dual Ordering
order Dual Ordering -> Dual Ordering -> Dual Ordering
forall a. Semigroup a => a -> a -> a
<>) (Dual Ordering -> Dual Ordering)
-> ((b, b) -> Dual Ordering) -> (b, b) -> Dual Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ordering -> Dual Ordering
forall a. a -> Dual a
Dual (Ordering -> Dual Ordering)
-> ((b, b) -> Ordering) -> (b, b) -> Dual Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> Ordering) -> (b, b) -> Ordering
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((b, b) -> Dual Ordering) -> (b, b) -> Dual Ordering
forall a b. (a -> b) -> a -> b
$ (b, b)
input

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 :: forall s. 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 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 :: forall s. 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 :: forall s.
Int -> Int -> MVector s (PackBits a) -> MVector s (PackBits a)
basicUnsafeSlice Int
i 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 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 a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a))
  {-# INLINE basicUnsafeNew #-}
  basicUnsafeNew :: forall (m :: * -> *).
PrimMonad m =>
Int -> m (MVector (PrimState m) (PackBits a))
basicUnsafeNew 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 a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a))
  {-# INLINE basicInitialize #-}
  basicInitialize :: forall (m :: * -> *).
PrimMonad m =>
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 :: forall (m :: * -> *).
PrimMonad m =>
MVector (PrimState m) (PackBits a) -> Int -> m (PackBits a)
basicUnsafeRead (MV_PackBits MVector (PrimState m) Bit
v) 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 a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (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 :: forall (m :: * -> *).
PrimMonad m =>
MVector (PrimState m) (PackBits a) -> Int -> PackBits a -> m ()
basicUnsafeWrite (MV_PackBits MVector (PrimState m) Bit
v) Int
i (PackBits 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 a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (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 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 :: forall (m :: * -> *).
PrimMonad m =>
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 :: forall (m :: * -> *).
PrimMonad m =>
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 Int
i 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 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 a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a))
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeIndexM :: forall (m :: * -> *).
Monad m =>
Vector (PackBits a) -> Int -> m (PackBits a)
basicUnsafeIndexM (V_PackBits Vector Bit
v) 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 a b. (Finitary a, 1 <= Cardinality a, Num b) => b
bitLength @a) (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)

-- | This wrapper provides an efficient 'Hashable' instance (hash the entire

-- underlying bit-packed vector, rather than each element individually), as well

-- as a 'Bin.Binary' instance (which stores or reads the entire blob of

-- bits \'in one go\').

newtype BulkPack a = BulkPack { forall a. BulkPack a -> Vector (PackBits a)
exposeVector :: VU.Vector (PackBits a) }
  deriving (BulkPack a -> ()
(BulkPack a -> ()) -> NFData (BulkPack a)
forall a. BulkPack a -> ()
forall a. (a -> ()) -> NFData a
rnf :: BulkPack a -> ()
$crnf :: forall a. BulkPack a -> ()
NFData)

deriving instance (Finitary a, 1 <= Cardinality a) => Eq (BulkPack a)

deriving instance (Finitary a, 1 <= Cardinality a) => Ord (BulkPack a)

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

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

-- Helpers


type BitLength a = CLog 2 (Cardinality a)

{-# INLINE packBits #-}
packBits :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  a -> PackBits a
packBits :: forall a. (Finitary a, 1 <= Cardinality a) => 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 :: forall a. (Finitary a, 1 <= Cardinality a) => 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 :: forall a b. (Finitary a, 1 <= Cardinality a, Num b) => 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 :: forall (n :: Nat). (KnownNat n, 1 <= n) => 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 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
. 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 (Natural
d, Natural
r) = Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
quotRem Natural
remaining Natural
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 :: forall (n :: Nat). KnownNat n => Vector Bit -> Finite n
outOfBits 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 Finite n
0 Vector Bit
v) Finite n
1
  where go :: b -> Bit -> StateT b m b
go b
old (BT.Bit 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
* b
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)