module Language.GLSL.Runtime.PrimFuns where

import           Control.Monad               ((>=>))
import           Language.GLSL.Runtime.Math  (floor, fract, mod, smoothstep,
                                              step)
import           Language.GLSL.Runtime.Value (Eval, Value (..), evalCoerce)
import           Language.GLSL.Types         (FunName (..), Type (..), pp,
                                              ppFunName)
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