{-
 - 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 AllowAmbiguousTypes #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module:        Data.Finitary.PackBytes
-- Description:   Scheme for packing @Finitary@ types into @Word@ arrays.
-- Copyright:     (C) Koz Ross 2019
-- License:       GPL version 3.0 or later
-- Maintainer:    koz.ross@retro-freedom.nz
-- Stability:     Experimental
-- Portability:   GHC only
--
-- If a type @a@ is 'Finitary', each inhabitant of @a@ has an index, which can
-- be represented as an unsigned integer, spread across one or more machine
-- words. This unsigned integer will have fixed length (as the number of
-- inhabitants of @a@ is finite). We can use this to derive a 'VU.Unbox'
-- instance, by representing 'VU.Vector' as a large array of machine words. We
-- can also derive a 'Storable' instance similarly.
--
-- This is the most efficient encoding of an arbitrary finitary type, both due
-- to the asymptotics of encoding and decoding (logarithmic in @Cardinality a@
-- with base @Cardinality Word@) and the fact that word accesses are faster than
-- byte and bit accesses on almost all architectures. Unless you have concerns
-- regarding space, this encoding is a good choice.
--
-- Unless your type's cardinality is extremely large (a non-trivial multiple of
-- @Cardinality Word@), this encoding is wasteful. If your type's cardinality is
-- smaller than that of @Word@, you should consider "Data.Finitary.PackInto"
-- instead, as you will have much larger control over space usage at almost no
-- performance penalty. 
module Data.Finitary.PackWords 
(
  PackWords, pattern Packed
) where

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

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

-- | An opaque wrapper around @a@, representing each value as a fixed-length
-- array of machine words.
newtype PackWords (a :: Type) = PackWords (VU.Vector Word)
  deriving (PackWords a -> PackWords a -> Bool
(PackWords a -> PackWords a -> Bool)
-> (PackWords a -> PackWords a -> Bool) -> Eq (PackWords a)
forall a. PackWords a -> PackWords a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackWords a -> PackWords a -> Bool
$c/= :: forall a. PackWords a -> PackWords a -> Bool
== :: PackWords a -> PackWords a -> Bool
$c== :: forall a. PackWords a -> PackWords a -> Bool
Eq, Int -> PackWords a -> ShowS
[PackWords a] -> ShowS
PackWords a -> String
(Int -> PackWords a -> ShowS)
-> (PackWords a -> String)
-> ([PackWords a] -> ShowS)
-> Show (PackWords a)
forall a. Int -> PackWords a -> ShowS
forall a. [PackWords a] -> ShowS
forall a. PackWords a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackWords a] -> ShowS
$cshowList :: forall a. [PackWords a] -> ShowS
show :: PackWords a -> String
$cshow :: forall a. PackWords a -> String
showsPrec :: Int -> PackWords a -> ShowS
$cshowsPrec :: forall a. Int -> PackWords a -> ShowS
Show)

type role PackWords nominal

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

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

instance Bin.Binary (PackWords a) where
  {-# INLINE put #-}
  put :: PackWords a -> Put
put = Vector Word -> Put
forall t. Binary t => t -> Put
Bin.put (Vector Word -> Put)
-> (PackWords a -> Vector Word) -> PackWords a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word -> PackWords a) -> PackWords a -> Vector Word
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word -> PackWords a
forall a. Vector Word -> PackWords a
PackWords
  {-# INLINE get #-}
  get :: Get (PackWords a)
get = Vector Word -> PackWords a
forall a. Vector Word -> PackWords a
PackWords (Vector Word -> PackWords a)
-> Get (Vector Word) -> Get (PackWords 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 (PackWords a) where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> PackWords a -> Int
hashWithSalt salt :: Int
salt = Int -> Vector Word -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Vector Word -> Int)
-> (PackWords a -> Vector Word) -> PackWords a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word -> PackWords a) -> PackWords a -> Vector Word
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word -> PackWords a
forall a. Vector Word -> PackWords a
PackWords

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

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

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

instance (Finitary a, 1 <= Cardinality a) => Storable (PackWords a) where
  {-# INLINE sizeOf #-}
  sizeOf :: PackWords a -> Int
sizeOf _ = forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
wordLength @a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
bytesPerWord
  {-# INLINE alignment #-}
  alignment :: PackWords a -> Int
alignment _ = Word -> Int
forall a. Storable a => a -> Int
alignment (Word
forall a. HasCallStack => a
undefined :: Word)
  {-# INLINE peek #-}
  peek :: Ptr (PackWords a) -> IO (PackWords a)
peek ptr :: Ptr (PackWords a)
ptr = do let wordPtr :: Ptr Any
wordPtr = Ptr (PackWords a) -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr (PackWords a)
ptr
                Vector Word -> PackWords a
forall a. Vector Word -> PackWords a
PackWords (Vector Word -> PackWords a)
-> IO (Vector Word) -> IO (PackWords a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (Int -> IO Word) -> IO (Vector Word)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> (Int -> m a) -> m (Vector a)
VU.generateM (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
wordLength @a) (Ptr Word -> IO Word
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word -> IO Word) -> (Int -> Ptr Word) -> Int -> IO Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Any -> Int -> Ptr Word
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
wordPtr (Int -> Ptr Word) -> (Int -> Int) -> Int -> Ptr Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
bytesPerWord))
  {-# INLINE poke #-}
  poke :: Ptr (PackWords a) -> PackWords a -> IO ()
poke ptr :: Ptr (PackWords a)
ptr (PackWords v :: Vector Word
v) = do let wordPtr :: Ptr Word
wordPtr = Ptr (PackWords a) -> Ptr Word
forall a b. Ptr a -> Ptr b
castPtr Ptr (PackWords a)
ptr
                              (Ptr Word -> Word -> IO (Ptr Word))
-> Ptr Word -> Vector Word -> IO ()
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m ()
VU.foldM'_ Ptr Word -> Word -> IO (Ptr Word)
forall a b. Storable a => Ptr a -> a -> IO (Ptr b)
go Ptr Word
wordPtr Vector Word
v
    where go :: Ptr a -> a -> IO (Ptr b)
go p :: Ptr a
p e :: a
e = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
p a
e IO () -> IO (Ptr b) -> IO (Ptr b)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO (Ptr b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr a -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
p Int
forall a. Num a => a
bytesPerWord) 

newtype instance VU.MVector s (PackWords a) = MV_PackWords (VU.MVector s Word)

instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (PackWords a) where
  {-# INLINE basicLength #-}
  basicLength :: MVector s (PackWords a) -> Int
basicLength = (MVector s Word -> MVector s (PackWords a))
-> (MVector s Word -> Int) -> MVector s (PackWords a) -> Int
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over MVector s Word -> MVector s (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords ((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
wordLength @a) (Int -> Int) -> (MVector s Word -> Int) -> MVector s Word -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Word -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
VGM.basicLength)
  {-# INLINE basicOverlaps #-}
  basicOverlaps :: MVector s (PackWords a) -> MVector s (PackWords a) -> Bool
basicOverlaps = (MVector s Word -> MVector s (PackWords a))
-> (MVector s Word -> MVector s Word -> Bool)
-> MVector s (PackWords a)
-> MVector s (PackWords a)
-> Bool
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a -> a') -> b -> b -> b'
over2 MVector s Word -> MVector s (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords MVector s Word -> MVector s Word -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
VGM.basicOverlaps
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> MVector s (PackWords a) -> MVector s (PackWords a)
basicUnsafeSlice i :: Int
i len :: Int
len = (MVector s Word -> MVector s (PackWords a))
-> (MVector s Word -> MVector s Word)
-> MVector s (PackWords a)
-> MVector s (PackWords a)
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over MVector s Word -> MVector s (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords (Int -> Int -> MVector s Word -> MVector s Word
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
wordLength @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
wordLength @a))
  {-# INLINE basicUnsafeNew #-}
  basicUnsafeNew :: Int -> m (MVector (PrimState m) (PackWords a))
basicUnsafeNew len :: Int
len = MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords (MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a))
-> m (MVector (PrimState m) Word)
-> m (MVector (PrimState m) (PackWords a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) Word)
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
wordLength @a)
  {-# INLINE basicInitialize #-}
  basicInitialize :: MVector (PrimState m) (PackWords a) -> m ()
basicInitialize = MVector (PrimState m) Word -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
VGM.basicInitialize (MVector (PrimState m) Word -> m ())
-> (MVector (PrimState m) (PackWords a)
    -> MVector (PrimState m) Word)
-> MVector (PrimState m) (PackWords a)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a))
-> MVector (PrimState m) (PackWords a)
-> MVector (PrimState m) Word
forall a b. Coercible a b => (a -> b) -> b -> a
op MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeRead :: MVector (PrimState m) (PackWords a) -> Int -> m (PackWords a)
basicUnsafeRead (MV_PackWords v) i :: Int
i = (Vector Word -> PackWords a) -> m (Vector Word) -> m (PackWords a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector Word -> PackWords a
forall a. Vector Word -> PackWords a
PackWords (m (Vector Word) -> m (PackWords a))
-> (MVector (PrimState m) Word -> m (Vector Word))
-> MVector (PrimState m) Word
-> m (PackWords a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState m) Word -> m (Vector Word)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
VG.freeze (MVector (PrimState m) Word -> m (Vector Word))
-> (MVector (PrimState m) Word -> MVector (PrimState m) Word)
-> MVector (PrimState m) Word
-> m (Vector Word)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int -> MVector (PrimState m) Word -> MVector (PrimState m) Word
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
wordLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
wordLength @a) (MVector (PrimState m) Word -> m (PackWords a))
-> MVector (PrimState m) Word -> m (PackWords a)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState m) Word
v
  {-# INLINE basicUnsafeWrite #-}
  basicUnsafeWrite :: MVector (PrimState m) (PackWords a) -> Int -> PackWords a -> m ()
basicUnsafeWrite (MV_PackWords v) i :: Int
i (PackWords x :: Vector Word
x) = let slice :: MVector (PrimState m) Word
slice = Int
-> Int -> MVector (PrimState m) Word -> MVector (PrimState m) Word
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
wordLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
wordLength @a) MVector (PrimState m) Word
v in
                                                        Mutable Vector (PrimState m) Word -> Vector Word -> m ()
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> v a -> m ()
VG.unsafeCopy MVector (PrimState m) Word
Mutable Vector (PrimState m) Word
slice Vector Word
x

newtype instance VU.Vector (PackWords a) = V_PackWords (VU.Vector Word)

instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackWords a) where
  {-# INLINE basicLength #-}
  basicLength :: Vector (PackWords a) -> Int
basicLength = (Vector Word -> Vector (PackWords a))
-> (Vector Word -> Int) -> Vector (PackWords a) -> Int
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over Vector Word -> Vector (PackWords a)
forall a. Vector Word -> Vector (PackWords a)
V_PackWords ((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
wordLength @a) (Int -> Int) -> (Vector Word -> Int) -> Vector Word -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.basicLength)
  {-# INLINE basicUnsafeFreeze #-}
  basicUnsafeFreeze :: Mutable Vector (PrimState m) (PackWords a)
-> m (Vector (PackWords a))
basicUnsafeFreeze = (Vector Word -> Vector (PackWords a))
-> m (Vector Word) -> m (Vector (PackWords a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector Word -> Vector (PackWords a)
forall a. Vector Word -> Vector (PackWords a)
V_PackWords (m (Vector Word) -> m (Vector (PackWords a)))
-> (MVector (PrimState m) (PackWords a) -> m (Vector Word))
-> MVector (PrimState m) (PackWords a)
-> m (Vector (PackWords a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState m) Word -> m (Vector Word)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
VG.basicUnsafeFreeze (MVector (PrimState m) Word -> m (Vector Word))
-> (MVector (PrimState m) (PackWords a)
    -> MVector (PrimState m) Word)
-> MVector (PrimState m) (PackWords a)
-> m (Vector Word)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a))
-> MVector (PrimState m) (PackWords a)
-> MVector (PrimState m) Word
forall a b. Coercible a b => (a -> b) -> b -> a
op MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords
  {-# INLINE basicUnsafeThaw #-}
  basicUnsafeThaw :: Vector (PackWords a)
-> m (Mutable Vector (PrimState m) (PackWords a))
basicUnsafeThaw = (MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a))
-> m (MVector (PrimState m) Word)
-> m (MVector (PrimState m) (PackWords a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVector (PrimState m) Word -> MVector (PrimState m) (PackWords a)
forall s a. MVector s Word -> MVector s (PackWords a)
MV_PackWords (m (MVector (PrimState m) Word)
 -> m (MVector (PrimState m) (PackWords a)))
-> (Vector (PackWords a) -> m (MVector (PrimState m) Word))
-> Vector (PackWords a)
-> m (MVector (PrimState m) (PackWords a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word -> m (MVector (PrimState m) Word)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
v a -> m (Mutable v (PrimState m) a)
VG.basicUnsafeThaw (Vector Word -> m (MVector (PrimState m) Word))
-> (Vector (PackWords a) -> Vector Word)
-> Vector (PackWords a)
-> m (MVector (PrimState m) Word)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word -> Vector (PackWords a))
-> Vector (PackWords a) -> Vector Word
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word -> Vector (PackWords a)
forall a. Vector Word -> Vector (PackWords a)
V_PackWords
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> Vector (PackWords a) -> Vector (PackWords a)
basicUnsafeSlice i :: Int
i len :: Int
len = (Vector Word -> Vector (PackWords a))
-> (Vector Word -> Vector Word)
-> Vector (PackWords a)
-> Vector (PackWords a)
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over Vector Word -> Vector (PackWords a)
forall a. Vector Word -> Vector (PackWords a)
V_PackWords (Int -> Int -> Vector Word -> Vector Word
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
wordLength @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
wordLength @a))
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeIndexM :: Vector (PackWords a) -> Int -> m (PackWords a)
basicUnsafeIndexM (V_PackWords v) i :: Int
i = PackWords a -> m (PackWords a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackWords a -> m (PackWords a))
-> (Vector Word -> PackWords a) -> Vector Word -> m (PackWords a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word -> PackWords a
forall a. Vector Word -> PackWords a
PackWords (Vector Word -> PackWords a)
-> (Vector Word -> Vector Word) -> Vector Word -> PackWords a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Vector Word -> Vector Word
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
wordLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
wordLength @a) (Vector Word -> m (PackWords a)) -> Vector Word -> m (PackWords a)
forall a b. (a -> b) -> a -> b
$ Vector Word
v

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

-- Helpers

type WordLength a = CLog (Cardinality Word) (Cardinality a)

{-# INLINE bitsPerWord #-}
bitsPerWord :: forall (a :: Type) . 
  (Num a) => 
  a
bitsPerWord :: a
bitsPerWord = 8 a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Num a => a
bytesPerWord

{-# INLINE bytesPerWord #-}
bytesPerWord :: forall (a :: Type) . 
  (Num a) => 
  a
bytesPerWord :: a
bytesPerWord = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> (Word -> Int) -> Word -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
forall a. Storable a => a -> Int
sizeOf (Word -> a) -> Word -> a
forall a b. (a -> b) -> a -> b
$ (Word
forall a. HasCallStack => a
undefined :: Word)

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

{-# INLINE packWords #-}
packWords :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  a -> PackWords a
packWords :: a -> PackWords a
packWords = Finite (Cardinality a) -> PackWords a
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite (Finite (Cardinality a) -> PackWords a)
-> (a -> Finite (Cardinality a)) -> a -> PackWords 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 unpackWords #-}
unpackWords :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  PackWords a -> a
unpackWords :: PackWords a -> a
unpackWords = Finite (Cardinality a) -> a
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite (Finite (Cardinality a) -> a)
-> (PackWords a -> Finite (Cardinality a)) -> PackWords a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackWords a -> Finite (Cardinality a)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite

{-# INLINE intoWords #-}
intoWords :: forall (n :: Nat) . 
  (KnownNat n, 1 <= n) => 
  Finite n -> VU.Vector Word
intoWords :: Finite n -> Vector Word
intoWords = State Natural (Vector Word) -> Natural -> Vector Word
forall s a. State s a -> s -> a
evalState (Int -> StateT Natural Identity Word -> State Natural (Vector Word)
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
wordLength @(Finite n)) StateT Natural Identity Word
go) (Natural -> Vector Word)
-> (Finite n -> Natural) -> Finite n -> Vector Word
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 Word
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 Natural
forall a. Num a => a
bitsPerWord
                Natural -> StateT Natural Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Natural
d StateT Natural Identity ()
-> StateT Natural Identity Word -> StateT Natural Identity Word
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word -> StateT Natural Identity Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
r)

{-# INLINE outOfWords #-}
outOfWords :: forall (n :: Nat) . 
  (KnownNat n) => 
  VU.Vector Word -> Finite n
outOfWords :: Vector Word -> Finite n
outOfWords v :: Vector Word
v = State (Finite n) (Finite n) -> Finite n -> Finite n
forall s a. State s a -> s -> a
evalState ((Finite n -> Word -> State (Finite n) (Finite n))
-> Finite n -> Vector Word -> 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 -> Word -> State (Finite n) (Finite n)
forall (m :: * -> *) a b.
(Monad m, Integral a, Num b) =>
b -> a -> StateT b m b
go 0 Vector Word
v) 1
  where go :: b -> a -> StateT b m b
go old :: b
old w :: a
w = 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
* a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w
                      (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
forall a. Num a => a
bitsPerWord)
                      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)