{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE UnboxedTuples       #-}
{-# LANGUAGE ViewPatterns        #-}
module Numeric.Quaternion.Internal
    ( Quaternion (..), Quater(Quater)
    ) where

import Numeric.DataFrame.Type  (KnownBackend)
import Numeric.Matrix.Internal (Matrix)
import Numeric.PrimBytes       (PrimBytes)
import Numeric.Vector.Internal (Vector)
import Text.Read

-- | @(x,y,z,w)@ of a quaternion
pattern Quater :: Quaternion t => t -> t -> t -> t -> Quater t
pattern $bQuater :: t -> t -> t -> t -> Quater t
$mQuater :: forall r t.
Quaternion t =>
Quater t -> (t -> t -> t -> t -> r) -> (Void# -> r) -> r
Quater a b c d <- (unpackQ# -> (# a, b, c, d #))
  where
    Quater = t -> t -> t -> t -> Quater t
forall t. Quaternion t => t -> t -> t -> t -> Quater t
packQ
{-# COMPLETE Quater #-}

-- | Quaternion operations
class ( Floating (Quater t), Floating t, Ord t, PrimBytes t
      , KnownBackend t '[3], KnownBackend t '[4]
      , KnownBackend t '[3,3], KnownBackend t '[4, 4]
      ) => Quaternion t where
    -- | Quaternion data type. The ordering of coordinates is @(x,y,z,w)@,
    --   where @w@ is the argument, and @x y z@ are the components of a 3D vector
    data Quater t
    -- | Set the quaternion in format @(x,y,z,w)@
    packQ :: t -> t -> t -> t -> Quater t
    -- | Get the values of the quaternion in format @(x,y,z,w)@
    unpackQ# :: Quater t -> (# t, t, t, t #)
    -- | Set the quaternion from 3D axis vector and argument
    fromVecNum :: Vector t 3 -> t -> Quater t
    -- | Set the quaternion from 4D vector in format @(x,y,z,w)@
    fromVec4 :: Vector t 4 -> Quater t
    -- | Transform the quaternion to 4D vector in format @(x,y,z,w)@
    toVec4 :: Quater t -> Vector t 4
    -- | Get scalar square of the quaternion.
    --
    --   >>> realToFrac (square q) == q * conjugate q
    square :: Quater t -> t
    -- | Imaginary part of the quaternion (orientation vector)
    im :: Quater t -> Quater t
    -- | Real part of the quaternion
    re :: Quater t -> Quater t
    -- | Imaginary part of the quaternion as a 3D vector
    imVec :: Quater t -> Vector t 3
    -- | Real part of the quaternion as a scalar
    taker :: Quater t -> t
    -- | i-th component
    takei :: Quater t -> t
    -- | j-th component
    takej :: Quater t -> t
    -- | k-th component
    takek :: Quater t -> t
    -- | Conjugate quaternion (negate imaginary part)
    conjugate :: Quater t -> Quater t
    -- | Rotates and scales vector in 3D using quaternion.
    --   Let \( q = c (\cos \frac{\alpha}{2}, v \sin \frac{\alpha}{2}) \)
    --     , \( c > 0 \), \( {|v|}^2 = 1 \);
    --   then the rotation angle is \( \alpha \), and the axis of rotation is \(v\).
    --   Scaling is proportional to \( c^2 \).
    --
    --   >>> rotScale q x == q * x * (conjugate q)
    rotScale :: Quater t -> Vector t 3 -> Vector t 3
    -- | Creates a quaternion @q@ from two vectors @a@ and @b@,
    --   such that @rotScale q a == b@.
    getRotScale :: Vector t 3 -> Vector t 3 -> Quater t
    -- | Creates a rotation versor from an axis vector and an angle in radians.
    --   Result is always a unit quaternion (versor).
    --   If the argument vector is zero, then result is a real unit quaternion.
    axisRotation :: Vector t 3 -> t -> Quater t
    -- | Quaternion rotation angle \( \alpha \)
    --   (where \( q = c (\cos \frac{\alpha}{2},  v \sin \frac{\alpha}{2}) \)
    --     , \( c > 0 \), \( {|v|}^2 = 1 \)).
    --
    --   >>> q /= 0 ==> axisRotation (imVec q) (qArg q) == signum q
    qArg :: Quater t -> t
    -- | Create a quaternion from a rotation matrix.
    --   Note, that rotations of \(q\) and \(-q\) are equivalent, there result of this
    --   function may be ambiguious. Assume the sign of the result to be chosen arbitrarily.
    fromMatrix33 :: Matrix t 3 3 -> Quater t
    -- | Create a quaternion from a homogenious coordinates trasform matrix.
    --   Ignores matrix translation transform.
    --   Note, that rotations of \(q\) and \(-q\) are equivalent, there result of this
    --   function may be ambiguious. Assume the sign of the result to be chosen arbitrarily.
    fromMatrix44 :: Matrix t 4 4 -> Quater t
    -- | Create a rotation matrix from a quaternion.
    --   Note, that rotations of \(q\) and \(-q\) are equivalent, so the following property holds:
    --
    --   >>> toMatrix33 q == toMatrix33 (-q)
    toMatrix33 :: Quater t -> Matrix t 3 3
    -- | Create a homogenious coordinates trasform matrix from a quaternion.
    --   Translation of the output matrix is zero.
    --   Note, that rotations of \(q\) and \(-q\) are equivalent, so the following property holds:
    --
    --   >>> toMatrix44 q == toMatrix44 (-q)
    toMatrix44 :: Quater t -> Matrix t 4 4


instance (Show t, Quaternion t, Ord t, Num t) => Show (Quater t) where
    showsPrec :: Int -> Quater t -> ShowS
showsPrec Int
p (Quater t
x t
y t
z t
w)
        = case ShowState
finS of
            ShowState
SEmpty -> Char -> ShowS
showChar Char
'0'
            ShowState
Simple -> ShowS
finF
            ShowState
SParen -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6) ShowS
finF
      where
        (ShowState
finS, ShowS
finF) = ShowState -> [(t, Maybe Char)] -> (ShowState, ShowS)
go ShowState
SEmpty
          [(t
w, Maybe Char
forall a. Maybe a
Nothing), (t
x, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'i'), (t
y, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'j'), (t
z, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'k')]
        go :: ShowState -> [(t, Maybe Char)] -> (ShowState, ShowS)
        go :: ShowState -> [(t, Maybe Char)] -> (ShowState, ShowS)
go ShowState
s ((t
v,Maybe Char
l):[(t, Maybe Char)]
xs)
          | (ShowState
s0, ShowS
f0) <- ShowState -> t -> Maybe Char -> (ShowState, ShowS)
showComponent ShowState
s t
v Maybe Char
l
          , (ShowState
s', ShowS
f') <- ShowState -> [(t, Maybe Char)] -> (ShowState, ShowS)
go ShowState
s0 [(t, Maybe Char)]
xs
            = (ShowState
s', ShowS
f0 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
f')
        go ShowState
s [] = (ShowState
s, ShowS
forall a. a -> a
id)
        showLabel :: Maybe Char -> ShowS
showLabel Maybe Char
Nothing  = ShowS
forall a. a -> a
id
        showLabel (Just Char
c) = Char -> ShowS
showChar Char
c
        showComponent :: ShowState -> t -> Maybe Char -> (ShowState, ShowS)
        showComponent :: ShowState -> t -> Maybe Char -> (ShowState, ShowS)
showComponent ShowState
sState t
val Maybe Char
mLabel = case (ShowState
sState, t -> t -> Ordering
forall a. Ord a => a -> a -> Ordering
compare t
val t
0) of
          (ShowState
_     , Ordering
EQ) -> ( ShowState
sState, ShowS
forall a. a -> a
id )
          (ShowState
SEmpty, Ordering
GT) -> ( ShowState
Simple, t -> ShowS
forall a. Show a => a -> ShowS
shows t
val ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> ShowS
showLabel Maybe Char
mLabel )
          (ShowState
SEmpty, Ordering
LT) -> ( ShowState
SParen, t -> ShowS
forall a. Show a => a -> ShowS
shows t
val ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> ShowS
showLabel Maybe Char
mLabel )
          (ShowState
_     , Ordering
GT) -> ( ShowState
SParen
                          , String -> ShowS
showString String
" + " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ShowS
forall a. Show a => a -> ShowS
shows t
val ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> ShowS
showLabel Maybe Char
mLabel )
          (ShowState
_     , Ordering
LT) -> ( ShowState
SParen
                          , String -> ShowS
showString String
" - " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ShowS
forall a. Show a => a -> ShowS
shows (t -> t
forall a. Num a => a -> a
negate t
val) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> ShowS
showLabel Maybe Char
mLabel )


data ShowState = SEmpty | Simple | SParen
    deriving ShowState -> ShowState -> Bool
(ShowState -> ShowState -> Bool)
-> (ShowState -> ShowState -> Bool) -> Eq ShowState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowState -> ShowState -> Bool
$c/= :: ShowState -> ShowState -> Bool
== :: ShowState -> ShowState -> Bool
$c== :: ShowState -> ShowState -> Bool
Eq

instance (Read t, Quaternion t, Num t) => Read (Quater t) where
    readPrec :: ReadPrec (Quater t)
readPrec     = ReadPrec (Quater t) -> ReadPrec (Quater t)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Quater t) -> ReadPrec (Quater t))
-> ReadPrec (Quater t) -> ReadPrec (Quater t)
forall a b. (a -> b) -> a -> b
$ ReadPrec t
forall a. Read a => ReadPrec a
readPrec ReadPrec t -> (t -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t)
go t -> t
forall a. a -> a
id t
0 t
0 t
0 t
0
      where
        go :: (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t)
        go :: (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t)
go t -> t
f t
x t
y t
z t
w t
new =
          let def :: ReadPrec (Quater t)
def = Quater t -> ReadPrec (Quater t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> t -> t -> t -> Quater t
forall t. Quaternion t => t -> t -> t -> t -> Quater t
Quater t
x t
y t
z (t -> t
f t
new))
              withLabel :: Lexeme -> ReadPrec (Quater t)
withLabel Lexeme
EOF         = ReadPrec (Quater t)
def
              withLabel (Ident String
"i")
                = (ReadPrec Lexeme
lexP ReadPrec Lexeme
-> (Lexeme -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
proceed (t -> t
f t
new) t
y t
z t
w) ReadPrec (Quater t) -> ReadPrec (Quater t) -> ReadPrec (Quater t)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
<++ Quater t -> ReadPrec (Quater t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> t -> t -> t -> Quater t
forall t. Quaternion t => t -> t -> t -> t -> Quater t
Quater (t -> t
f t
new) t
y t
z t
w)
              withLabel (Ident String
"j")
                = (ReadPrec Lexeme
lexP ReadPrec Lexeme
-> (Lexeme -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
proceed t
x (t -> t
f t
new) t
z t
w) ReadPrec (Quater t) -> ReadPrec (Quater t) -> ReadPrec (Quater t)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
<++ Quater t -> ReadPrec (Quater t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> t -> t -> t -> Quater t
forall t. Quaternion t => t -> t -> t -> t -> Quater t
Quater t
x (t -> t
f t
new) t
z t
w)
              withLabel (Ident String
"k")
                = (ReadPrec Lexeme
lexP ReadPrec Lexeme
-> (Lexeme -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
proceed t
x t
y (t -> t
f t
new) t
w) ReadPrec (Quater t) -> ReadPrec (Quater t) -> ReadPrec (Quater t)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
<++ Quater t -> ReadPrec (Quater t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> t -> t -> t -> Quater t
forall t. Quaternion t => t -> t -> t -> t -> Quater t
Quater t
x t
y (t -> t
f t
new) t
w)
              withLabel Lexeme
l           = t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
proceed t
x t
y t
z (t -> t
f t
new) Lexeme
l
          in (ReadPrec Lexeme
lexP ReadPrec Lexeme
-> (Lexeme -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Lexeme -> ReadPrec (Quater t)
withLabel) ReadPrec (Quater t) -> ReadPrec (Quater t) -> ReadPrec (Quater t)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
<++ ReadPrec (Quater t)
def
        proceed :: t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
        proceed :: t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
proceed t
x t
y t
z t
w (Symbol String
"+") = ReadPrec t
forall a. Read a => ReadPrec a
readPrec ReadPrec t -> (t -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t)
go t -> t
forall a. a -> a
id t
x t
y t
z t
w
        proceed t
x t
y t
z t
w (Symbol String
"-") = ReadPrec t
forall a. Read a => ReadPrec a
readPrec ReadPrec t -> (t -> ReadPrec (Quater t)) -> ReadPrec (Quater t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t)
go t -> t
forall a. Num a => a -> a
negate t
x t
y t
z t
w
        proceed t
x t
y t
z t
w Lexeme
EOF          = Quater t -> ReadPrec (Quater t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> t -> t -> t -> Quater t
forall t. Quaternion t => t -> t -> t -> t -> Quater t
Quater t
x t
y t
z t
w)
        proceed t
_ t
_ t
_ t
_ Lexeme
_            = ReadPrec (Quater t)
forall a. ReadPrec a
pfail

    readListPrec :: ReadPrec [Quater t]
readListPrec = ReadPrec [Quater t]
forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Quater t]
readList     = ReadS [Quater t]
forall a. Read a => ReadS [a]
readListDefault