{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
module Numeric.Quaternion.Internal
( Quaternion (..), Quater(Quater)
) where
import Numeric.Matrix.Internal (Matrix)
import Numeric.Vector.Internal (Vector)
import Text.Read
pattern Quater :: Quaternion t => t -> t -> t -> t -> Quater t
pattern Quater a b c d <- (unpackQ# -> (# a, b, c, d #))
where
Quater = packQ
{-# COMPLETE Quater #-}
class Quaternion t where
data Quater t
packQ :: t -> t -> t -> t -> Quater t
unpackQ# :: Quater t -> (# t, t, t, t #)
fromVecNum :: Vector t 3 -> t -> Quater t
fromVec4 :: Vector t 4 -> Quater t
toVec4 :: Quater t -> Vector t 4
square :: Quater t -> t
im :: Quater t -> Quater t
re :: Quater t -> Quater t
imVec :: Quater t -> Vector t 3
taker :: Quater t -> t
takei :: Quater t -> t
takej :: Quater t -> t
takek :: Quater t -> t
conjugate :: Quater t -> Quater t
rotScale :: Quater t -> Vector t 3 -> Vector t 3
getRotScale :: Vector t 3 -> Vector t 3 -> Quater t
axisRotation :: Vector t 3 -> t -> Quater t
qArg :: Quater t -> t
fromMatrix33 :: Matrix t 3 3 -> Quater t
fromMatrix44 :: Matrix t 4 4 -> Quater t
toMatrix33 :: Quater t -> Matrix t 3 3
toMatrix44 :: Quater t -> Matrix t 4 4
instance (Show t, Quaternion t, Ord t, Num t) => Show (Quater t) where
showsPrec p (Quater x y z w)
= case finS of
SEmpty -> showChar '0'
Simple -> finF
SParen -> showParen (p > 6) finF
where
(finS, finF) = go SEmpty
[(w, Nothing), (x, Just 'i'), (y, Just 'j'), (z, Just 'k')]
go :: ShowState -> [(t, Maybe Char)] -> (ShowState, ShowS)
go s ((v,l):xs)
| (s0, f0) <- showComponent s v l
, (s', f') <- go s0 xs
= (s', f0 . f')
go s [] = (s, id)
showLabel Nothing = id
showLabel (Just c) = showChar c
showComponent :: ShowState -> t -> Maybe Char -> (ShowState, ShowS)
showComponent sState val mLabel = case (sState, compare val 0) of
(_ , EQ) -> ( sState, id )
(SEmpty, GT) -> ( Simple, shows val . showLabel mLabel )
(SEmpty, LT) -> ( SParen, shows val . showLabel mLabel )
(_ , GT) -> ( SParen
, showString " + " . shows val . showLabel mLabel )
(_ , LT) -> ( SParen
, showString " - " . shows (negate val) . showLabel mLabel )
data ShowState = SEmpty | Simple | SParen
deriving Eq
instance (Read t, Quaternion t, Num t) => Read (Quater t) where
readPrec = parens $ readPrec >>= go id 0 0 0 0
where
go :: (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t)
go f x y z w new =
let def = pure (Quater x y z (f new))
withLabel EOF = def
withLabel (Ident "i")
= (lexP >>= proceed (f new) y z w) <++ pure (Quater (f new) y z w)
withLabel (Ident "j")
= (lexP >>= proceed x (f new) z w) <++ pure (Quater x (f new) z w)
withLabel (Ident "k")
= (lexP >>= proceed x y (f new) w) <++ pure (Quater x y (f new) w)
withLabel l = proceed x y z (f new) l
in (lexP >>= withLabel) <++ def
proceed :: t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t)
proceed x y z w (Symbol "+") = readPrec >>= go id x y z w
proceed x y z w (Symbol "-") = readPrec >>= go negate x y z w
proceed x y z w EOF = pure (Quater x y z w)
proceed _ _ _ _ _ = pfail
readListPrec = readListPrecDefault
readList = readListDefault