module Hylogen.Types where
import Data.Monoid
import Data.VectorSpace
import GHC.Exts (Constraint)
import Data.Hashable
import GHC.Generics
class (ConstructFrom' tuple hprim, Show tuple, Vec hprim) => ConstructFrom tuple hprim where
exprFormFromTuple :: tuple -> hprim -> Expr
instance ConstructFrom Float Vec1 where
exprFormFromTuple x _ = Tree (Uniform, GLSLFloat, (show x)) []
instance ConstructFrom (Vec1, Vec1) Vec2 where
exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec2, "vec2") [toExpr x, toExpr y]
instance ConstructFrom (Vec1, Vec1, Vec1) Vec3 where
exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y, toExpr z]
instance ConstructFrom (Vec2, Vec1) Vec3 where
exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y]
instance ConstructFrom (Vec1, Vec2) Vec3 where
exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec3, "vec3") [toExpr x, toExpr y]
instance ConstructFrom (Vec1, Vec1, Vec1, Vec1) Vec4 where
exprFormFromTuple (x, y, z, w) _ = Tree (QuaternaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z, toExpr w]
instance ConstructFrom (Vec2, Vec1, Vec1) Vec4 where
exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z]
instance ConstructFrom (Vec1, Vec2, Vec1) Vec4 where
exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z]
instance (a ~ Vec1, b ~ Vec1) => ConstructFrom (a, b, Vec2) Vec4 where
exprFormFromTuple (x, y, z) _ = Tree (TernaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y, toExpr z]
instance ConstructFrom (Vec3, Vec1) Vec4 where
exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y]
instance (a ~ Vec1) => ConstructFrom (a, Vec3) Vec4 where
exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y]
instance (a ~ Vec2) => ConstructFrom (a, Vec2) Vec4 where
exprFormFromTuple (x, y) _ = Tree (BinaryOpPre, GLSLVec4, "vec4") [toExpr x, toExpr y]
type family (ConstructFrom' tuple hprim) :: Constraint where
ConstructFrom' a Vec1 = a ~ Float
ConstructFrom' (a, b) Vec2 = (a ~ Vec1, b ~ Vec1)
ConstructFrom' (a, b, c) Vec3 = (a ~ Vec1, b ~ Vec1, c ~ Vec1)
ConstructFrom' (Vec2, b) Vec3 = (b ~ Vec1)
ConstructFrom' (a, Vec2) Vec3 = (a ~ Vec1)
ConstructFrom' (a, b, c, d) Vec4 = (a ~ Vec1, b ~ Vec1, c ~ Vec1, d ~ Vec1)
ConstructFrom' (Vec3, b) Vec4 = (b ~ Vec1)
ConstructFrom' (Vec2, b) Vec4 = (b ~ Vec2)
ConstructFrom' (a, Vec3) Vec4 = (a ~ Vec1)
ConstructFrom' (Vec2, b, c) Vec4 = (b ~ Vec1, c ~ Vec1)
ConstructFrom' (a, Vec2, c) Vec4 = (a ~ Vec1, c ~ Vec1)
ConstructFrom' (a, b, Vec2) Vec4 = (a ~ Vec1, b ~ Vec1)
class (Expressible v, Show v) => Vec v where
vec :: (ConstructFrom tuple v) => tuple -> v
vu :: String -> v
vuop :: String -> v -> v
vuoppre :: String -> v -> v
vbop :: String -> v -> v -> v
vboppre :: String -> v -> v -> v
select :: Booly -> v -> v -> v
fromVec1 :: Vec1 -> v
toList :: v -> [Vec1]
class (Expressible a, Show a) => HasX a
class HasX a => HasY a
class HasY a => HasZ a
class HasZ a => HasW a
data Vec1 where
Vec1 :: Float -> Vec1
V1u :: String -> Vec1
V1uop :: String -> Vec1 -> Vec1
V1uoppre :: String -> Vec1 -> Vec1
V1bop :: String -> Vec1 -> Vec1 -> Vec1
V1boppre :: String -> Vec1 -> Vec1 -> Vec1
V1select :: Booly -> Vec1 -> Vec1 -> Vec1
Dot :: (Vec a) => a -> a -> Vec1
X :: (HasX a) => a -> Vec1
Y :: (HasY a) => a -> Vec1
Z :: (HasZ a) => a -> Vec1
W :: (HasW a) => a -> Vec1
instance Show Vec1 where
show expr = case expr of
Vec1 x -> show x
V1u x -> x
V1uop u x -> u <> "(" <> show x <> ")"
V1uoppre u x -> "(" <> u <> show x <> ")"
V1bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V1boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"
V1select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"
Dot x y -> "dot(" <> show x <> ", " <> show y <> ")"
X x -> show x <> ".x"
Y x -> show x <> ".y"
Z x -> show x <> ".z"
W x -> show x <> ".w"
instance Vec Vec1 where
vec = Vec1
vu = V1u
vuop = V1uop
vuoppre = V1uoppre
vbop = V1bop
vboppre = V1boppre
select = V1select
fromVec1 = id
toList x = [x]
instance Num Vec1 where
(+) = vbop "+"
(*) = vbop "*"
negate = vuoppre "-"
abs = vuop "abs"
signum = vuop "sign"
fromInteger = Vec1 . fromInteger
instance Fractional Vec1 where
(/) = vbop "/"
recip = vbop "/" 1
fromRational = Vec1 . fromRational
instance Floating Vec1 where
pi = vu "pi"
exp = vuop "exp"
log = vuop "log"
sqrt = vuop "sqrt"
(**) = vboppre "pow"
sin = vuop "sin"
cos = vuop "cos"
tan = vuop "tan"
asin = vuop "asin"
acos = vuop "acos"
atan = vuop "atan"
sinh x = (exp x exp (negate x))/2
cosh x = (exp x + exp (negate x))/2
tanh x = sinh x / cosh x
asinh x = log $ x + sqrt(x**2 + 1)
acosh x = log $ x + sqrt(x**2 1)
atanh x = 0.5 * log ((1 + x)/(1 x))
instance AdditiveGroup Vec1 where
zeroV = 0
(^+^) = (+)
negateV = negate
(^-^) = ()
instance VectorSpace Vec1 where
type Scalar Vec1 = Vec1
a *^ b = a * b
instance InnerSpace Vec1 where
(<.>) = Dot
data Vec2 where
Vec2 :: (ConstructFrom tuple Vec2) => tuple -> Vec2
V2u :: String -> Vec2
V2uop :: String -> Vec2 -> Vec2
V2uoppre :: String -> Vec2 -> Vec2
V2bop :: String -> Vec2 -> Vec2 -> Vec2
V2boppre :: String -> Vec2 -> Vec2 -> Vec2
V2bops :: String -> Vec1 -> Vec2 -> Vec2
V2select :: Booly -> Vec2 -> Vec2 -> Vec2
instance Vec Vec2 where
vec = Vec2
vu = V2u
vuop = V2uop
vuoppre = V2uoppre
vbop = V2bop
vboppre = V2boppre
select = V2select
fromVec1 x = Vec2 (x, x)
toList x = [X x, Y x]
instance Show Vec2 where
show expr = case expr of
Vec2 tuple -> "vec2" <> show tuple
V2u x -> x
V2uop u x -> u <> "(" <> show x <> ")"
V2uoppre u x -> "(" <> u <> show x <> ")"
V2bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V2boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"
V2bops b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V2select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"
instance Num Vec2 where
(+) = vbop "+"
(*) = vbop "*"
negate = vuoppre "-"
abs = vuop "abs"
signum = vuop "sign"
fromInteger = fromVec1 . fromInteger
instance Fractional Vec2 where
(/) = vbop "/"
recip = vbop "/" 1
fromRational = fromVec1 . fromRational
instance Floating Vec2 where
pi = vu "pi"
exp = vuop "exp"
log = vuop "log"
sqrt = vuop "sqrt"
(**) = vboppre "pow"
sin = vuop "sin"
cos = vuop "cos"
tan = vuop "tan"
asin = vuop "asin"
acos = vuop "acos"
atan = vuop "atan"
sinh x = (exp x exp (negate x))/2
cosh x = (exp x + exp (negate x))/2
tanh x = sinh x / cosh x
asinh x = log $ x + sqrt(x**2 + 1)
acosh x = log $ x + sqrt(x**2 1)
atanh x = 0.5 * log ((1 + x)/(1 x))
instance AdditiveGroup Vec2 where
zeroV = 0
(^+^) = (+)
negateV = negate
(^-^) = ()
instance VectorSpace Vec2 where
type Scalar Vec2 = Vec1
a *^ b = V2bops "*" a b
instance InnerSpace Vec2 where
(<.>) = Dot
instance HasX Vec2
instance HasY Vec2
data Vec3 where
Vec3 :: (ConstructFrom tuple Vec3) => tuple -> Vec3
V3u :: String -> Vec3
V3uop :: String -> Vec3 -> Vec3
V3uoppre :: String -> Vec3 -> Vec3
V3bop :: String -> Vec3 -> Vec3 -> Vec3
V3boppre :: String -> Vec3 -> Vec3 -> Vec3
V3bops :: String -> Vec1 -> Vec3 -> Vec3
V3select :: Booly -> Vec3 -> Vec3 -> Vec3
instance Vec Vec3 where
vec = Vec3
vu = V3u
vuop = V3uop
vuoppre = V3uoppre
vbop = V3bop
vboppre = V3boppre
select = V3select
fromVec1 x = Vec3 (x, x, x)
toList x = [X x, Y x, Z x]
instance Show Vec3 where
show expr = case expr of
Vec3 tuple -> "vec3" <> show tuple
V3u x -> x
V3uop u x -> u <> "(" <> show x <> ")"
V3uoppre u x -> "(" <> u <> show x <> ")"
V3bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V3boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"
V3bops b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V3select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"
instance Num Vec3 where
(+) = vbop "+"
(*) = vbop "*"
negate = vuoppre "-"
abs = vuop "abs"
signum = vuop "sign"
fromInteger = fromVec1 . fromInteger
instance Fractional Vec3 where
(/) = vbop "/"
recip = vbop "/" 1
fromRational = fromVec1 . fromRational
instance Floating Vec3 where
pi = vu "pi"
exp = vuop "exp"
log = vuop "log"
sqrt = vuop "sqrt"
(**) = vboppre "pow"
sin = vuop "sin"
cos = vuop "cos"
tan = vuop "tan"
asin = vuop "asin"
acos = vuop "acos"
atan = vuop "atan"
sinh x = (exp x exp (negate x))/2
cosh x = (exp x + exp (negate x))/2
tanh x = sinh x / cosh x
asinh x = log $ x + sqrt(x**2 + 1)
acosh x = log $ x + sqrt(x**2 1)
atanh x = 0.5 * log ((1 + x)/(1 x))
instance AdditiveGroup Vec3 where
zeroV = 0
(^+^) = (+)
negateV = negate
(^-^) = ()
instance VectorSpace Vec3 where
type Scalar Vec3 = Vec1
a *^ b = V3bops "*" a b
instance InnerSpace Vec3 where
(<.>) = Dot
instance HasX Vec3
instance HasY Vec3
instance HasZ Vec3
data Vec4 where
Vec4 :: (ConstructFrom tuple Vec4) => tuple -> Vec4
V4u :: String -> Vec4
V4uop :: String -> Vec4 -> Vec4
V4uoppre :: String -> Vec4 -> Vec4
V4bop :: String -> Vec4 -> Vec4 -> Vec4
V4boppre :: String -> Vec4 -> Vec4 -> Vec4
V4bops :: String -> Vec1 -> Vec4 -> Vec4
V4select :: Booly -> Vec4 -> Vec4 -> Vec4
Texture2D :: Texture -> Vec2 -> Vec4
instance Vec Vec4 where
vec = Vec4
vu = V4u
vuop = V4uop
vuoppre = V4uoppre
vbop = V4bop
vboppre = V4boppre
select = V4select
fromVec1 x = Vec4 (x, x, x, x)
toList x = [X x, Y x, Z x, W x]
instance Show Vec4 where
show expr = case expr of
Vec4 tuple -> "vec4" <> show tuple
V4u x -> x
V4uop u x -> u <> "(" <> show x <> ")"
V4uoppre u x -> "(" <> u <> show x <> ")"
V4bop b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V4boppre b x y -> b <> "(" <> show x <> ", " <> show y <> ")"
V4bops b x y -> "(" <> show x <> " " <> b <> " " <> show y <> ")"
V4select b x y -> "( " <> show b <> " ? " <> show x <> " : " <> show y <> ")"
Texture2D t v -> "texture2D(" <> show t <> ", " <> show v <> ")"
instance Num Vec4 where
(+) = vbop "+"
(*) = vbop "*"
negate = vuoppre "-"
abs = vuop "abs"
signum = vuop "sign"
fromInteger = fromVec1 . fromInteger
instance Fractional Vec4 where
(/) = vbop "/"
recip = vbop "/" 1
fromRational = fromVec1 . fromRational
instance Floating Vec4 where
pi = vu "pi"
exp = vuop "exp"
log = vuop "log"
sqrt = vuop "sqrt"
(**) = vboppre "pow"
sin = vuop "sin"
cos = vuop "cos"
tan = vuop "tan"
asin = vuop "asin"
acos = vuop "acos"
atan = vuop "atan"
sinh x = (exp x exp (negate x))/2
cosh x = (exp x + exp (negate x))/2
tanh x = sinh x / cosh x
asinh x = log $ x + sqrt(x**2 + 1)
acosh x = log $ x + sqrt(x**2 1)
atanh x = 0.5 * log ((1 + x)/(1 x))
instance AdditiveGroup Vec4 where
zeroV = 0
(^+^) = (+)
negateV = negate
(^-^) = ()
instance VectorSpace Vec4 where
type Scalar Vec4 = Vec1
a *^ b = V4bops "*" a b
instance InnerSpace Vec4 where
(<.>) = Dot
instance HasX Vec4
instance HasY Vec4
instance HasZ Vec4
instance HasW Vec4
data Texture where
Tu :: String -> Texture
instance Show Texture where
show (Tu xs) = xs
data Booly where
Bu:: String -> Booly
Buop :: String -> Booly -> Booly
Buoppre :: String -> Booly -> Booly
Bbop :: String -> Booly -> Booly -> Booly
Bcomp :: (Vec a) => String -> a -> a -> Booly
Bcomp_ :: String -> Vec1 -> Vec1 -> Booly
instance Show Booly where
show expr = case expr of
Bu x -> x
Buop u x -> u <> "(" <> show x <> ")"
Buoppre u x -> "(" <> u <> show x <> ")"
Bbop u x y -> "(" <> show x <> " " <> u <> " " <> show y <> ")"
Bcomp u x y -> show . product $ zipWith (Bcomp_ u) (toList x) (toList y)
Bcomp_ u x y -> "(" <> show x <> " " <> u <> " " <> show y <> ")"
instance Num Booly where
(+) = Bbop "||"
(*) = Bbop "&&"
negate = Buoppre "!"
abs = id
signum = id
fromInteger x
| x > 0 = Bu "true"
| otherwise = Bu "false"
data GLSLType = GLSLFloat
| GLSLVec2
| GLSLVec3
| GLSLVec4
| GLSLBool
| GLSLTexture
deriving (Generic, Hashable, Eq, Ord)
instance Show GLSLType where
show x = case x of
GLSLFloat -> "float"
GLSLVec2 -> "vec2"
GLSLVec3 -> "vec3"
GLSLVec4 -> "vec4"
GLSLBool -> "bool"
GLSLTexture -> "(texture)"
class (Show a) => Expressible a where
toExpr :: a -> Expr
data ExprForm = Uniform
| Variable
| UnaryOp
| UnaryOpPre
| BinaryOp
| BinaryOpPre
| TernaryOpPre
| QuaternaryOpPre
| Select
| Access
deriving (Show, Generic, Hashable)
data Tree a = Tree { getElem :: a
, getChildren :: [Tree a]
}
deriving (Functor)
type Expr = Tree (ExprForm, GLSLType, String)
instance Show Expr where
show (Tree (form, _, str) xs) = case form of
Uniform -> str
Variable -> str
UnaryOp -> str <> "(" <> show (xs!!0) <> ")"
UnaryOpPre -> "(" <> str <> show (xs!!0) <> ")"
BinaryOp -> "(" <> show (xs !! 0) <> " " <> str <> " " <> show (xs !! 1) <> ")"
BinaryOpPre -> str <> "(" <> show (xs!!0) <> ", " <> show (xs!!1) <> ")"
TernaryOpPre -> str <> "(" <> show (xs!!0) <> ", " <> show (xs!!1) <> ", " <> show (xs!!2) <> ")"
QuaternaryOpPre -> str <> "(" <> show (xs!!0) <> ", " <> show (xs!!1) <> ", " <> show (xs!!2) <> ", " <> show (xs!!3) <> ")"
Select -> "( " <> show (xs!!0) <> " ? " <> show (xs!!1) <> " : " <> show (xs!!2) <> ")"
Access -> show (xs!!0) <> "." <> str
instance Expressible Vec1 where
toExpr foo = case foo of
Vec1 x -> exprFormFromTuple x foo
V1u str -> Tree (Uniform, ty, str) []
V1uop str x -> Tree (UnaryOp, ty, str) [toExpr x]
V1uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]
V1bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]
V1boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]
V1select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y]
Dot x y -> Tree (BinaryOpPre, ty, "dot") [toExpr x, toExpr y]
X x -> Tree (Access, ty, "x") [toExpr x]
Y x -> Tree (Access, ty, "y") [toExpr x]
Z x -> Tree (Access, ty, "z") [toExpr x]
W x -> Tree (Access, ty, "w") [toExpr x]
where
ty = GLSLFloat
instance Expressible Vec2 where
toExpr foo = case foo of
Vec2 x -> exprFormFromTuple x foo
V2u str -> Tree (Uniform, ty, str) []
V2uop str x -> Tree (UnaryOp, ty, str) [toExpr x]
V2uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]
V2bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]
V2boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]
V2bops str x y -> Tree (BinaryOp , ty, str) [toExpr x, toExpr y]
V2select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y]
where
ty = GLSLVec2
instance Expressible Vec3 where
toExpr foo = case foo of
Vec3 x -> exprFormFromTuple x foo
V3u str -> Tree (Uniform, ty, str) []
V3uop str x -> Tree (UnaryOp, ty, str) [toExpr x]
V3uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]
V3bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]
V3boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]
V3bops str x y -> Tree (BinaryOp , ty, str) [toExpr x, toExpr y]
V3select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y]
where
ty = GLSLVec3
instance Expressible Vec4 where
toExpr foo = case foo of
Vec4 x -> exprFormFromTuple x foo
V4u str -> Tree (Uniform, ty, str) []
V4uop str x -> Tree (UnaryOp, ty, str) [toExpr x]
V4uoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]
V4bop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]
V4boppre str x y -> Tree (BinaryOpPre, ty, str) [toExpr x, toExpr y]
V4bops str x y -> Tree (BinaryOp , ty, str) [toExpr x, toExpr y]
V4select b x y -> Tree (Select, ty, "?:") [toExpr b, toExpr x, toExpr y]
Texture2D t x -> Tree (BinaryOpPre, ty, "texture2D") [toExpr t, toExpr x]
where
ty = GLSLVec4
instance Expressible Booly where
toExpr foo = case foo of
Bu str -> Tree (Uniform, ty, str) []
Buop str x -> Tree (UnaryOp, ty, str) [toExpr x]
Buoppre str x -> Tree (UnaryOpPre, ty, str) [toExpr x]
Bbop str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]
Bcomp_ str x y -> Tree (BinaryOp, ty, str) [toExpr x, toExpr y]
Bcomp str x y -> toExpr . product $ zipWith (Bcomp_ str) (toList x) (toList y)
where
ty = GLSLBool
instance Expressible Texture where
toExpr (Tu str) = Tree (Uniform, ty, str) []
where
ty = GLSLTexture