module Language.GLSL.Runtime.PrimFuns where

import           Control.Monad               ((>=>))
import           Language.GLSL.AST           (FunName (..), Type (..))
import           Language.GLSL.PrettyPrint   (pp, ppFunName)
import           Language.GLSL.Runtime.Math  (floor, fract, mod, smoothstep,
                                              step)
import           Language.GLSL.Runtime.Value (Eval, Value (..), evalCoerce)
import           Linear
import           Prelude                     hiding (floor, mod)

flt :: Value -> Eval Float
flt :: Value -> Eval Float
flt = Type -> Value -> Eval Value
evalCoerce Type
TyFloat (Value -> Eval Value)
-> (Value -> Eval Float) -> Value -> Eval Float
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Eval Float
forall (f :: * -> *). MonadFail f => Value -> f Float
convert
  where
    convert :: Value -> f Float
convert (FloatValue Float
v) = Float -> f Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
v
    convert Value
v              = String -> f Float
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f Float) -> String -> f Float
forall a b. (a -> b) -> a -> b
$ String
"not a Float value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v

v4 :: Value -> Eval (V4 Float)
v4 :: Value -> Eval (V4 Float)
v4 = Type -> Value -> Eval Value
evalCoerce (Int -> Type
TyVec Int
4) (Value -> Eval Value)
-> (Value -> Eval (V4 Float)) -> Value -> Eval (V4 Float)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Eval (V4 Float)
forall (f :: * -> *). MonadFail f => Value -> f (V4 Float)
convert
  where
    convert :: Value -> f (V4 Float)
convert (Vec4Value V4 Float
v) = V4 Float -> f (V4 Float)
forall (f :: * -> *) a. Applicative f => a -> f a
pure V4 Float
v
    convert Value
v             = String -> f (V4 Float)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f (V4 Float)) -> String -> f (V4 Float)
forall a b. (a -> b) -> a -> b
$ String
"not a V4 value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v


eval :: FunName -> [Value] -> Eval Value
eval :: FunName -> [Value] -> Eval Value
eval FunName
PrimVec2 [Value
x, Value
y] =
  (V2 Float -> Value)
-> StateT EvalState EvalResult (V2 Float) -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap V2 Float -> Value
Vec2Value (StateT EvalState EvalResult (V2 Float) -> Eval Value)
-> StateT EvalState EvalResult (V2 Float) -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2
    (Float -> Float -> V2 Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> V2 Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
x
    StateT EvalState EvalResult (Float -> V2 Float)
-> Eval Float -> StateT EvalState EvalResult (V2 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
y
eval FunName
PrimVec3 [Value
x, Value
y, Value
z] =
  (V3 Float -> Value)
-> StateT EvalState EvalResult (V3 Float) -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap V3 Float -> Value
Vec3Value (StateT EvalState EvalResult (V3 Float) -> Eval Value)
-> StateT EvalState EvalResult (V3 Float) -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3
    (Float -> Float -> Float -> V3 Float)
-> Eval Float
-> StateT EvalState EvalResult (Float -> Float -> V3 Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
x
    StateT EvalState EvalResult (Float -> Float -> V3 Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> V3 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
y
    StateT EvalState EvalResult (Float -> V3 Float)
-> Eval Float -> StateT EvalState EvalResult (V3 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
z
eval FunName
PrimVec4 [Value
x, Value
y, Value
z, Value
w] =
  (V4 Float -> Value) -> Eval (V4 Float) -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap V4 Float -> Value
Vec4Value (Eval (V4 Float) -> Eval Value) -> Eval (V4 Float) -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4
    (Float -> Float -> Float -> Float -> V4 Float)
-> Eval Float
-> StateT
     EvalState EvalResult (Float -> Float -> Float -> V4 Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
x
    StateT EvalState EvalResult (Float -> Float -> Float -> V4 Float)
-> Eval Float
-> StateT EvalState EvalResult (Float -> Float -> V4 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
y
    StateT EvalState EvalResult (Float -> Float -> V4 Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> V4 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
z
    StateT EvalState EvalResult (Float -> V4 Float)
-> Eval Float -> Eval (V4 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
w

eval FunName
PrimMat4x4 [Value
x, Value
y, Value
z, Value
w] =
  (M44 Float -> Value)
-> StateT EvalState EvalResult (M44 Float) -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap M44 Float -> Value
Mat4x4Value (StateT EvalState EvalResult (M44 Float) -> Eval Value)
-> StateT EvalState EvalResult (M44 Float) -> Eval Value
forall a b. (a -> b) -> a -> b
$ V4 Float -> V4 Float -> V4 Float -> V4 Float -> M44 Float
forall a. a -> a -> a -> a -> V4 a
V4
    (V4 Float -> V4 Float -> V4 Float -> V4 Float -> M44 Float)
-> Eval (V4 Float)
-> StateT
     EvalState
     EvalResult
     (V4 Float -> V4 Float -> V4 Float -> M44 Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval (V4 Float)
v4 Value
x
    StateT
  EvalState
  EvalResult
  (V4 Float -> V4 Float -> V4 Float -> M44 Float)
-> Eval (V4 Float)
-> StateT EvalState EvalResult (V4 Float -> V4 Float -> M44 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval (V4 Float)
v4 Value
y
    StateT EvalState EvalResult (V4 Float -> V4 Float -> M44 Float)
-> Eval (V4 Float)
-> StateT EvalState EvalResult (V4 Float -> M44 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval (V4 Float)
v4 Value
z
    StateT EvalState EvalResult (V4 Float -> M44 Float)
-> Eval (V4 Float) -> StateT EvalState EvalResult (M44 Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval (V4 Float)
v4 Value
w

eval FunName
PrimLength [Vec2Value V2 Float
a] = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V2 Float -> Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm V2 Float
a
eval FunName
PrimLength [Vec3Value V3 Float
a] = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V3 Float -> Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm V3 Float
a
eval FunName
PrimLength [Vec4Value V4 Float
a] = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V4 Float -> Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm V4 Float
a

eval FunName
PrimNormalize [Vec2Value V2 Float
a] = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ V2 Float -> Value
Vec2Value (V2 Float -> Value) -> V2 Float -> Value
forall a b. (a -> b) -> a -> b
$ V2 Float -> V2 Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm V2 Float
a
eval FunName
PrimNormalize [Vec3Value V3 Float
a] = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ V3 Float -> Value
Vec3Value (V3 Float -> Value) -> V3 Float -> Value
forall a b. (a -> b) -> a -> b
$ V3 Float -> V3 Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm V3 Float
a
eval FunName
PrimNormalize [Vec4Value V4 Float
a] = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ V4 Float -> Value
Vec4Value (V4 Float -> Value) -> V4 Float -> Value
forall a b. (a -> b) -> a -> b
$ V4 Float -> V4 Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm V4 Float
a

eval FunName
PrimSqrt   [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
forall a. Floating a => a -> a
sqrt   (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimSin    [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
forall a. Floating a => a -> a
sin    (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimAsin   [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
forall a. Floating a => a -> a
asin   (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimCos    [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
forall a. Floating a => a -> a
cos    (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimAbs    [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
forall a. Num a => a -> a
abs    (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimFloor  [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
floor  (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimFract  [Value
a] = Float -> Value
FloatValue      (Float -> Value) -> (Float -> Float) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
fract  (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a
eval FunName
PrimMod  [Value
a,Value
b] = (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Value
FloatValue (Eval Float -> Eval Value) -> Eval Float -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float
mod    (Float -> Float -> Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a StateT EvalState EvalResult (Float -> Float)
-> Eval Float -> Eval Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
b
eval FunName
PrimAtan [Value
a,Value
b] = (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Value
FloatValue (Eval Float -> Eval Value) -> Eval Float -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float
forall a. RealFloat a => a -> a -> a
atan2  (Float -> Float -> Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a StateT EvalState EvalResult (Float -> Float)
-> Eval Float -> Eval Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
b

eval FunName
PrimSmoothstep [Value
a,Value
b,Value
c] = (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Value
FloatValue (Eval Float -> Eval Value) -> Eval Float -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float
smoothstep (Float -> Float -> Float -> Float)
-> Eval Float
-> StateT EvalState EvalResult (Float -> Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a StateT EvalState EvalResult (Float -> Float -> Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> Float)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
b StateT EvalState EvalResult (Float -> Float)
-> Eval Float -> Eval Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
c
eval FunName
PrimStep         [Value
a,Value
b] = (Float -> Value) -> Eval Float -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Value
FloatValue (Eval Float -> Eval Value) -> Eval Float -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float
step (Float -> Float -> Float)
-> Eval Float -> StateT EvalState EvalResult (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Float
flt Value
a StateT EvalState EvalResult (Float -> Float)
-> Eval Float -> Eval Float
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Eval Float
flt Value
b

-- eval _ (a:_) = pure a
eval FunName
fun [Value]
_ = String -> Eval Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Eval Value) -> String -> Eval Value
forall a b. (a -> b) -> a -> b
$ String
"primfun not implemented: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (FunName -> Builder) -> FunName -> String
forall a. (a -> Builder) -> a -> String
pp FunName -> Builder
ppFunName FunName
fun