module Rattletrap.Type.CompressedWord where

import qualified Data.Bits as Bits
import qualified Rattletrap.BitGet as BitGet
import qualified Rattletrap.BitPut as BitPut
import qualified Rattletrap.Schema as Schema
import qualified Rattletrap.Utility.Json as Json

-- | Although there's no guarantee that these values will not overflow, it's
-- exceptionally unlikely. Most 'CompressedWord's are very small.
data CompressedWord = CompressedWord
  { CompressedWord -> Word
limit :: Word,
    CompressedWord -> Word
value :: Word
  }
  deriving (CompressedWord -> CompressedWord -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompressedWord -> CompressedWord -> Bool
$c/= :: CompressedWord -> CompressedWord -> Bool
== :: CompressedWord -> CompressedWord -> Bool
$c== :: CompressedWord -> CompressedWord -> Bool
Eq, Eq CompressedWord
CompressedWord -> CompressedWord -> Bool
CompressedWord -> CompressedWord -> Ordering
CompressedWord -> CompressedWord -> CompressedWord
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
min :: CompressedWord -> CompressedWord -> CompressedWord
$cmin :: CompressedWord -> CompressedWord -> CompressedWord
max :: CompressedWord -> CompressedWord -> CompressedWord
$cmax :: CompressedWord -> CompressedWord -> CompressedWord
>= :: CompressedWord -> CompressedWord -> Bool
$c>= :: CompressedWord -> CompressedWord -> Bool
> :: CompressedWord -> CompressedWord -> Bool
$c> :: CompressedWord -> CompressedWord -> Bool
<= :: CompressedWord -> CompressedWord -> Bool
$c<= :: CompressedWord -> CompressedWord -> Bool
< :: CompressedWord -> CompressedWord -> Bool
$c< :: CompressedWord -> CompressedWord -> Bool
compare :: CompressedWord -> CompressedWord -> Ordering
$ccompare :: CompressedWord -> CompressedWord -> Ordering
Ord, Int -> CompressedWord -> ShowS
[CompressedWord] -> ShowS
CompressedWord -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompressedWord] -> ShowS
$cshowList :: [CompressedWord] -> ShowS
show :: CompressedWord -> String
$cshow :: CompressedWord -> String
showsPrec :: Int -> CompressedWord -> ShowS
$cshowsPrec :: Int -> CompressedWord -> ShowS
Show)

instance Json.FromJSON CompressedWord where
  parseJSON :: Value -> Parser CompressedWord
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Json.withObject String
"CompressedWord" forall a b. (a -> b) -> a -> b
$ \Object
object -> do
    Word
limit <- forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"limit"
    Word
value <- forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"value"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure CompressedWord {Word
limit :: Word
limit :: Word
limit, Word
value :: Word
value :: Word
value}

instance Json.ToJSON CompressedWord where
  toJSON :: CompressedWord -> Value
toJSON CompressedWord
x =
    [(Key, Value)] -> Value
Json.object [forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"limit" forall a b. (a -> b) -> a -> b
$ CompressedWord -> Word
limit CompressedWord
x, forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"value" forall a b. (a -> b) -> a -> b
$ CompressedWord -> Word
value CompressedWord
x]

schema :: Schema.Schema
schema :: Schema
schema =
  String -> Value -> Schema
Schema.named String
"compressedWord" forall a b. (a -> b) -> a -> b
$
    [((Key, Value), Bool)] -> Value
Schema.object
      [ (forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"limit" forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Value
Json.object [forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"type" String
"integer"], Bool
True),
        (forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"value" forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Value
Json.object [forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"type" String
"integer"], Bool
True)
      ]

bitPut :: CompressedWord -> BitPut.BitPut
bitPut :: CompressedWord -> BitPut
bitPut CompressedWord
compressedWord =
  let limit_ :: Word
limit_ = CompressedWord -> Word
limit CompressedWord
compressedWord
      value_ :: Word
value_ = CompressedWord -> Word
value CompressedWord
compressedWord
      maxBits :: Int
maxBits = Word -> Int
getMaxBits Word
limit_
   in Word -> Word -> Int -> Int -> Word -> BitPut
putCompressedWordStep Word
limit_ Word
value_ Int
maxBits Int
0 Word
0

putCompressedWordStep :: Word -> Word -> Int -> Int -> Word -> BitPut.BitPut
putCompressedWordStep :: Word -> Word -> Int -> Int -> Word -> BitPut
putCompressedWordStep Word
limit_ Word
value_ Int
maxBits Int
position Word
soFar =
  if Int
position forall a. Ord a => a -> a -> Bool
< Int
maxBits
    then do
      let x :: Word
x = forall a. Bits a => a -> Int -> a
Bits.shiftL Word
1 Int
position :: Word
      if Int
maxBits forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
position forall a. Eq a => a -> a -> Bool
== Int
maxBits forall a. Num a => a -> a -> a
- Int
1 Bool -> Bool -> Bool
&& Word
soFar forall a. Num a => a -> a -> a
+ Word
x forall a. Ord a => a -> a -> Bool
> Word
limit_
        then forall a. Monoid a => a
mempty
        else
          let bit :: Bool
bit = forall a. Bits a => a -> Int -> Bool
Bits.testBit Word
value_ Int
position
              delta :: Word
delta = if Bool
bit then Word
x else Word
0
           in Bool -> BitPut
BitPut.bool Bool
bit
                forall a. Semigroup a => a -> a -> a
<> Word -> Word -> Int -> Int -> Word -> BitPut
putCompressedWordStep
                  Word
limit_
                  Word
value_
                  Int
maxBits
                  (Int
position forall a. Num a => a -> a -> a
+ Int
1)
                  (Word
soFar forall a. Num a => a -> a -> a
+ Word
delta)
    else forall a. Monoid a => a
mempty

getMaxBits :: Word -> Int
getMaxBits :: Word -> Int
getMaxBits Word
x =
  let n :: Int
      n :: Int
n = forall a. Ord a => a -> a -> a
max Int
1 (forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Floating a => a -> a -> a
logBase (Double
2 :: Double) (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Ord a => a -> a -> a
max Word
1 Word
x))))
   in if Word
x forall a. Ord a => a -> a -> Bool
< Word
1024 Bool -> Bool -> Bool
&& Word
x forall a. Eq a => a -> a -> Bool
== Word
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
n then Int
n forall a. Num a => a -> a -> a
+ Int
1 else Int
n

bitGet :: Word -> BitGet.BitGet CompressedWord
bitGet :: Word -> BitGet CompressedWord
bitGet = Word -> BitGet CompressedWord
bitGetNew

bitGetNew :: Word -> BitGet.BitGet CompressedWord
bitGetNew :: Word -> BitGet CompressedWord
bitGetNew Word
limit = do
  Word
value <-
    if Word
limit forall a. Ord a => a -> a -> Bool
< Word
1
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0
      else do
        let numBits :: Int
numBits =
              forall a. Ord a => a -> a -> a
max (Int
0 :: Int)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Int
1
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a -> a
logBase (Double
2 :: Double)
                forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
limit
        Word
partial <- forall a. Bits a => Int -> BitGet a
BitGet.bits Int
numBits
        let next :: Word
next = Word
partial forall a. Num a => a -> a -> a
+ forall a. Bits a => a -> Int -> a
Bits.shiftL Word
1 Int
numBits
        if Word
next forall a. Ord a => a -> a -> Bool
> Word
limit
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
partial
          else do
            Bool
x <- BitGet Bool
BitGet.bool
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
x then Word
next else Word
partial
  forall (f :: * -> *) a. Applicative f => a -> f a
pure CompressedWord {Word
limit :: Word
limit :: Word
limit, Word
value :: Word
value :: Word
value}