module Rattletrap.Type.Quaternion where

import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Ord as Ord
import qualified Rattletrap.BitGet as BitGet
import qualified Rattletrap.BitPut as BitPut
import qualified Rattletrap.Exception.InvalidComponent as InvalidComponent
import qualified Rattletrap.Schema as Schema
import qualified Rattletrap.Type.CompressedWord as CompressedWord
import qualified Rattletrap.Utility.Json as Json

data Quaternion = Quaternion
  { Quaternion -> Double
x :: Double
  , Quaternion -> Double
y :: Double
  , Quaternion -> Double
z :: Double
  , Quaternion -> Double
w :: Double
  }
  deriving (Quaternion -> Quaternion -> Bool
(Quaternion -> Quaternion -> Bool)
-> (Quaternion -> Quaternion -> Bool) -> Eq Quaternion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Quaternion -> Quaternion -> Bool
$c/= :: Quaternion -> Quaternion -> Bool
== :: Quaternion -> Quaternion -> Bool
$c== :: Quaternion -> Quaternion -> Bool
Eq, Int -> Quaternion -> ShowS
[Quaternion] -> ShowS
Quaternion -> String
(Int -> Quaternion -> ShowS)
-> (Quaternion -> String)
-> ([Quaternion] -> ShowS)
-> Show Quaternion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Quaternion] -> ShowS
$cshowList :: [Quaternion] -> ShowS
show :: Quaternion -> String
$cshow :: Quaternion -> String
showsPrec :: Int -> Quaternion -> ShowS
$cshowsPrec :: Int -> Quaternion -> ShowS
Show)

instance Json.FromJSON Quaternion where
  parseJSON :: Value -> Parser Quaternion
parseJSON = String
-> (Object -> Parser Quaternion) -> Value -> Parser Quaternion
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Json.withObject String
"Quaternion" ((Object -> Parser Quaternion) -> Value -> Parser Quaternion)
-> (Object -> Parser Quaternion) -> Value -> Parser Quaternion
forall a b. (a -> b) -> a -> b
$ \Object
object -> do
    Double
x <- Object -> String -> Parser Double
forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"x"
    Double
y <- Object -> String -> Parser Double
forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"y"
    Double
z <- Object -> String -> Parser Double
forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"z"
    Double
w <- Object -> String -> Parser Double
forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"w"
    Quaternion -> Parser Quaternion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Quaternion :: Double -> Double -> Double -> Double -> Quaternion
Quaternion { Double
x :: Double
x :: Double
x, Double
y :: Double
y :: Double
y, Double
z :: Double
z :: Double
z, Double
w :: Double
w :: Double
w }

instance Json.ToJSON Quaternion where
  toJSON :: Quaternion -> Value
toJSON Quaternion
a = [Pair] -> Value
Json.object
    [ String -> Double -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"x" (Double -> Pair) -> Double -> Pair
forall a b. (a -> b) -> a -> b
$ Quaternion -> Double
x Quaternion
a
    , String -> Double -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"y" (Double -> Pair) -> Double -> Pair
forall a b. (a -> b) -> a -> b
$ Quaternion -> Double
y Quaternion
a
    , String -> Double -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"z" (Double -> Pair) -> Double -> Pair
forall a b. (a -> b) -> a -> b
$ Quaternion -> Double
z Quaternion
a
    , String -> Double -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"w" (Double -> Pair) -> Double -> Pair
forall a b. (a -> b) -> a -> b
$ Quaternion -> Double
w Quaternion
a
    ]

schema :: Schema.Schema
schema :: Schema
schema = String -> Value -> Schema
Schema.named String
"quaternion" (Value -> Schema) -> Value -> Schema
forall a b. (a -> b) -> a -> b
$ [(Pair, Bool)] -> Value
Schema.object
  [ (String -> Value -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"x" (Value -> Pair) -> Value -> Pair
forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
Schema.number, Bool
True)
  , (String -> Value -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"y" (Value -> Pair) -> Value -> Pair
forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
Schema.number, Bool
True)
  , (String -> Value -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"z" (Value -> Pair) -> Value -> Pair
forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
Schema.number, Bool
True)
  , (String -> Value -> Pair
forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"w" (Value -> Pair) -> Value -> Pair
forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
Schema.number, Bool
True)
  ]

data Component
  = X
  | Y
  | Z
  | W
  deriving (Component -> Component -> Bool
(Component -> Component -> Bool)
-> (Component -> Component -> Bool) -> Eq Component
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Component -> Component -> Bool
$c/= :: Component -> Component -> Bool
== :: Component -> Component -> Bool
$c== :: Component -> Component -> Bool
Eq, Int -> Component -> ShowS
[Component] -> ShowS
Component -> String
(Int -> Component -> ShowS)
-> (Component -> String)
-> ([Component] -> ShowS)
-> Show Component
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Component] -> ShowS
$cshowList :: [Component] -> ShowS
show :: Component -> String
$cshow :: Component -> String
showsPrec :: Int -> Component -> ShowS
$cshowsPrec :: Int -> Component -> ShowS
Show)

toQuaternion :: Component -> Double -> Double -> Double -> Quaternion
toQuaternion :: Component -> Double -> Double -> Double -> Quaternion
toQuaternion Component
component Double
a Double
b Double
c =
  let d :: Double
d = Double -> Double -> Double -> Double
toPart Double
a Double
b Double
c
  in
    case Component
component of
      Component
X -> Double -> Double -> Double -> Double -> Quaternion
Quaternion Double
d Double
a Double
b Double
c
      Component
Y -> Double -> Double -> Double -> Double -> Quaternion
Quaternion Double
a Double
d Double
b Double
c
      Component
Z -> Double -> Double -> Double -> Double -> Quaternion
Quaternion Double
a Double
b Double
d Double
c
      Component
W -> Double -> Double -> Double -> Double -> Quaternion
Quaternion Double
a Double
b Double
c Double
d

toPart :: Double -> Double -> Double -> Double
toPart :: Double -> Double -> Double -> Double
toPart Double
a Double
b Double
c = Double -> Double
forall a. Floating a => a -> a
sqrt (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
b) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c))

compressPart :: Double -> CompressedWord.CompressedWord
compressPart :: Double -> CompressedWord
compressPart =
  Word -> Word -> CompressedWord
CompressedWord.CompressedWord Word
maxCompressedValue
    (Word -> CompressedWord)
-> (Double -> Word) -> Double -> CompressedWord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word
forall a b. (RealFrac a, Integral b) => a -> b
round
    (Double -> Word) -> (Double -> Double) -> Double -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word -> Double
wordToDouble Word
maxCompressedValue)
    (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5)
    (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0)
    (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
maxValue)

decompressPart :: CompressedWord.CompressedWord -> Double
decompressPart :: CompressedWord -> Double
decompressPart CompressedWord
x_ =
  (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
maxValue)
    (Double -> Double) -> (Word -> Double) -> Word -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2.0)
    (Double -> Double) -> (Word -> Double) -> Word -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Num a => a -> a -> a
subtract Double
0.5
    (Double -> Double) -> (Word -> Double) -> Word -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word -> Double
wordToDouble (CompressedWord -> Word
CompressedWord.limit CompressedWord
x_))
    (Double -> Double) -> (Word -> Double) -> Word -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Double
wordToDouble
    (Word -> Double) -> Word -> Double
forall a b. (a -> b) -> a -> b
$ CompressedWord -> Word
CompressedWord.value CompressedWord
x_

maxComponent :: Quaternion -> Component
maxComponent :: Quaternion -> Component
maxComponent Quaternion
quaternion =
  let
    x_ :: Double
x_ = Quaternion -> Double
x Quaternion
quaternion
    y_ :: Double
y_ = Quaternion -> Double
y Quaternion
quaternion
    z_ :: Double
z_ = Quaternion -> Double
z Quaternion
quaternion
    w_ :: Double
w_ = Quaternion -> Double
w Quaternion
quaternion
    parts :: [(Double, Component)]
parts = [(Double
x_, Component
X), (Double
y_, Component
Y), (Double
z_, Component
Z), (Double
w_, Component
W)]
    biggestPart :: (Double, Component)
biggestPart = ((Double, Component) -> Double)
-> [(Double, Component)] -> (Double, Component)
forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> a
maximumOn (Double, Component) -> Double
forall a b. (a, b) -> a
fst [(Double, Component)]
parts
    roundTrip :: Double -> Double
roundTrip = CompressedWord -> Double
decompressPart (CompressedWord -> Double)
-> (Double -> CompressedWord) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CompressedWord
compressPart
    computedPart :: (Double, Component)
computedPart = (Double, Component)
-> Maybe (Double, Component) -> (Double, Component)
forall a. a -> Maybe a -> a
Maybe.fromMaybe
      (Double, Component)
biggestPart
      (((Double, Component) -> Bool)
-> [(Double, Component)] -> Maybe (Double, Component)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(Double
value, Component
_) -> Double
value Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Double
roundTrip Double
value) [(Double, Component)]
parts)
  in (Double, Component) -> Component
forall a b. (a, b) -> b
snd
    (if ((Double, Component)
biggestPart (Double, Component) -> (Double, Component) -> Bool
forall a. Eq a => a -> a -> Bool
== (Double, Component)
computedPart)
        Bool -> Bool -> Bool
|| (Double -> Double
forall a. Num a => a -> a
abs ((Double, Component) -> Double
forall a b. (a, b) -> a
fst (Double, Component)
biggestPart Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double, Component) -> Double
forall a b. (a, b) -> a
fst (Double, Component)
computedPart) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0.00001)
      then (Double, Component)
biggestPart
      else (Double, Component)
computedPart
    )

maximumOn :: (Foldable t, Ord b) => (a -> b) -> t a -> a
maximumOn :: (a -> b) -> t a -> a
maximumOn a -> b
f = (a -> a -> Ordering) -> t a -> a
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.maximumBy ((a -> b) -> a -> a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Ord.comparing a -> b
f)

numBits :: Word
numBits :: Word
numBits = Word
18

wordToDouble :: Word -> Double
wordToDouble :: Word -> Double
wordToDouble = Word -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral

maxCompressedValue :: Word
maxCompressedValue :: Word
maxCompressedValue = (Word
2 Word -> Word -> Word
forall a b. (Num a, Integral b) => a -> b -> a
^ Word
numBits) Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1

maxValue :: Double
maxValue :: Double
maxValue = Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt Double
2.0

bitPut :: Quaternion -> BitPut.BitPut
bitPut :: Quaternion -> BitPut
bitPut Quaternion
q =
  let c :: Component
c = Quaternion -> Component
maxComponent Quaternion
q
  in
    Component -> BitPut
putComponent Component
c BitPut -> BitPut -> BitPut
forall a. Semigroup a => a -> a -> a
<> case Component
c of
      Component
X -> Double -> Double -> Double -> BitPut
putParts (Quaternion -> Double
y Quaternion
q) (Quaternion -> Double
z Quaternion
q) (Quaternion -> Double
w Quaternion
q)
      Component
Y -> Double -> Double -> Double -> BitPut
putParts (Quaternion -> Double
x Quaternion
q) (Quaternion -> Double
z Quaternion
q) (Quaternion -> Double
w Quaternion
q)
      Component
Z -> Double -> Double -> Double -> BitPut
putParts (Quaternion -> Double
x Quaternion
q) (Quaternion -> Double
y Quaternion
q) (Quaternion -> Double
w Quaternion
q)
      Component
W -> Double -> Double -> Double -> BitPut
putParts (Quaternion -> Double
x Quaternion
q) (Quaternion -> Double
y Quaternion
q) (Quaternion -> Double
z Quaternion
q)

putComponent :: Component -> BitPut.BitPut
putComponent :: Component -> BitPut
putComponent Component
component = CompressedWord -> BitPut
CompressedWord.bitPut
  (Word -> Word -> CompressedWord
CompressedWord.CompressedWord
    Word
3
    (case Component
component of
      Component
X -> Word
0
      Component
Y -> Word
1
      Component
Z -> Word
2
      Component
W -> Word
3
    )
  )

putParts :: Double -> Double -> Double -> BitPut.BitPut
putParts :: Double -> Double -> Double -> BitPut
putParts Double
a Double
b Double
c = Double -> BitPut
putPart Double
a BitPut -> BitPut -> BitPut
forall a. Semigroup a => a -> a -> a
<> Double -> BitPut
putPart Double
b BitPut -> BitPut -> BitPut
forall a. Semigroup a => a -> a -> a
<> Double -> BitPut
putPart Double
c

putPart :: Double -> BitPut.BitPut
putPart :: Double -> BitPut
putPart = CompressedWord -> BitPut
CompressedWord.bitPut (CompressedWord -> BitPut)
-> (Double -> CompressedWord) -> Double -> BitPut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CompressedWord
compressPart

bitGet :: BitGet.BitGet Quaternion
bitGet :: BitGet Quaternion
bitGet = do
  Component
component <- BitGet Component
decodeComponent
  Double
a <- BitGet Double
decodePart
  Double
b <- BitGet Double
decodePart
  Double
c <- BitGet Double
decodePart
  Quaternion -> BitGet Quaternion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quaternion -> BitGet Quaternion)
-> Quaternion -> BitGet Quaternion
forall a b. (a -> b) -> a -> b
$ Component -> Double -> Double -> Double -> Quaternion
toQuaternion Component
component Double
a Double
b Double
c

decodeComponent :: BitGet.BitGet Component
decodeComponent :: BitGet Component
decodeComponent = do
  CompressedWord
x_ <- Word -> BitGet CompressedWord
CompressedWord.bitGet Word
3
  case CompressedWord -> Word
CompressedWord.value CompressedWord
x_ of
    Word
0 -> Component -> BitGet Component
forall (f :: * -> *) a. Applicative f => a -> f a
pure Component
X
    Word
1 -> Component -> BitGet Component
forall (f :: * -> *) a. Applicative f => a -> f a
pure Component
Y
    Word
2 -> Component -> BitGet Component
forall (f :: * -> *) a. Applicative f => a -> f a
pure Component
Z
    Word
3 -> Component -> BitGet Component
forall (f :: * -> *) a. Applicative f => a -> f a
pure Component
W
    Word
y_ -> InvalidComponent -> BitGet Component
forall e a. Exception e => e -> BitGet a
BitGet.throw (InvalidComponent -> BitGet Component)
-> InvalidComponent -> BitGet Component
forall a b. (a -> b) -> a -> b
$ Word -> InvalidComponent
InvalidComponent.InvalidComponent Word
y_

decodePart :: BitGet.BitGet Double
decodePart :: BitGet Double
decodePart = (CompressedWord -> Double)
-> BitGet CompressedWord -> BitGet Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompressedWord -> Double
decompressPart (BitGet CompressedWord -> BitGet Double)
-> BitGet CompressedWord -> BitGet Double
forall a b. (a -> b) -> a -> b
$ Word -> BitGet CompressedWord
CompressedWord.bitGet Word
maxCompressedValue