-- |
-- Module: M.Chunk.Code
-- Description: Encode and decode paletted containers.
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- Encode and decode paletted containers for block states and biomes.
module M.Chunk.Code
  ( ChunkSection (..),
    ChunkSectionEncoding (..),
    mkcscodec,
  )
where

import Control.Monad
import Data.Bits
import Data.ByteString.Builder
import Data.Data
import Data.Foldable
import Data.Int
import Data.IntMap.Strict qualified as M
import Data.Vector.Unboxed qualified as V
import Data.Word
import FlatParse.Stateful qualified as F
import GHC.Generics hiding (S)
import M.Pack
import Text.Printf
import Prelude hiding (words)

-- | a chunk section where @c@ is the numeric type for block states and
-- @m@ is the same for biomes
data ChunkSection c m = ChunkSection
  { -- | number of non-air blocks (tracked for optimization)
    forall c m. ChunkSection c m -> Int16
csnonempty :: !Int16,
    -- | block states (4,096 entries; 16x16x16, access @[y][z][x]@)
    forall c m. ChunkSection c m -> Vector c
csblockstates :: !(V.Vector c),
    -- | biomes (64 entries; 4x4x4, access @[y][z][x]@)
    forall c m. ChunkSection c m -> Vector m
csbiomes :: !(V.Vector m)
  }
  deriving (ChunkSection c m -> ChunkSection c m -> Bool
(ChunkSection c m -> ChunkSection c m -> Bool)
-> (ChunkSection c m -> ChunkSection c m -> Bool)
-> Eq (ChunkSection c m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c m.
(Unbox c, Unbox m, Eq c, Eq m) =>
ChunkSection c m -> ChunkSection c m -> Bool
$c== :: forall c m.
(Unbox c, Unbox m, Eq c, Eq m) =>
ChunkSection c m -> ChunkSection c m -> Bool
== :: ChunkSection c m -> ChunkSection c m -> Bool
$c/= :: forall c m.
(Unbox c, Unbox m, Eq c, Eq m) =>
ChunkSection c m -> ChunkSection c m -> Bool
/= :: ChunkSection c m -> ChunkSection c m -> Bool
Eq, Eq (ChunkSection c m)
Eq (ChunkSection c m) =>
(ChunkSection c m -> ChunkSection c m -> Ordering)
-> (ChunkSection c m -> ChunkSection c m -> Bool)
-> (ChunkSection c m -> ChunkSection c m -> Bool)
-> (ChunkSection c m -> ChunkSection c m -> Bool)
-> (ChunkSection c m -> ChunkSection c m -> Bool)
-> (ChunkSection c m -> ChunkSection c m -> ChunkSection c m)
-> (ChunkSection c m -> ChunkSection c m -> ChunkSection c m)
-> Ord (ChunkSection c m)
ChunkSection c m -> ChunkSection c m -> Bool
ChunkSection c m -> ChunkSection c m -> Ordering
ChunkSection c m -> ChunkSection c m -> ChunkSection c m
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 c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
Eq (ChunkSection c m)
forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Bool
forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Ordering
forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> ChunkSection c m
$ccompare :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Ordering
compare :: ChunkSection c m -> ChunkSection c m -> Ordering
$c< :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Bool
< :: ChunkSection c m -> ChunkSection c m -> Bool
$c<= :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Bool
<= :: ChunkSection c m -> ChunkSection c m -> Bool
$c> :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Bool
> :: ChunkSection c m -> ChunkSection c m -> Bool
$c>= :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> Bool
>= :: ChunkSection c m -> ChunkSection c m -> Bool
$cmax :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> ChunkSection c m
max :: ChunkSection c m -> ChunkSection c m -> ChunkSection c m
$cmin :: forall c m.
(Unbox c, Unbox m, Ord c, Ord m) =>
ChunkSection c m -> ChunkSection c m -> ChunkSection c m
min :: ChunkSection c m -> ChunkSection c m -> ChunkSection c m
Ord, (forall x. ChunkSection c m -> Rep (ChunkSection c m) x)
-> (forall x. Rep (ChunkSection c m) x -> ChunkSection c m)
-> Generic (ChunkSection c m)
forall x. Rep (ChunkSection c m) x -> ChunkSection c m
forall x. ChunkSection c m -> Rep (ChunkSection c m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c m x. Rep (ChunkSection c m) x -> ChunkSection c m
forall c m x. ChunkSection c m -> Rep (ChunkSection c m) x
$cfrom :: forall c m x. ChunkSection c m -> Rep (ChunkSection c m) x
from :: forall x. ChunkSection c m -> Rep (ChunkSection c m) x
$cto :: forall c m x. Rep (ChunkSection c m) x -> ChunkSection c m
to :: forall x. Rep (ChunkSection c m) x -> ChunkSection c m
Generic, Typeable, Typeable (ChunkSection c m)
Typeable (ChunkSection c m) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> ChunkSection c m
 -> c (ChunkSection c m))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (ChunkSection c m))
-> (ChunkSection c m -> Constr)
-> (ChunkSection c m -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (ChunkSection c m)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (ChunkSection c m)))
-> ((forall b. Data b => b -> b)
    -> ChunkSection c m -> ChunkSection c m)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> ChunkSection c m -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ChunkSection c m -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> ChunkSection c m -> m (ChunkSection c m))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ChunkSection c m -> m (ChunkSection c m))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ChunkSection c m -> m (ChunkSection c m))
-> Data (ChunkSection c m)
ChunkSection c m -> Constr
ChunkSection c m -> DataType
(forall b. Data b => b -> b)
-> ChunkSection c m -> ChunkSection c m
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ChunkSection c m -> u
forall u. (forall d. Data d => d -> u) -> ChunkSection c m -> [u]
forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
Typeable (ChunkSection c m)
forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
ChunkSection c m -> Constr
forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
ChunkSection c m -> DataType
forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
(forall b. Data b => b -> b)
-> ChunkSection c m -> ChunkSection c m
forall c m u.
(Data c, Data m, Unbox c, Unbox m) =>
Int -> (forall d. Data d => d -> u) -> ChunkSection c m -> u
forall c m u.
(Data c, Data m, Unbox c, Unbox m) =>
(forall d. Data d => d -> u) -> ChunkSection c m -> [u]
forall c m r r'.
(Data c, Data m, Unbox c, Unbox m) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
forall c m r r'.
(Data c, Data m, Unbox c, Unbox m) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
forall c m (m :: * -> *).
(Data c, Data m, Unbox c, Unbox m, Monad m) =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
forall c m (m :: * -> *).
(Data c, Data m, Unbox c, Unbox m, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
forall c m (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (ChunkSection c m)
forall c m (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChunkSection c m -> c (ChunkSection c m)
forall c m (t :: * -> *) (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (ChunkSection c m))
forall c m (t :: * -> * -> *) (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (ChunkSection c m))
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (ChunkSection c m)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChunkSection c m -> c (ChunkSection c m)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (ChunkSection c m))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (ChunkSection c m))
$cgfoldl :: forall c m (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChunkSection c m -> c (ChunkSection c m)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChunkSection c m -> c (ChunkSection c m)
$cgunfold :: forall c m (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (ChunkSection c m)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (ChunkSection c m)
$ctoConstr :: forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
ChunkSection c m -> Constr
toConstr :: ChunkSection c m -> Constr
$cdataTypeOf :: forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
ChunkSection c m -> DataType
dataTypeOf :: ChunkSection c m -> DataType
$cdataCast1 :: forall c m (t :: * -> *) (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (ChunkSection c m))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (ChunkSection c m))
$cdataCast2 :: forall c m (t :: * -> * -> *) (c :: * -> *).
(Data c, Data m, Unbox c, Unbox m, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (ChunkSection c m))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (ChunkSection c m))
$cgmapT :: forall c m.
(Data c, Data m, Unbox c, Unbox m) =>
(forall b. Data b => b -> b)
-> ChunkSection c m -> ChunkSection c m
gmapT :: (forall b. Data b => b -> b)
-> ChunkSection c m -> ChunkSection c m
$cgmapQl :: forall c m r r'.
(Data c, Data m, Unbox c, Unbox m) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
$cgmapQr :: forall c m r r'.
(Data c, Data m, Unbox c, Unbox m) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSection c m -> r
$cgmapQ :: forall c m u.
(Data c, Data m, Unbox c, Unbox m) =>
(forall d. Data d => d -> u) -> ChunkSection c m -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ChunkSection c m -> [u]
$cgmapQi :: forall c m u.
(Data c, Data m, Unbox c, Unbox m) =>
Int -> (forall d. Data d => d -> u) -> ChunkSection c m -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ChunkSection c m -> u
$cgmapM :: forall c m (m :: * -> *).
(Data c, Data m, Unbox c, Unbox m, Monad m) =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
$cgmapMp :: forall c m (m :: * -> *).
(Data c, Data m, Unbox c, Unbox m, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
$cgmapMo :: forall c m (m :: * -> *).
(Data c, Data m, Unbox c, Unbox m, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSection c m -> m (ChunkSection c m)
Data)

-- | uses paletted view with hard-coded settings to compress what's been shown
instance
  ( Show c,
    Integral c,
    FiniteBits c,
    V.Unbox c,
    Show m,
    Integral m,
    FiniteBits m,
    V.Unbox m
  ) =>
  Show (ChunkSection c m)
  where
  show :: ChunkSection c m -> String
show ChunkSection {Int16
Vector c
Vector m
csnonempty :: forall c m. ChunkSection c m -> Int16
csblockstates :: forall c m. ChunkSection c m -> Vector c
csbiomes :: forall c m. ChunkSection c m -> Vector m
csnonempty :: Int16
csblockstates :: Vector c
csbiomes :: Vector m
..} =
    String -> Int16 -> Int -> String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"ChunkSection {csnonempty = %d, csblockstates = (length %d numbers; \
      \paletted view) %s, csbiomes = (length %d numbers; \
      \paletted view) %s}"
      Int16
csnonempty
      -- often reasonable encoding settings, since protocol default;
      -- but could be surprising if using expanded number of block states
      -- and/or biomes.
      (Vector c -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector c
csblockstates)
      (Builder -> String
forall a. Show a => a -> String
show (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ MkCodec -> Vector c -> Builder
forall a.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Vector a -> Builder
mkencoder (Word8 -> Word8 -> Word8 -> Int -> MkCodec
MkCodec Word8
4 Word8
8 Word8
15 Int
4096) Vector c
csblockstates)
      (Vector m -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector m
csbiomes)
      (Builder -> String
forall a. Show a => a -> String
show (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ MkCodec -> Vector m -> Builder
forall a.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Vector a -> Builder
mkencoder (Word8 -> Word8 -> Word8 -> Int -> MkCodec
MkCodec Word8
1 Word8
3 Word8
6 Int
64) Vector m
csbiomes)

-- | encoding configuration for @ChunkSection@
data ChunkSectionEncoding = ChunkSectionEncoding
  { -- | number of possible block states
    ChunkSectionEncoding -> Int
cseblockstates :: !Int,
    -- | number of possible biomes
    ChunkSectionEncoding -> Int
csebiomes :: !Int
  }
  deriving (Int -> ChunkSectionEncoding -> ShowS
[ChunkSectionEncoding] -> ShowS
ChunkSectionEncoding -> String
(Int -> ChunkSectionEncoding -> ShowS)
-> (ChunkSectionEncoding -> String)
-> ([ChunkSectionEncoding] -> ShowS)
-> Show ChunkSectionEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChunkSectionEncoding -> ShowS
showsPrec :: Int -> ChunkSectionEncoding -> ShowS
$cshow :: ChunkSectionEncoding -> String
show :: ChunkSectionEncoding -> String
$cshowList :: [ChunkSectionEncoding] -> ShowS
showList :: [ChunkSectionEncoding] -> ShowS
Show, ReadPrec [ChunkSectionEncoding]
ReadPrec ChunkSectionEncoding
Int -> ReadS ChunkSectionEncoding
ReadS [ChunkSectionEncoding]
(Int -> ReadS ChunkSectionEncoding)
-> ReadS [ChunkSectionEncoding]
-> ReadPrec ChunkSectionEncoding
-> ReadPrec [ChunkSectionEncoding]
-> Read ChunkSectionEncoding
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ChunkSectionEncoding
readsPrec :: Int -> ReadS ChunkSectionEncoding
$creadList :: ReadS [ChunkSectionEncoding]
readList :: ReadS [ChunkSectionEncoding]
$creadPrec :: ReadPrec ChunkSectionEncoding
readPrec :: ReadPrec ChunkSectionEncoding
$creadListPrec :: ReadPrec [ChunkSectionEncoding]
readListPrec :: ReadPrec [ChunkSectionEncoding]
Read, ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
(ChunkSectionEncoding -> ChunkSectionEncoding -> Bool)
-> (ChunkSectionEncoding -> ChunkSectionEncoding -> Bool)
-> Eq ChunkSectionEncoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
== :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
$c/= :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
/= :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
Eq, Eq ChunkSectionEncoding
Eq ChunkSectionEncoding =>
(ChunkSectionEncoding -> ChunkSectionEncoding -> Ordering)
-> (ChunkSectionEncoding -> ChunkSectionEncoding -> Bool)
-> (ChunkSectionEncoding -> ChunkSectionEncoding -> Bool)
-> (ChunkSectionEncoding -> ChunkSectionEncoding -> Bool)
-> (ChunkSectionEncoding -> ChunkSectionEncoding -> Bool)
-> (ChunkSectionEncoding
    -> ChunkSectionEncoding -> ChunkSectionEncoding)
-> (ChunkSectionEncoding
    -> ChunkSectionEncoding -> ChunkSectionEncoding)
-> Ord ChunkSectionEncoding
ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
ChunkSectionEncoding -> ChunkSectionEncoding -> Ordering
ChunkSectionEncoding
-> ChunkSectionEncoding -> ChunkSectionEncoding
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
$ccompare :: ChunkSectionEncoding -> ChunkSectionEncoding -> Ordering
compare :: ChunkSectionEncoding -> ChunkSectionEncoding -> Ordering
$c< :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
< :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
$c<= :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
<= :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
$c> :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
> :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
$c>= :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
>= :: ChunkSectionEncoding -> ChunkSectionEncoding -> Bool
$cmax :: ChunkSectionEncoding
-> ChunkSectionEncoding -> ChunkSectionEncoding
max :: ChunkSectionEncoding
-> ChunkSectionEncoding -> ChunkSectionEncoding
$cmin :: ChunkSectionEncoding
-> ChunkSectionEncoding -> ChunkSectionEncoding
min :: ChunkSectionEncoding
-> ChunkSectionEncoding -> ChunkSectionEncoding
Ord, (forall x. ChunkSectionEncoding -> Rep ChunkSectionEncoding x)
-> (forall x. Rep ChunkSectionEncoding x -> ChunkSectionEncoding)
-> Generic ChunkSectionEncoding
forall x. Rep ChunkSectionEncoding x -> ChunkSectionEncoding
forall x. ChunkSectionEncoding -> Rep ChunkSectionEncoding x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChunkSectionEncoding -> Rep ChunkSectionEncoding x
from :: forall x. ChunkSectionEncoding -> Rep ChunkSectionEncoding x
$cto :: forall x. Rep ChunkSectionEncoding x -> ChunkSectionEncoding
to :: forall x. Rep ChunkSectionEncoding x -> ChunkSectionEncoding
Generic, Typeable ChunkSectionEncoding
Typeable ChunkSectionEncoding =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> ChunkSectionEncoding
 -> c ChunkSectionEncoding)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ChunkSectionEncoding)
-> (ChunkSectionEncoding -> Constr)
-> (ChunkSectionEncoding -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ChunkSectionEncoding))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ChunkSectionEncoding))
-> ((forall b. Data b => b -> b)
    -> ChunkSectionEncoding -> ChunkSectionEncoding)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> ChunkSectionEncoding -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ChunkSectionEncoding -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> ChunkSectionEncoding -> m ChunkSectionEncoding)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ChunkSectionEncoding -> m ChunkSectionEncoding)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ChunkSectionEncoding -> m ChunkSectionEncoding)
-> Data ChunkSectionEncoding
ChunkSectionEncoding -> Constr
ChunkSectionEncoding -> DataType
(forall b. Data b => b -> b)
-> ChunkSectionEncoding -> ChunkSectionEncoding
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ChunkSectionEncoding -> u
forall u.
(forall d. Data d => d -> u) -> ChunkSectionEncoding -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ChunkSectionEncoding
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ChunkSectionEncoding
-> c ChunkSectionEncoding
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ChunkSectionEncoding)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ChunkSectionEncoding)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ChunkSectionEncoding
-> c ChunkSectionEncoding
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ChunkSectionEncoding
-> c ChunkSectionEncoding
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ChunkSectionEncoding
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ChunkSectionEncoding
$ctoConstr :: ChunkSectionEncoding -> Constr
toConstr :: ChunkSectionEncoding -> Constr
$cdataTypeOf :: ChunkSectionEncoding -> DataType
dataTypeOf :: ChunkSectionEncoding -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ChunkSectionEncoding)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ChunkSectionEncoding)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ChunkSectionEncoding)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ChunkSectionEncoding)
$cgmapT :: (forall b. Data b => b -> b)
-> ChunkSectionEncoding -> ChunkSectionEncoding
gmapT :: (forall b. Data b => b -> b)
-> ChunkSectionEncoding -> ChunkSectionEncoding
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChunkSectionEncoding -> r
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> ChunkSectionEncoding -> [u]
gmapQ :: forall u.
(forall d. Data d => d -> u) -> ChunkSectionEncoding -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ChunkSectionEncoding -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ChunkSectionEncoding -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ChunkSectionEncoding -> m ChunkSectionEncoding
Data, Typeable)

-- | create a codec for @ChunkSection@s using the provided settings
mkcscodec ::
  (V.Unbox m, V.Unbox c, FiniteBits m, FiniteBits c, Integral m, Integral c) =>
  -- | encoding settings
  ChunkSectionEncoding ->
  -- | a pair of an encoder and a decoder, respectively
  (ChunkSection c m -> Builder, Parser st r (ChunkSection c m))
mkcscodec :: forall m c (st :: ZeroBitType) r.
(Unbox m, Unbox c, FiniteBits m, FiniteBits c, Integral m,
 Integral c) =>
ChunkSectionEncoding
-> (ChunkSection c m -> Builder, Parser st r (ChunkSection c m))
mkcscodec ChunkSectionEncoding
cse =
  -- the [4, 8] and [1, 3] ranges have been hardcoded in the protocol spec
  -- for some time
  let -- configure codecs with protocol-specified ranges
      bscodec :: MkCodec
bscodec = Word8 -> Word8 -> Word8 -> Int -> MkCodec
MkCodec Word8
4 Word8
8 (Int -> Word8
forall a b. (FiniteBits a, Ord a, Num a, Num b) => a -> b
lg2 ChunkSectionEncoding
cse.cseblockstates) Int
4096
      bmcodec :: MkCodec
bmcodec = Word8 -> Word8 -> Word8 -> Int -> MkCodec
MkCodec Word8
1 Word8
3 (Int -> Word8
forall a b. (FiniteBits a, Ord a, Num a, Num b) => a -> b
lg2 ChunkSectionEncoding
cse.csebiomes) Int
64
      -- create encoder/decoder pairs for blocks and biomes
      (Vector c -> Builder
bsencode, Vector m -> Builder
bmencode) = (MkCodec -> Vector c -> Builder
forall a.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Vector a -> Builder
mkencoder MkCodec
bscodec, MkCodec -> Vector m -> Builder
forall a.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Vector a -> Builder
mkencoder MkCodec
bmcodec)
      (Parser st r (Vector c)
bsdecode, Parser st r (Vector m)
bmdecode) = (MkCodec -> Parser st r (Vector c)
forall a (st :: ZeroBitType) r.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Parser st r (Vector a)
mkdecoder MkCodec
bscodec, MkCodec -> Parser st r (Vector m)
forall a (st :: ZeroBitType) r.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Parser st r (Vector a)
mkdecoder MkCodec
bmcodec)
      -- format: [blockcount][blockstates][biomes]
      encode :: ChunkSection c m -> Builder
encode ChunkSection c m
cs =
        Int16 -> Builder
int16BE ChunkSection c m
cs.csnonempty
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Vector c -> Builder
bsencode ChunkSection c m
cs.csblockstates
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Vector m -> Builder
bmencode ChunkSection c m
cs.csbiomes
      decode :: ParserT st r ParseError (ChunkSection c m)
decode = do
        Int16
blockcount <- ParserT st r ParseError Int16
forall (st :: ZeroBitType) r e. ParserT st r e Int16
F.anyInt16be ParserT st r ParseError Int16
-> (Int16 -> ParserT st r ParseError Int16)
-> ParserT st r ParseError Int16
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int16 -> ParserT st r ParseError Int16
forall {a} {st :: ZeroBitType} {r}.
(Ord a, Num a, Show a) =>
a -> ParserT st r ParseError a
checkbc
        Int16 -> Vector c -> Vector m -> ChunkSection c m
forall c m. Int16 -> Vector c -> Vector m -> ChunkSection c m
ChunkSection Int16
blockcount (Vector c -> Vector m -> ChunkSection c m)
-> Parser st r (Vector c)
-> ParserT st r ParseError (Vector m -> ChunkSection c m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser st r (Vector c)
bsdecode ParserT st r ParseError (Vector m -> ChunkSection c m)
-> Parser st r (Vector m)
-> ParserT st r ParseError (ChunkSection c m)
forall a b.
ParserT st r ParseError (a -> b)
-> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser st r (Vector m)
bmdecode
        where
          -- verify block count is within Minecraft's limits
          checkbc :: a -> ParserT st r ParseError a
checkbc a
n
            | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = ParseError -> ParserT st r ParseError a
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err ParseError
"mkcscodec/decode: negative non-air block count"
            | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
4096 -- max blocks in 16x16x16 section
              =
                ParseError -> ParserT st r ParseError a
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err (ParseError -> ParserT st r ParseError a)
-> ParseError -> ParserT st r ParseError a
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError do
                  String
"mkcscodec/decode: non-air block count too many: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n
            | Bool
otherwise = a -> ParserT st r ParseError a
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
n
   in (ChunkSection c m -> Builder
encode, ParserT st r ParseError (ChunkSection c m)
decode)

-- Calculate bits needed to represent n values
lg2 :: (FiniteBits a, Ord a, Num a, Num b) => a -> b
lg2 :: forall a b. (FiniteBits a, Ord a, Num a, Num b) => a -> b
lg2 a
n
  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1 = b
0
  | Bool
otherwise = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize a
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros (a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1)

-- | Configuration for encoding and decoding
data MkCodec = MkCodec
  { -- | Minimum palette size (if using palette)
    MkCodec -> Word8
lowlim :: !Word8,
    -- | Maximum palette size (if using palette)
    MkCodec -> Word8
upplim :: !Word8,
    -- | Bits per entry for direct encoding
    MkCodec -> Word8
directbpe :: !Word8,
    -- | Count for single value encoding
    MkCodec -> Int
singlecount :: !Int
  }

-- | Encode values using either direct, indirect (palette), or single value encoding
--
-- == Usage
--
-- Plug in the first argument ('MkCodec' configuration) and store the
-- closure in a variable. This closure is the actual encoder function.
-- Then, use the closure to encode values.
mkencoder ::
  forall a.
  (Integral a, FiniteBits a, V.Unbox a) =>
  -- | Encoder configuration
  MkCodec ->
  -- | Input values to encode
  V.Vector a ->
  -- | Encoded data
  Builder
mkencoder :: forall a.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Vector a -> Builder
mkencoder MkCodec {Int
Word8
lowlim :: MkCodec -> Word8
upplim :: MkCodec -> Word8
directbpe :: MkCodec -> Word8
singlecount :: MkCodec -> Int
lowlim :: Word8
upplim :: Word8
directbpe :: Word8
singlecount :: Int
..} = Vector a -> Builder
choose1
  where
    -- Main strategy selector based on input characteristics
    choose1 :: Vector a -> Builder
choose1 Vector a
vs
      -- Safety checks
      | a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
forall a. HasCallStack => a
undefined :: Int) =
          String -> Builder
forall a. HasCallStack => String -> a
error String
"mkencoder/choose1: bit size"
      | Word8
lowlim Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0 = String -> Builder
forall a. HasCallStack => String -> a
error String
"mkencoder/choose1: lowlim"
      | Word8
upplim Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0 Bool -> Bool -> Bool
|| Word8
upplim Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
lowlim =
          String -> Builder
forall a. HasCallStack => String -> a
error String
"mkencoder/choose1: upplim"
      | Word8
directbpe Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0 = String -> Builder
forall a. HasCallStack => String -> a
error String
"mkencoder/choose1: directbpe"
      | Vector a -> Bool
forall a. Unbox a => Vector a -> Bool
V.null Vector a
vs = String -> Builder
forall a. HasCallStack => String -> a
error String
"mkencoder/choose1: empty"
      -- Single value case - when vector has only one value
      | Just (a
v, Vector a
w) <- Vector a -> Maybe (a, Vector a)
forall a. Unbox a => Vector a -> Maybe (a, Vector a)
V.uncons Vector a
vs, Vector a -> Bool
forall a. Unbox a => Vector a -> Bool
V.null Vector a
w = a -> Builder
forall {a}. Integral a => a -> Builder
single a
v
      -- Single value case - when all values are identical
      | Just (Int
_, IntMap Int
m, Builder
_) <- Vector a -> Maybe (Int, IntMap Int, Builder)
computepalette Vector a
vs, IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = a -> Builder
forall {a}. Integral a => a -> Builder
single (Vector a -> a
forall a. Unbox a => Vector a -> a
V.head Vector a
vs)
      -- Try palette encoding if possible
      | Just (Int, IntMap Int, Builder)
p <- Vector a -> Maybe (Int, IntMap Int, Builder)
computepalette Vector a
vs = (Int, IntMap Int, Builder) -> Vector a -> Builder
forall {a} {c} {a}.
(FiniteBits a, FiniteBits c, Unbox c, Unbox a, Integral a,
 Integral c, Integral a) =>
(a, IntMap c, Builder) -> Vector a -> Builder
indirect (Int, IntMap Int, Builder)
p Vector a
vs
      -- Fallback to direct encoding
      | Bool
otherwise = Vector a -> Builder
direct Vector a
vs

    -- Encode a single value: [0: bpe][value][0: # longs to follow = none]
    single :: a -> Builder
single a
v = Word8 -> Builder
word8 Word8
0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall {a}. Integral a => a -> Builder
packleb32 a
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 Word8
0

    -- Palette-based encoding
    indirect :: (a, IntMap c, Builder) -> Vector a -> Builder
indirect (a
palsiz, IntMap c
pal, Builder
pallis) Vector a
vs =
      let bpe :: Int
bpe = a -> Int
forall a b. (FiniteBits a, Ord a, Num a, Num b) => a -> b
lg2 a
palsiz -- Bits per entry
          lut :: a -> c
lut = (IntMap c
pal M.!) (Int -> c) -> (a -> Int) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -- Convert values to pal. indices
          wor :: Vector Word64
wor = Int -> Vector c -> Vector Word64
forall w c.
(FiniteBits w, Integral w, Unbox w, FiniteBits c, Integral c,
 Unbox c) =>
Int -> Vector c -> Vector w
pkbv Int
bpe (Vector c -> Vector Word64) -> Vector c -> Vector Word64
forall a b. (a -> b) -> a -> b
$ (a -> c) -> Vector a -> Vector c
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
V.map a -> c
lut Vector a
vs -- Pack indices into words
          chk :: Word8
chk
            | Int
bpe Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8 = String -> Word8
forall a. HasCallStack => String -> a
error (String -> Word8) -> String -> Word8
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"mkencoder/indirect: bpe (%d) > 8" Int
bpe
            | Bool
otherwise = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bpe
       in Word8 -> Builder
word8 Word8
chk -- Format: [bpe][palette size]
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall {a}. Integral a => a -> Builder
packleb32 a
palsiz -- [palette entries...]
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
pallis -- [data length][packed data]
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall {a}. Integral a => a -> Builder
packleb32 (Vector Word64 -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector Word64
wor)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Word64 -> Builder) -> Vector Word64 -> Builder
forall m a. (Monoid m, Unbox a) => (a -> m) -> Vector a -> m
V.foldMap' Word64 -> Builder
word64BE Vector Word64
wor

    -- Direct encoding without palette
    direct :: Vector a -> Builder
direct Vector a
vs =
      let p :: Vector Word64
p = Int -> Vector a -> Vector Word64
forall w c.
(FiniteBits w, Integral w, Unbox w, FiniteBits c, Integral c,
 Unbox c) =>
Int -> Vector c -> Vector w
pkbv (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
directbpe) Vector a
vs
       in Word8 -> Builder
word8 Word8
directbpe -- Format: [bpe][length]
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall {a}. Integral a => a -> Builder
packleb32 (Vector Word64 -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector Word64
p) -- [raw values...]
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Word64 -> Builder) -> Vector Word64 -> Builder
forall m a. (Monoid m, Unbox a) => (a -> m) -> Vector a -> m
V.foldMap' (forall a. Pack a => a -> Builder
pack @Word64) Vector Word64
p

    -- Try to create an efficient palette
    computepalette :: Vector a -> Maybe (Int, IntMap Int, Builder)
computepalette Vector a
vs =
      let (IntMap Int
m', Builder
l') = ((IntMap Int, Builder) -> a -> (IntMap Int, Builder))
-> (IntMap Int, Builder) -> Vector a -> (IntMap Int, Builder)
forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
V.foldl' (IntMap Int, Builder) -> a -> (IntMap Int, Builder)
forall {a}.
Integral a =>
(IntMap Int, Builder) -> a -> (IntMap Int, Builder)
f (IntMap Int
forall a. IntMap a
M.empty, Builder
"") Vector a
vs
          f :: (IntMap Int, Builder) -> a -> (IntMap Int, Builder)
f (IntMap Int
m, Builder
l) (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
v) -- Build palette map and entry list
            | Int
v Int -> IntMap Int -> Bool
forall a. Int -> IntMap a -> Bool
`M.member` IntMap Int
m = (IntMap Int
m, Builder
l) -- Skip if value already in palette
            | Bool
otherwise = (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
v (IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m) IntMap Int
m, Builder
l Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall {a}. Integral a => a -> Builder
packleb32 Int
v)
          lowlim' :: Int
lowlim' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lowlim
          upplim' :: Int
upplim' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
upplim
       in if
            | IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -> (Int, IntMap Int, Builder) -> Maybe (Int, IntMap Int, Builder)
forall a. a -> Maybe a
Just (IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m', IntMap Int
m', Builder
l') -- single-value mode
            | IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
1 Int
lowlim' -> -- Pad to minimum size
                let re :: Builder
re = (Word8 -> Builder) -> [Word8] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Word8 -> Builder
word8 do
                      Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take (Int
lowlim' Int -> Int -> Int
forall a. Num a => a -> a -> a
- IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m') (Word8 -> [Word8]
forall a. a -> [a]
repeat Word8
0)
                 in (Int, IntMap Int, Builder) -> Maybe (Int, IntMap Int, Builder)
forall a. a -> Maybe a
Just (Int
lowlim', IntMap Int
m', Builder
l' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
re)
            | IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
1 Int
upplim' -> Maybe (Int, IntMap Int, Builder)
forall a. Maybe a
Nothing -- Too many uniques
            | Bool
otherwise -> (Int, IntMap Int, Builder) -> Maybe (Int, IntMap Int, Builder)
forall a. a -> Maybe a
Just (IntMap Int -> Int
forall a. IntMap a -> Int
M.size IntMap Int
m', IntMap Int
m', Builder
l') -- Just right

-- | Decode values from a paletted container
--
-- == Usage
--
-- Plug in the first argument ('MkCodec' configuration) and store the
-- closure in a variable. This closure is the actual decoder function.
-- Then, use the closure to decode values.
mkdecoder ::
  (Integral a, FiniteBits a, V.Unbox a) =>
  MkCodec ->
  Parser st r (V.Vector a)
mkdecoder :: forall a (st :: ZeroBitType) r.
(Integral a, FiniteBits a, Unbox a) =>
MkCodec -> Parser st r (Vector a)
mkdecoder MkCodec {Int
Word8
lowlim :: MkCodec -> Word8
upplim :: MkCodec -> Word8
directbpe :: MkCodec -> Word8
singlecount :: MkCodec -> Int
lowlim :: Word8
upplim :: Word8
directbpe :: Word8
singlecount :: Int
..} = ParserT st r ParseError (Vector a)
choose1
  where
    -- Main decoder selection based on bits-per-entry (bpe)
    choose1 :: ParserT st r ParseError (Vector a)
choose1 = do
      Word8
bpe <- forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack @Word8
      if
        -- Select encoding format based on bpe value
        | Word8
bpe Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 -> ParserT st r ParseError (Vector a)
single -- Single value encoding
        | Word8
bpe Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
upplim -> ParserT st r ParseError (Vector a)
direct -- Direct encoding
        | Bool
otherwise -> Word8 -> ParserT st r ParseError (Vector a)
paletted Word8
bpe -- Palette encoding

    -- Single value format: [0][value][0] -> replicate value n times
    single :: ParserT st r ParseError (Vector a)
single = do
      a
value <- Parser st r a
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 -- Read the single value
      ParserT st r ParseError ()
-> ParseError -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
F.cut (Word8 -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e. Word8 -> ParserT st r e ()
F.word8 Word8
0) ParseError
"mkdecoder/single: data array length is not zero"
      Vector a -> ParserT st r ParseError (Vector a)
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector a -> ParserT st r ParseError (Vector a))
-> Vector a -> ParserT st r ParseError (Vector a)
forall a b. (a -> b) -> a -> b
$ Int -> a -> Vector a
forall a. Unbox a => Int -> a -> Vector a
V.replicate Int
singlecount a
value

    -- Palette encoding: [bpe][palsize][pal...][count][packed...]
    paletted :: Word8 -> ParserT st r ParseError (Vector a)
paletted (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> (Word8 -> Word8) -> Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a
max Word8
lowlim -> Int
bpe) = do
      Int
pln <- Parser st r Int
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 Parser st r Int -> (Int -> Parser st r Int) -> Parser st r Int
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Int -> Parser st r Int
forall a (st :: ZeroBitType) r.
(Num a, Ord a, Show a) =>
String -> a -> Parser st r a
guardnat String
"mkdecoder/paletted: palette length"
      Vector a
pal <- Int -> Parser st r a -> ParserT st r ParseError (Vector a)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
V.replicateM Int
pln Parser st r a
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 -- Read palette entries
      Int
longs <- Parser st r Int
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 Parser st r Int -> (Int -> Parser st r Int) -> Parser st r Int
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Int -> Parser st r Int
forall a (st :: ZeroBitType) r.
(Num a, Ord a, Show a) =>
String -> a -> Parser st r a
guardnat String
"mkdecoder/paletted: # of longs"
      -- Read packed words, unpack bits, map through palette
      (Int -> a) -> Vector Int -> Vector a
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
V.map (Vector a
pal V.!) (Vector Int -> Vector a)
-> (Vector Word64 -> Vector Int) -> Vector Word64 -> Vector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Vector Word64 -> Vector Int
forall w c.
(FiniteBits w, Integral w, Unbox w, FiniteBits c, Integral c,
 Unbox c) =>
Int -> Vector w -> Vector c
upbv Int
bpe (Vector Word64 -> Vector a)
-> ParserT st r ParseError (Vector Word64)
-> ParserT st r ParseError (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParserT st r ParseError Word64
-> ParserT st r ParseError (Vector Word64)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
V.replicateM Int
longs (forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack @Word64)

    -- Direct encoding format: [bpe][count][value1][value2]...
    direct :: ParserT st r ParseError (Vector a)
direct = do
      Int
nlongs <- Parser st r Int
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 Parser st r Int -> (Int -> Parser st r Int) -> Parser st r Int
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Parser st r Int
forall {a} {st :: ZeroBitType} {r}.
(Ord a, Num a, Show a) =>
a -> ParserT st r ParseError a
checklongs -- Read # of 64-bit words
      Int -> Vector Word64 -> Vector a
forall w c.
(FiniteBits w, Integral w, Unbox w, FiniteBits c, Integral c,
 Unbox c) =>
Int -> Vector w -> Vector c
upbv (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
directbpe) (Vector Word64 -> Vector a)
-> ParserT st r ParseError (Vector Word64)
-> ParserT st r ParseError (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParserT st r ParseError Word64
-> ParserT st r ParseError (Vector Word64)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
V.replicateM Int
nlongs (forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack @Word64)
      where
        -- Safety check for number of words
        checklongs :: a -> ParserT st r ParseError a
checklongs a
n
          | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = ParseError -> ParserT st r ParseError a
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err ParseError
"mkdecoder/direct: negative longs"
          | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
2048 = a -> ParserT st r ParseError a
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
n -- Arbitrary size limit
          | Bool
otherwise = ParseError -> ParserT st r ParseError a
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err (ParseError -> ParserT st r ParseError a)
-> ParseError -> ParserT st r ParseError a
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError do
              String
"mkdecoder/direct: too many longs (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

-- | unpack a paletted container
-- (Minecraft, Java Edition, padded words).
--
-- see also: 'pkbv'.
upbv ::
  forall w c.
  ( FiniteBits w,
    Integral w,
    V.Unbox w,
    FiniteBits c,
    Integral c,
    V.Unbox c
  ) =>
  Int -> V.Vector w -> V.Vector c
upbv :: forall w c.
(FiniteBits w, Integral w, Unbox w, FiniteBits c, Integral c,
 Unbox c) =>
Int -> Vector w -> Vector c
upbv Int
b = Vector w -> Vector c
e
  where
    e :: Vector w -> Vector c
e
      | Int
wsz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
csz = String -> Vector w -> Vector c
forall a. HasCallStack => String -> a
error String
"upbv: incorrect bit combination"
      | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
csz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b = String -> Vector w -> Vector c
forall a. HasCallStack => String -> a
error String
"upbv: incorrect bits per entry"
      | Bool
otherwise = \Vector w
words ->
          let m :: w
m = w -> Int -> w
forall a. Bits a => a -> Int -> a
unsafeShiftL w
1 Int
b w -> w -> w
forall a. Num a => a -> a -> a
- w
1
              len :: Int
len = Vector w -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector w
words Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cpw
              cpw :: Int
cpw = Int
wsz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
b
              fi :: w -> c
fi = forall a b. (Integral a, Num b) => a -> b
fromIntegral @w @c
           in Int -> (Int -> c) -> Vector c
forall a. Unbox a => Int -> (Int -> a) -> Vector a
V.generate Int
len \Int
i ->
                let w :: Int
w = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
cpw
                    c :: Int
c = Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
cpw)
                 in w -> c
fi (w -> c) -> w -> c
forall a b. (a -> b) -> a -> b
$ ((Vector w
words Vector w -> Int -> w
forall a. Unbox a => Vector a -> Int -> a
V.! Int
w) w -> Int -> w
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
c) w -> w -> w
forall a. Bits a => a -> a -> a
.&. w
m
    wsz :: Int
wsz = w -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (w
forall a. HasCallStack => a
undefined :: w)
    csz :: Int
csz = c -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (c
forall a. HasCallStack => a
undefined :: c)

data S a = S !Int !a -- shift, accumulator

uns :: S a -> a
uns :: forall a. S a -> a
uns (S Int
_ a
a) = a
a

-- | pack bits into a paletted container (list of words).
--
-- see also: 'upb'.
pkbv ::
  forall w c.
  (FiniteBits w, Integral w, V.Unbox w, FiniteBits c, Integral c, V.Unbox c) =>
  -- | bits per entry
  Int ->
  -- | chars; least significant char first.
  V.Vector c ->
  -- | words; least significant word first.
  V.Vector w
pkbv :: forall w c.
(FiniteBits w, Integral w, Unbox w, FiniteBits c, Integral c,
 Unbox c) =>
Int -> Vector c -> Vector w
pkbv Int
b = Vector c -> Vector w
e
  where
    e :: Vector c -> Vector w
e
      | Int
wsz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
csz = String -> Vector c -> Vector w
forall a. HasCallStack => String -> a
error String
"pkbv: incorrect bit combination"
      | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
csz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b = String -> Vector c -> Vector w
forall a. HasCallStack => String -> a
error String
"pkbv: incorrect bits per entry"
      | Bool
otherwise = \Vector c
chars ->
          let cpw :: Int
cpw = Int
wsz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
b
              w :: Int
w = (Vector c -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector c
chars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cpw Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
cpw
              f :: S w -> c -> S w
f (S Int
s w
a) (c -> w
fi -> w
q) = Int -> w -> S w
forall a. Int -> a -> S a
S (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) (w
a w -> w -> w
forall a. Bits a => a -> a -> a
.|. w -> Int -> w
forall a. Bits a => a -> Int -> a
unsafeShiftL w
q Int
s)
           in Int -> (Int -> w) -> Vector w
forall a. Unbox a => Int -> (Int -> a) -> Vector a
V.generate Int
w \Int
i -> S w -> w
forall a. S a -> a
uns do
                let j :: Int
j = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cpw
                    l :: Int
l = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
cpw (Vector c -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector c
chars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cpw)
                 in (S w -> c -> S w) -> S w -> Vector c -> S w
forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
V.foldl' S w -> c -> S w
f (Int -> w -> S w
forall a. Int -> a -> S a
S Int
0 w
0) (Vector c -> S w) -> Vector c -> S w
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector c -> Vector c
forall a. Unbox a => Int -> Int -> Vector a -> Vector a
V.slice Int
j Int
l Vector c
chars
    wsz :: Int
wsz = w -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (w
forall a. HasCallStack => a
undefined :: w)
    csz :: Int
csz = c -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (c
forall a. HasCallStack => a
undefined :: c)
    fi :: c -> w
fi = forall a b. (Integral a, Num b) => a -> b
fromIntegral @c @w