diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for HaGL + +## 0.1.0.0 -- 2023-06-10 + +* Initial (pre-)release diff --git a/HaGL.cabal b/HaGL.cabal new file mode 100644 --- /dev/null +++ b/HaGL.cabal @@ -0,0 +1,105 @@ +name: HaGL +version: 0.1.0.0 +synopsis: Haskell-embedded OpenGL +description: A simple, functional approach to + OpenGL programming in Haskell. + . + All definitions that comprise HaGL are + provided by the top-level "Graphics.HaGL" module. +homepage: https://github.com/simeonkr/HaGL +license: MIT +license-file: LICENSE +author: Simeon Krastnikov +maintainer: skrastnikov@gmail.com +category: Graphics +build-type: Simple +extra-source-files: README.md, CHANGELOG.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/simeonkr/HaGL + +library + exposed-modules: + Graphics.HaGL + Graphics.HaGL.Internal + other-modules: + Graphics.HaGL.TH.HaGL + Graphics.HaGL.Util + Graphics.HaGL.Util.Types + Graphics.HaGL.Util.DepMap + Graphics.HaGL.Numerical + Graphics.HaGL.GLType + Graphics.HaGL.GLExpr + Graphics.HaGL.ExprID + Graphics.HaGL.GLAst + Graphics.HaGL.Print + Graphics.HaGL.Eval + Graphics.HaGL.GLObj + Graphics.HaGL.Shader + Graphics.HaGL.CodeGen + Graphics.HaGL.Backend + Graphics.HaGL.Backend.GLUT + default-extensions: + GADTs, + DataKinds, + KindSignatures, + TypeFamilies, + TypeOperators, + ViewPatterns, + FlexibleContexts, + FlexibleInstances, + PartialTypeSignatures + build-depends: + base >= 4.12 && < 4.19, + template-haskell >= 2.14.0 && < 2.21, + array >= 0.5.3 && < 0.6, + matrix >= 0.3.6 && < 0.4, + containers >= 0.6.0 && < 0.7, + unordered-containers >= 0.2.19 && < 0.3, + mtl >= 2.2.2 && < 2.3, + hashable >= 1.4.2 && < 1.5, + time >= 1.8.0 && < 1.14, + cryptohash-md5 >= 0.11.100 && < 0.12, + OpenGL >= 3.0.3 && < 3.1, + OpenGLRaw >= 3.3.4 && < 3.4, + GLUT >= 2.7.0 && < 2.8, + bytestring >= 0.11.4 && < 0.12, + gl-capture >= 0.1.0 && < 0.2 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall + -- FIXME: enable -fwarn-incomplete-patterns + -- and fix warnings + -Wno-incomplete-patterns + -Wno-missing-signatures + -Wno-unticked-promoted-constructors + -Wno-partial-type-signatures + -Wno-name-shadowing + -Wno-orphans + +test-suite HaGL-test + type: exitcode-stdio-1.0 + default-extensions: + GADTs, + DataKinds, + KindSignatures, + TypeFamilies, + TypeOperators, + ViewPatterns, + FlexibleContexts, + FlexibleInstances, + PartialTypeSignatures + build-depends: + base, + HaGL, + HUnit >= 1.6.2.0 && < 1.7, + bytestring, + directory >= 1.3.3.0 && < 1.4, + GLUT + other-modules: + hs-source-dirs: tests + main-is: Test.hs + default-language: Haskell2010 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022-23 Simeon Krastnikov + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,111 @@ +# HaGL: Haskell-embedded OpenGL + +HaGL (Haskell-embedded OpenGL, pronounced "haggle") aims to provide a simple, +elegant, and modular way to create lightweight OpenGL visualizations in Haskell. + +By unifying vertex, fragment, and uniform processing into an expressively +typed GLSL-like language consisting of pure, composable primitives, HaGL makes +it easy to experiment with and prototype visual graphical demos. + +To see it in action, please skip straight to the +["Getting Started" guide](https://github.com/simeonkr/HaGL/blob/master/doc/Overview.md). + +## Installation + +Please make sure that you have installed the correct headers and static libraries +for OpenGL development on your system, as well as freeglut for running the GLUT +backend. (For example, in Debian/Ubuntu, ensure that the packages `libgl-dev`, +`lib-glu1-mesa-dev`, and `freeglut3` are installed.) + +Then with the latest version of [Haskell Cabal](https://www.haskell.org/cabal/) installed: + +``` +cabal update +cabal install HaGL +``` + +To instead build locally from the sources, issue: +``` +cabal build HaGL +``` +from the top-level directory. + +The supporting library and examples can be built using: +``` +cabal build HaGL-lib +cabal build HaGL-examples +``` + +(It is recommended that these packages be built not installed, as they are not +yet stable and complete enough to be used without modifications.) + +To check that all the packages have been installed correctly, run a single +example as follows: +``` +cabal run hagl-example interactive_cube +``` + +## Usage + +To learn how to use HaGL please refer to the +["Getting Started" guide](https://github.com/simeonkr/HaGL/blob/master/doc/Overview.md). +The complete documentation can be found on +[Hackage](https://hackage.haskell.org/package/HaGL). + +## Running the Test Suite + +The test suite can be run using: + +``` +cabal test +``` + +Note that since some tests require launching a graphical window, the test suite +cannot be run on a non-GUI system. + +## Intended Use and Alternatives + +HaGL is best suited for the production of simple non-reactive visual animations; +in this regard, its use-cases somewhat resemble those of the [VisPy](https://vispy.org/) +and [Glumpy](https://glumpy.github.io/) Python libraries. + +At the moment, the only way to interpret HaGL code is as a GLUT application but +other backends will be added in the future, as well as a backend-agnostic interface. + +HaGL prioritizes approachability and simplicity over completeness and is likely +unsuitable for use in a game engine. +For more advanced graphics programming consider using, for example, +[LambdaCube 3D](http://lambdacube3d.com/), [FIR](https://gitlab.com/sheaf/fir), +or the Haskell [OpenGL](https://hackage.haskell.org/package/OpenGL) bindings. + +## Scope of OpenGL Support + +HaGL models a simple OpenGL pipeline that supports basic vertex and fragment +processing and exposes a generic API similar to that of GLSL that can be +used for both shader programming and host numerical computation (of uniforms). +In addition, it provides various operations of its own to model certain +imperative constructs in a functional manner. + +An "interpreter" for running HaGL code is provided in the form of GLUT backend +built using the [OpenGL](https://hackage.haskell.org/package/OpenGL) and +[GLUT](https://hackage.haskell.org/package/GLUT) bindings for Haskell. + +Features that are currently missing but could possibly be added in the future: + +* Texture mapping using sampler objects +* Instanced rendering +* Tessellation shading +* Geometry shading +* Compute shading +* Non-GLUT backends and a backend-agnostic interface +* Integration with an FRP framework such as [Yampa](https://hackage.haskell.org/package/Yampa) + +## Contributing + +Contributions in the form of pull requests, suggestions, or feedback are welcome +and appreciated. + +The best way to keep the project alive is to demonstrate its usefulness through +a wide range of interesting examples and tutorials. Another potential area to +explore is the creation of high-level libraries for specific types of visual +applications, as well as improving the supporting library that ships with HaGL. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Graphics/HaGL.hs b/src/Graphics/HaGL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL.hs @@ -0,0 +1,982 @@ +{-| +Module : HaGL +Copyright : (c) Simeon Krastnikov, 2022-2023 +License : MIT +Maintainer : Simeon Krastnikov +Stability : experimental + +This module exports everything that comprises the core language. + +It is best used with the following extensions enabled: +@GADTs@, @DataKinds@, @ViewPatterns@, @FlexibleContexts@. + +Note that quite a few of the exported functions clash with unrelated +ones from Prelude ('max', 'length', 'mod', 'any', etc.) or class methods +with identical behaviour ('abs', 'sin', etc.), in an effort to prioritize +consistency with GLSL function naming. + +In summary, this module can be imported as follows: + +@ + {-\# LANGUAGE GADTs \#-} + {-\# LANGUAGE DataKinds \#-} + {-\# LANGUAGE ViewPatterns \#-} + {-\# LANGUAGE FlexibleContexts \#-} + + import Prelude hiding (max, sin, cos, ...) + + import Graphics.HaGL +@ + +HaGL expressions have the type 'GLExpr' (d :: 'GLDomain') t, +where @d@ is the domain of computation and @t@ is the underlying numeric type, +which is always an instance of 'GLType'. Here are some example expressions: + +@ + -- A vertex attribute constructed from its input values on three vertices + x :: GLExpr VertexDomain Float + x = vert [-1, 0, 1] + + -- Numeric operators and functions like (+) and sin can handle generic + -- expressions. Note that in this example the domain of the inputs to + -- these functions is VertexDomain, so we know that these functions will + -- be computed in a vertex shader. + y :: GLExpr VertexDomain Float + y = sin (2 * x + 1) + + -- 'frag x' is a a fragment variable corresponding to an interpolation of + -- the value of x at the vertices that define its containing primitive. + -- Because it has the type 'GLExpr FragmentDomain Float', the addition + -- below will be computed in a fragment shader. + z :: GLExpr FragmentDomain Float + z = frag x + 3 + + -- \'time\' is a built-in I/O variable and as such it is computed on the CPU + time :: GLExpr HostDomain Float + + -- We can use \'uniform\' to lift a host variable to an arbitrary domain + -- Here 'uniform time' is inferred to have type 'GLExpr VertexDomain Float': + yPlusTime :: GLExpr VertexDomain Float + yPlusTime = y + uniform time + + -- Here 'uniform time' is inferred to be of type 'GLExpr FragmentDomain Float': + zPlusTime :: GLExpr FragmentDomain Float + zPlusTime = z + uniform time + + -- A generic floating-point vector of length 4 + v :: GLExpr d (Vec 4 Float) + v = vec4 1 1 1 1 + + -- A vector can be initialized from a numeric literal, so long as its + -- underlying type 'Vec n t' is specified or can be inferred. + -- Here is another way to define the same vector v: + v' :: GLExpr d (Vec 4 Float) + v' = 1 + + -- Matrices are constructed from their columns: + m :: GLExpr d (Mat 2 3 Float) + m = mat2x3 (vec2 1 2) (vec2 3 4) (vec2 5 6) + + -- Operators like (.+) and (.*) act component-wise on vectors and matrices: + _ = m .+ m .== mat2x3 (vec2 2 4) (vec2 6 8) (vec2 10 12) + + -- Non-boolean primitives and vectors over such types are instances of Num; + -- in such cases Num methods like (+) can be used instead. + _ = vec2 1 1 + 1 .== vec2 2 2 + + -- The operator (.#) performs scalar multiplication: + _ = 3 .# v + _ = 3 .# m + + -- The operator (.\@) performs matrix multiplication + -- (including matrix-vector multiplication): + m1 :: GLExpr d (Mat 2 3 Float) + m1 = ... + m2 :: GLExpr d (Mat 3 4 Float) + m2 = ... + m1m2 :: GLExpr d (Mat 2 4 Float) + m1m2 = m1 .\@ m2 + + -- All multiplications here will take place in a vertex shader: + m1m2v :: GLExpr VertexDomain (Vec 2 Float) + m1m2v = m1m2 .\@ v + + -- The inferred type of m1m2 in this expression is + -- 'GLExpr HostDomain (Mat 2 4 Float)' so the multiplication of m1 and m2 + -- will take place on the CPU. + -- The inferred type of uniform m1m2 is 'GLExpr VertexDomain (Mat 2 4 Float)' + -- and that of v is 'GLExpr VertexDomain (Vec 2 Float)' so their + -- multiplication will take place in a vertex shader. + m1m2v' :: GLExpr VertexDomain (Vec 2 Float) + m1m2v' = uniform m1m2 .\@ v + +@ + +`GLExpr`s can be used to construct `GLObj`s, which being instances +of 'Drawable' can be interpreted by a given 'Backend' using 'draw'. +For example: + +@ +-- initialize pos from the vertices of some 3D object +pos :: GLExpr VertexDomain (Vec 4 Float) +pos = vert [vec4 1 0 0 1, ...] + +red :: GLExpr FragmentDomain (Vec 4 Float) +red = vec4 1 0 0 1 + +redObj :: GLObj +redObj = GLObj { + primitiveMode = TriangleStrip, + indices = Nothing, + position = pos, + color = red, + discardWhen = False +} + +-- or equivalently, +redObj' :: GLObj +redObj' = triangleStrip { position = pos, color = red } + +-- we can now draw the object +main :: IO () +main = draw GlutBackend redObj +@ + +A complete set of examples explained in more depth can be found in +the ["Getting Started"](https://github.com/simeonkr/HaGL/blob/master/doc/Overview.md) guide. + +-} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -dth-dec-file #-} +-- required due to use of genID +{-# OPTIONS_GHC -fno-full-laziness #-} + +module Graphics.HaGL ( + -- * @GLType@ + -- | Any instance of 'GLType' can be the underlying type @t@ of a 'GLExpr' + -- These types are: + -- + -- * Primitive types: 'Float', 'Double', 'Int', 'UInt', 'Bool' + -- + -- * Vectors: 'Vec' @n@ @Float@, 'Vec' @n@ @Double@, 'Vec' @n@ @Int@, + -- 'Vec' @n@ @UInt@, 'Vec' @n@ @Bool@ + -- + -- * Matrices: 'Mat' @p@ @q@ @Float@, 'Mat' @p@ @q@ @Double@ + -- + -- * Arrays: Represented as [t], where @t@ is a primitive type or a vector + GLType, + Float, Double, Int, UInt, Bool, + Mat, Vec, + GLElt, + -- ** Raw vector/matrix constructors + -- | Though raw types are not usually constructed directly, the following + -- functions can be used for loading data from externally computed arrays + -- via [lifts](#lifts). + fromMapping, + fromList, + -- ** Subclasses of @GLType@ + GLPrim, GLSingle, GLNumeric, GLSigned, GLFloating, GLSingleNumeric, GLInteger, + GLPrimOrVec, GLInputType, + GLSupportsSmoothInterp, GLSupportsBitwiseOps, + -- * @GLExpr@ + -- | A HaGL expression can be created in one of the following ways: + -- + -- * Using one of the HaGL-specific [constructors](#constructors) + -- + -- * Directly from a numeric literal, if its underlying type @t@ is one of + -- 'Int', 'UInt', 'Float', 'Double', or a 'Vec' of one of these types. + -- (A vector initialized from a value @c@ is the vector with all elements + -- equal to c.) + -- + -- * Through the application of [built-in operators and functions](#builtins) + -- + GLExpr, + GLDomain(..), + ConstExpr, + HostExpr, + VertExpr, + FragExpr, + -- * Constructors #constructors# + cnst, + true, + false, + uniform, + prec, + vert, + frag, + noperspFrag, + flatFrag, + -- ** Vector, matrix, and array constructors + -- | A constructor of the form vec/n/ creates a column vector with + -- /n/ components; a constructor of the form mat/p/x/q/ creates a matrix + -- with /p/ rows and /q/ columns (mat/p/ is an alias for mat/p/x/p/). + vec2, vec3, vec4, + mat2, mat3, mat4, + mat2x2, mat2x3, mat2x4, + mat3x2, mat3x3, mat3x4, + mat4x2, mat4x3, mat4x4, + pre, + app, + ($-), + array, + -- * Deconstruction and indexing + -- | To deconstruct a vector into a tuple of primitive elements or to + -- deconstruct a matrix into a tuple of column vectors use 'decon'. This + -- approach pairs particularly well with view patterns: + -- + -- @ + -- vec2Flip :: GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) + -- vec2Flip (decon v2 -> (v1, v2)) = vec2 v2 v1 + -- @ + -- + -- Alternatively, with the synonyms @x@, @y@, @z@, @w@, referring to the + -- components of a vector in that order, projection functions consisting of + -- an ordered selection of such names followed by an underscore (e.g., 'xyz_'), + -- can be used to extract the corresponding components. For matrices, the + -- projection functions are of the form col/n/. Note that the types of these + -- functions constrains the length of their input so that the operation is + -- well-defined. + Deconstructible(..), + x_, y_, z_, w_, + xy_, xz_, xw_, + yx_, yz_, yw_, + zx_, zy_, zw_, + wx_, wy_, wz_, + xyz_, xyw_, xzy_, xzw_, xwy_, xwz_, + yxz_, yxw_, yzx_, yzw_, ywx_, ywz_, + zxy_, zxw_, zyx_, zyw_, zwx_, zwy_, + wxy_, wxz_, wyx_, wyz_, wzx_, wzy_, + col0, col1, col2, col3, + (.!), + -- * Type conversion + cast, + matCast, + -- * Built-in operators and functions #builtins# + -- | Most definitions here strive to be consistent with the corresponding + -- built-in functions provided by GLSL + -- (cf. [The OpenGL Shading Language, Version 4.60.7] + -- (https://registry.khronos.org/OpenGL/specs/gl/GLSLangSpec.4.60.pdf)), + -- in terms of semantics and typing constraints. Some notable exceptions + -- to this rule are: + -- + -- * Typing restrictions may be stricter to prevent what would otherwise be + -- runtime errors; for example, matrix multiplication is only defined on + -- matrices with the correct dimensions. + -- + -- * The operators @(+)@, @(-)@, @(*)@, as well as the function @negate@, + -- being methods of @Num@, are only supported on expressions where the + -- underlying type is one of 'Int', 'UInt', 'Float', 'Double', or a + -- vector of one of these types. + -- To perform these operations component-wise on matrices use the operators + -- @(.+)@, @(.-)@, @(.*)@, or the function @neg@ respectively. + -- + -- * The operator @(/)@ is only supported when the underlying type is + -- 'Float' or 'Double'. The more general operator @(./)@ additionally + -- supports integer and component-wise division. + -- + -- * The operator @(.%)@ is the modulo operation on integers or + -- integer-valued vectors. + -- + -- * The operator @(.#)@ is used for scalar multiplication. + -- + -- * The operator @(.\@)@ is used for matrix (including matrix-vector) multiplication. + -- + -- * All boolean and bitwise operators are also prefixed with a single dot: + -- @(.==)@, @(.<)@, @(.&&)@, @(.&)@, etc. + + -- ** Arithmetic operators + (.+), + (.-), + (.*), + (./), + (.%), + (.#), + (.@), + neg, + -- ** Boolean operators and comparison functions + (.<), + (.<=), + (.>), + (.>=), + (.==), + (./=), + (.&&), + (.||), + (.^^), + nt, + cond, + -- ** Bitwise operators + (.<<), + (.>>), + (.&), + (.|), + (.^), + compl, + -- ** Angle and trigonometry functions + radians, + degrees, + Graphics.HaGL.sin, + Graphics.HaGL.cos, + Graphics.HaGL.tan, + Graphics.HaGL.asin, + Graphics.HaGL.acos, + Graphics.HaGL.atan, + Graphics.HaGL.sinh, + Graphics.HaGL.cosh, + Graphics.HaGL.tanh, + Graphics.HaGL.asinh, + Graphics.HaGL.acosh, + Graphics.HaGL.atanh, + -- ** Exponential functions + pow, + Graphics.HaGL.exp, + Graphics.HaGL.log, + exp2, + log2, + Graphics.HaGL.sqrt, + inversesqrt, + -- ** Common functions + Graphics.HaGL.abs, + sign, + Graphics.HaGL.floor, + trunc, + Graphics.HaGL.round, + roundEven, + ceil, + fract, + Graphics.HaGL.mod, + Graphics.HaGL.min, + Graphics.HaGL.max, + clamp, + mix, + step, + smoothstep, + -- ** Geometric functions + Graphics.HaGL.length, + distance, + dot, + cross, + normalize, + faceforward, + reflect, + refract, + -- ** Matrix functions + matrixCompMult, + outerProduct, + transpose, + determinant, + inverse, + -- ** Vector relational functions + lessThan, + lessThanEqual, + greaterThan, + greaterThanEqual, + equal, + notEqual, + Graphics.HaGL.any, + Graphics.HaGL.all, + Graphics.HaGL.not, + -- * Custom function support + -- | An n-ary @f@ function on @GLExpr@'s can be transported to an arbitrary + -- domain using @glFunc/n/@. That is, @glFunc/n/ f@ will take in the same + -- arguments as f but will be evaluated in the domain of its return type + -- (in contrast to @f@, which being a native Haskell function, will always + -- be evaluated on the CPU). + -- + -- However, due to the fact that GLSL does not allow recursion, attempting + -- to call @glFunc/n/ f@, where @f@ is defined recursively (or mutually + -- recursively in terms of other functions) will generally result in an + -- exception being thrown. The one case where this is permissible is that of + -- /tail-recursive/ functions of the form + -- + -- @ + -- f x1 x2 ... = cond c b (f y1 y2 ...) + -- @ + -- + -- where none of the expressions @c@, @b@, @y1@, @y2@, ... depend on @f@. Where + -- applicable, such functions will be synthesized as GLSL loops. For example, + -- the factorial function can be computed within a vertex shader as follows: + -- + -- @ + -- fact = glFunc1 $ \\n -> fact' n 1 where + -- fact' :: GLExpr VertexDomain Int -> GLExpr VertexDomain Int -> GLExpr VertexDomain Int + -- fact' = glFunc2 $ \\n a -> cond (n .== 0) a (fact' (n - 1) (a * n)) + -- + -- x :: GLExpr VertexDomain Int + -- x = fact 5 + -- @ + glFunc1, + glFunc2, + glFunc3, + glFunc4, + glFunc5, + glFunc6, + -- * Lifts from raw types #lifts# + -- | If the need arises to use an n-ary native function @f@ that is not defined + -- over @GLExpr@'s (for instance, to dynamically update array contents using + -- functions defined on lists), such a function can be lifted to the + -- @HostDomain@ using @glLift/n/@. @glLift/n/ f@ will then be defined over + -- `HostExpr`s that agree with respective argument types of @f@. For example, + -- the two expressions below compute the same array: + -- + -- @ + -- a1 :: GLExpr HostDomain [Float] + -- a1 = (glLift2 $ \\x y -> [x, y, x + y]) time time + -- a2 :: GLExpr HostDomain [Float] + -- a2 = array [time, 2 * time, 3 * time] + -- @ + -- + glLift0, + glLift1, + glLift2, + glLift3, + glLift4, + glLift5, + glLift6, + -- * Built-in I/O variables + time, + mouseLeft, + mouseRight, + mouseWheel, + mouseX, + mouseY, + mousePos, + -- * Drawables + Drawable(..), + GLObj(..), + PrimitiveMode, + points, + Graphics.HaGL.lines, + lineLoop, + lineStrip, + triangles, + triangleStrip, + triangleFan, + quads, + quadStrip, + polygon, + -- * Backends + Backend(..), + GlutOptions(..), + GlutRunMode(..), + drawGlut, + drawGlutCustom, + defaultGlutOptions, +) where + +import GHC.TypeNats (KnownNat) +import qualified Graphics.Rendering.OpenGL as OpenGL + +import Graphics.HaGL.TH.HaGL (gen2DCoordDecls, gen3DCoordDecls) +import Graphics.HaGL.Numerical (Mat, Vec, fromMapping, fromList) +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr +import Graphics.HaGL.ExprID (genID) +import Graphics.HaGL.GLObj +import Graphics.HaGL.Eval +import Graphics.HaGL.Backend.GLUT + + +{-# NOINLINE mkExpr #-} +mkExpr con e = con (genID e) e + + +-- Instance declarations + +instance GLPrim t => Enum (ConstExpr t) where + toEnum x = mkExpr GLAtom $ Const (toEnum x) + fromEnum = fromEnum . constEval + +instance {-# OVERLAPPING #-} (GLSigned (GLElt t), GLPrimOrVec t, Num t) => Num (GLExpr d t) where + x + y = mkExpr GLGenExpr $ OpAdd x y + x - y = mkExpr GLGenExpr $ OpSubt x y + x * y = mkExpr GLGenExpr $ OpMult x y + negate x = mkExpr GLGenExpr $ OpNeg x + abs x = mkExpr GLGenExpr $ Abs x + signum x = mkExpr GLGenExpr $ Sign x + fromInteger x = mkExpr GLAtom $ Const (fromInteger x) + +-- Unsigned integers need to be handled separately as GLSL does not +-- support all the operations corresponding to those required for Num + +instance {-# OVERLAPPING #-} Num (GLExpr d UInt) where + x + y = mkExpr GLGenExpr $ OpAdd x y + x - y = mkExpr GLGenExpr $ OpSubt x y + x * y = mkExpr GLGenExpr $ OpMult x y + negate x = + mkExpr GLGenExpr $ Cast $ + mkExpr GLGenExpr $ OpNeg + (mkExpr GLGenExpr $ Cast x :: GLExpr _ Int) + abs x = x + signum x = mkExpr GLGenExpr $ Cast + (mkExpr GLGenExpr $ Cast x :: GLExpr _ Bool) + fromInteger x = mkExpr GLAtom $ Const (fromInteger x) + +instance {-# OVERLAPPING #-} (GLType (Vec n UInt), GLType (Vec n Int), GLType (Vec n Bool), KnownNat n) => Num (GLExpr d (Vec n UInt)) where + x + y = mkExpr GLGenExpr $ OpAdd x y + x - y = mkExpr GLGenExpr $ OpSubt x y + x * y = mkExpr GLGenExpr $ OpMult x y + negate x = + mkExpr GLGenExpr $ MatCast $ + mkExpr GLGenExpr $ OpNeg + (mkExpr GLGenExpr $ MatCast x :: GLExpr _ (Vec _ Int)) + abs x = x + signum x = + mkExpr GLGenExpr $ MatCast + (mkExpr GLGenExpr $ MatCast x :: GLExpr _ (Vec _ Bool)) + fromInteger x = mkExpr GLAtom $ Const (fromInteger x) + +instance (GLFloating (GLElt t), GLPrimOrVec t, Fractional t) => Fractional (GLExpr d t) where + x / y = mkExpr GLGenExpr $ OpDiv x y + fromRational x = mkExpr GLAtom $ Const (fromRational x) + +instance (GLElt t ~ Float, GLPrimOrVec t, Fractional t) => Floating (GLExpr d t) where + pi = 3.141592653589793238 + sin x = mkExpr GLGenExpr $ Sin x + cos x = mkExpr GLGenExpr $ Cos x + tan x = mkExpr GLGenExpr $ Tan x + asin x = mkExpr GLGenExpr $ Asin x + acos x = mkExpr GLGenExpr $ Acos x + atan x = mkExpr GLGenExpr $ Atan x + sinh x = mkExpr GLGenExpr $ Sinh x + cosh x = mkExpr GLGenExpr $ Cosh x + tanh x = mkExpr GLGenExpr $ Tanh x + asinh x = mkExpr GLGenExpr $ Asinh x + acosh x = mkExpr GLGenExpr $ Acosh x + atanh x = mkExpr GLGenExpr $ Atanh x + x ** y = mkExpr GLGenExpr $ Pow x y + exp x = mkExpr GLGenExpr $ Exp x + sqrt x = mkExpr GLGenExpr $ Sqrt x + log x = mkExpr GLGenExpr $ Log x + + +-- * Constructors + +-- | Construct a @GLExpr@ from a raw type. Rarely useful as this can +-- be done implicitly; e.g., from a numeric literal. +cnst :: GLType t => ConstExpr t -> GLExpr d t +cnst x = mkExpr GLAtom $ Const (constEval x) + +true, false :: GLExpr d Bool +-- | The boolean value @true@ +true = cnst $ toEnum 1 +-- | The boolean value @false@ +false = cnst $ toEnum 0 + +-- | Lift a `HostExpr` to an arbitrary @GLExpr@ whose value is the same across +-- any primitive processed in a shader, if used in the context of one +uniform :: GLType t => HostExpr t -> GLExpr d t +uniform x = mkExpr GLAtom $ Uniform x + +-- | @prec x0 x@ is used to obtain a reference to the value @x@ one "time-step" +-- in the past, or @x0@ at the zero-th point in time. The @prec@ operator is +-- usually used to define expressions recurrently; for example: +-- @let x = prec 0 (x + 1)@ counts the total number of points in time. The +-- interpretation of a time-step in a given backend is normally an interval +-- that is on average equal to the length of time between two redraws. +prec :: GLType t => HostExpr t -> HostExpr t -> HostExpr t +prec x0 x = mkExpr GLAtom $ IOPrec x0 x + + +-- | A vertex input variable (attribute) constructed from a stream of per-vertex +-- data. The number of vertices (the length of the stream) should be consistent +-- across all vertex attributes used to construct a given @GLObj@. +vert :: GLInputType t => [ConstExpr t] -> VertExpr t +vert inp = mkExpr GLAtom $ Inp inp + +-- | A fragment input variable constructed from the output data of a vertex +-- variable, interpolated in a perspective-correct manner over the primitive +-- being processed +frag :: GLSupportsSmoothInterp t => VertExpr t -> FragExpr t +frag x = mkExpr GLAtom $ Frag Smooth x + +-- | A fragment input variable constructed from the output data of a vertex +-- variable, interpolated linearly across the primitive being processed +noperspFrag :: GLSupportsSmoothInterp t => GLInputType t => VertExpr t -> FragExpr t +noperspFrag x = mkExpr GLAtom $ Frag NoPerspective x + +-- | A fragment input variable constructed from the output data of a vertex +-- variable, having the same value across the primitive being processed +-- (cf. the OpenGL API for which vertex is used to determine its value) +flatFrag :: GLInputType t => VertExpr t -> FragExpr t +flatFrag x = mkExpr GLAtom $ Frag Flat x + + +-- * Vector, matrix, and array constructors + +vec2 x y = mkExpr GLGenExpr $ GLVec2 x y +vec3 x y z = mkExpr GLGenExpr $ GLVec3 x y z +vec4 x y z w = mkExpr GLGenExpr $ GLVec4 x y z w +mat2 x y = mat2x2 x y +mat3 x y z = mat3x3 x y z +mat4 x y z w = mat4x4 x y z w +mat2x2 x y = mkExpr GLGenExpr $ GLMat2x2 x y +mat2x3 x y z = mkExpr GLGenExpr $ GLMat2x3 x y z +mat2x4 x y z w = mkExpr GLGenExpr $ GLMat2x4 x y z w +mat3x2 x y = mkExpr GLGenExpr $ GLMat3x2 x y +mat3x3 x y z = mkExpr GLGenExpr $ GLMat3x3 x y z +mat3x4 x y z w = mkExpr GLGenExpr $ GLMat3x4 x y z w +mat4x2 x y = mkExpr GLGenExpr $ GLMat4x2 x y +mat4x3 x y z = mkExpr GLGenExpr $ GLMat4x3 x y z +mat4x4 x y z w = mkExpr GLGenExpr $ GLMat4x4 x y z w + +-- | Extend a vector by prepending an element +pre x y = mkExpr GLGenExpr $ Pre x y +-- | Extend a vector by appending an element +app x y = mkExpr GLGenExpr $ App x y + +infixr 8 $- + +-- | Concatenate two vectors together +x $- y = mkExpr GLGenExpr $ Conc x y + +-- | Create an array from a list of 'HostExpr's +array xs = mkExpr GLGenExpr $ GLArray xs + + +-- * Deconstruction and indexing + +x_ v = mkExpr GLGenExpr $ OpCoord CoordX v +y_ v = mkExpr GLGenExpr $ OpCoord CoordY v +z_ v = mkExpr GLGenExpr $ OpCoord CoordZ v +w_ v = mkExpr GLGenExpr $ OpCoord CoordW v +$gen2DCoordDecls +$gen3DCoordDecls + +-- | The first column of a matrix +col0 m = mkExpr GLGenExpr $ OpCol Col0 m +-- | The second column of a matrix +col1 m = mkExpr GLGenExpr $ OpCol Col1 m +-- | The third column of a matrix +col2 m = mkExpr GLGenExpr $ OpCol Col2 m +-- | The fourth column of a matrix +col3 m = mkExpr GLGenExpr $ OpCol Col3 m + +-- | Array index operator, returning the @i@-th (0-indexed) element of the array +arr .! i = mkExpr GLGenExpr $ OpArrayElt arr i + +-- | An expression that can be deconstructed into its components +class Deconstructible t where + -- | The resulting type of the deconstruction + type Decon t + -- | Deconstruct the given expression + decon :: t -> Decon t + +instance (GLPrim t, GLType (Vec 2 t)) => Deconstructible (GLExpr d (Vec 2 t)) where + type Decon (GLExpr d (Vec 2 t)) = (GLExpr d t, GLExpr d t) + decon v = (x_ v, y_ v) +instance (GLPrim t, GLType (Vec 3 t)) => Deconstructible (GLExpr d (Vec 3 t)) where + type Decon (GLExpr d (Vec 3 t)) = (GLExpr d t, GLExpr d t, GLExpr d t) + decon v = (x_ v, y_ v, z_ v) +instance (GLPrim t, GLType (Vec 4 t)) => Deconstructible (GLExpr d (Vec 4 t)) where + type Decon (GLExpr d (Vec 4 t)) = (GLExpr d t, GLExpr d t, GLExpr d t, GLExpr d t) + decon v = (x_ v, y_ v, z_ v, w_ v) +instance (GLPrim t, GLType (Mat p 2 t), GLType (Vec p t)) => Deconstructible (GLExpr d (Mat p 2 t)) where + type Decon (GLExpr d (Mat p 2 t)) = (GLExpr d (Vec p t), GLExpr d (Vec p t)) + decon m = (col0 m, col1 m) +instance (GLPrim t, GLType (Mat p 3 t), GLType (Vec p t)) => Deconstructible (GLExpr d (Mat p 3 t)) where + type Decon (GLExpr d (Mat p 3 t)) = (GLExpr d (Vec p t), GLExpr d (Vec p t), GLExpr d (Vec p t)) + decon m = (col0 m, col1 m, col2 m) +instance (GLPrim t, GLType (Mat p 4 t), GLType (Vec p t)) => Deconstructible (GLExpr d (Mat p 4 t)) where + type Decon (GLExpr d (Mat p 4 t)) = (GLExpr d (Vec p t), GLExpr d (Vec p t), GLExpr d (Vec p t), GLExpr d (Vec p t)) + decon m = (col0 m, col1 m, col2 m, col3 m) + + +-- * Expression type conversion + +-- | Coerce the primitive type of a value to arbitrary primitive type +cast x = mkExpr GLGenExpr $ Cast x +-- | Coerce the element type of a matrix to an arbitrary primitive type +matCast m = mkExpr GLGenExpr $ MatCast m + + +-- * Built-in operators and functions + +infixl 6 .+, .- +infixl 7 .*, ./, .% +infix 4 .<, .<=, .>, .>=, .==, ./= +infixl 3 .&& +infixl 1 .|| +infixl 2 .^^ +infixl 5 .<<, .>> +infixl 3 .& +infixl 1 .| +infixl 2 .^ +infixl 7 .# +infixl 7 .@ + +x .+ y = mkExpr GLGenExpr $ OpAdd x y +x .- y = mkExpr GLGenExpr $ OpSubt x y +x .* y = mkExpr GLGenExpr $ OpMult x y +x ./ y = mkExpr GLGenExpr $ OpDiv x y +x .% y = mkExpr GLGenExpr $ OpMod x y +-- | Arithmetic negation +neg x = mkExpr GLGenExpr $ OpNeg x +x .< y = mkExpr GLGenExpr $ OpLessThan x y +x .<= y = mkExpr GLGenExpr $ OpLessThanEqual x y +x .> y = mkExpr GLGenExpr $ OpGreaterThan x y +x .>= y = mkExpr GLGenExpr $ OpGreaterThanEqual x y +x .== y = mkExpr GLGenExpr $ OpEqual x y +x ./= y = mkExpr GLGenExpr $ OpNotEqual x y +x .&& y = mkExpr GLGenExpr $ OpAnd x y +x .|| y = mkExpr GLGenExpr $ OpOr x y +x .^^ y = mkExpr GLGenExpr $ OpXor x y +-- | Logical not +nt x = mkExpr GLGenExpr $ OpNot x +-- | Conditional operator, evaluating and returning its second or third argument +-- if the first evaluates to true or false, respectively +cond x y z = mkExpr GLGenExpr $ OpCond x y z +x .<< y = mkExpr GLGenExpr $ OpLshift x y +x .>> y = mkExpr GLGenExpr $ OpRshift x y +x .& y = mkExpr GLGenExpr $ OpBitAnd x y +x .| y = mkExpr GLGenExpr $ OpBitOr x y +x .^ y = mkExpr GLGenExpr $ OpBitXor x y +-- | One's complement +compl x = mkExpr GLGenExpr $ OpCompl x +-- | Scalar multiplication +x .# y = mkExpr GLGenExpr $ OpScalarMult x y +-- | Matrix multiplication +x .@ y = mkExpr GLGenExpr $ OpMatrixMult x y + +radians x = mkExpr GLGenExpr $ Radians x +degrees x = mkExpr GLGenExpr $ Degrees x +sin x = mkExpr GLGenExpr $ Sin x +cos x = mkExpr GLGenExpr $ Cos x +tan x = mkExpr GLGenExpr $ Tan x +asin x = mkExpr GLGenExpr $ Asin x +acos x = mkExpr GLGenExpr $ Acos x +atan x = mkExpr GLGenExpr $ Atan x +sinh x = mkExpr GLGenExpr $ Sin x +cosh x = mkExpr GLGenExpr $ Cos x +tanh x = mkExpr GLGenExpr $ Tan x +asinh x = mkExpr GLGenExpr $ Asin x +acosh x = mkExpr GLGenExpr $ Acos x +atanh x = mkExpr GLGenExpr $ Atan x + +pow x y = mkExpr GLGenExpr $ Pow x y +exp x = mkExpr GLGenExpr $ Exp x +log x = mkExpr GLGenExpr $ Log x +exp2 x = mkExpr GLGenExpr $ Exp2 x +log2 x = mkExpr GLGenExpr $ Log2 x +sqrt x = mkExpr GLGenExpr $ Sqrt x +inversesqrt x = mkExpr GLGenExpr $ Inversesqrt x + +abs x = mkExpr GLGenExpr $ Abs x +sign x = mkExpr GLGenExpr $ Sign x +floor x = mkExpr GLGenExpr $ Floor x +trunc x = mkExpr GLGenExpr $ Trunc x +round x = mkExpr GLGenExpr $ Round x +roundEven x = mkExpr GLGenExpr $ RoundEven x +ceil x = mkExpr GLGenExpr $ Ceil x +fract x = mkExpr GLGenExpr $ Fract x +mod x y = mkExpr GLGenExpr $ Mod x y +min x y = mkExpr GLGenExpr $ Min x y +max x y = mkExpr GLGenExpr $ Max x y +clamp x y z = mkExpr GLGenExpr $ Clamp x y z +mix x y z = mkExpr GLGenExpr $ Mix x y z +step x y = mkExpr GLGenExpr $ Step x y +smoothstep x y z = mkExpr GLGenExpr $ Smoothstep x y z + +length x = mkExpr GLGenExpr $ Length x +distance x y = mkExpr GLGenExpr $ Distance x y +dot x y = mkExpr GLGenExpr $ Dot x y +cross x y = mkExpr GLGenExpr $ Cross x y +normalize x = mkExpr GLGenExpr $ Normalize x +faceforward x y z = mkExpr GLGenExpr $ Faceforward x y z +reflect x y = mkExpr GLGenExpr $ Reflect x y +refract x y z = mkExpr GLGenExpr $ Refract x y z + +matrixCompMult x y = mkExpr GLGenExpr $ MatrixCompMult x y +outerProduct x y = mkExpr GLGenExpr $ OuterProduct x y +transpose x = mkExpr GLGenExpr $ Transpose x +determinant x = mkExpr GLGenExpr $ Determinant x +inverse x = mkExpr GLGenExpr $ Inverse x + +lessThan x y = mkExpr GLGenExpr $ LessThan x y +lessThanEqual x y = mkExpr GLGenExpr $ LessThanEqual x y +greaterThan x y = mkExpr GLGenExpr $ GreaterThan x y +greaterThanEqual x y = mkExpr GLGenExpr $ GreaterThanEqual x y +equal x y = mkExpr GLGenExpr $ Equal x y +notEqual x y = mkExpr GLGenExpr $ NotEqual x y +any x = mkExpr GLGenExpr $ Any x +all x = mkExpr GLGenExpr $ All x +not x = mkExpr GLGenExpr $ Not x + + +-- * Custom function support + +makeGenVar _ = mkExpr GLAtom GenVar + +{-# NOINLINE glFunc1 #-} +glFunc1 :: (GLType t, GLType t1) => + (GLExpr d t1 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t +glFunc1 f = (GLFunc (genID f)) . GLFunc1 f x + where x = makeGenVar "x" +{-# NOINLINE glFunc2 #-} +glFunc2 :: (GLType t, GLType t1, GLType t2) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t +glFunc2 f = (GLFunc (genID f) .) . GLFunc2 f x y + where (x, y) = (makeGenVar "x", makeGenVar "y") +{-# NOINLINE glFunc3 #-} +glFunc3 :: (GLType t, GLType t1, GLType t2, GLType t3) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t +glFunc3 f = ((GLFunc (genID f) .) .) . GLFunc3 f x y z + where (x, y, z) = (makeGenVar "x", makeGenVar "y", makeGenVar "z") +{-# NOINLINE glFunc4 #-} +glFunc4 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t +glFunc4 f = (((GLFunc (genID f) .) .) .) . GLFunc4 f x y z w + where (x, y, z, w) = (makeGenVar "x", makeGenVar "y", makeGenVar "z", makeGenVar "w") +{-# NOINLINE glFunc5 #-} +glFunc5 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4, GLType t5) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5-> GLExpr d t +glFunc5 f = ((((GLFunc (genID f) .) .) .) .) . GLFunc5 f x y z w v + where (x, y, z, w, v) = (makeGenVar "x", makeGenVar "y", makeGenVar "z", makeGenVar "w", makeGenVar "u") +{-# NOINLINE glFunc6 #-} +glFunc6 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4, GLType t5, GLType t6) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t6 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t6 -> GLExpr d t +glFunc6 f = (((((GLFunc (genID f) .) .) .) .) .) . GLFunc6 f x y z w u v + where (x, y, z, w, u, v) = (makeGenVar "x", makeGenVar "y", makeGenVar "z", makeGenVar "w", makeGenVar "u", makeGenVar "v") + + +-- Lifts from raw types + +glLift0 x = mkExpr GLAtom $ GLLift0 x +glLift1 f x = mkExpr GLAtom $ GLLift1 f x +glLift2 f x y = mkExpr GLAtom $ GLLift2 f x y +glLift3 f x y z = mkExpr GLAtom $ GLLift3 f x y z +glLift4 f x y z w = mkExpr GLAtom $ GLLift4 f x y z w +glLift5 f x y z w u = mkExpr GLAtom $ GLLift5 f x y z w u +glLift6 f x y z w u v = mkExpr GLAtom $ GLLift6 f x y z w u v + + +-- * Built-in I/O variables + +-- | Seconds elapsed since an initial point in time +time :: HostExpr Float +time = mkExpr GLAtom $ IOFloat "time" + +-- | True if and only if the left mouse button is pressed +mouseLeft :: HostExpr Bool +mouseLeft = mkExpr GLAtom $ IOBool "mouseLeft" + +-- | True if and only if the right mouse button is pressed +mouseRight :: HostExpr Bool +mouseRight = mkExpr GLAtom $ IOBool "mouseRight" + +-- | A pulse signal, equal to 1 at the moment the mouse wheel scrolls up, -1 when +-- the mouse wheel scrolls down, and afterwards exponentially decaying to its +-- otherwise default value of 0 +mouseWheel :: HostExpr Float +mouseWheel = mkExpr GLAtom $ IOFloat "mouseWheel" + +-- | The horizontal position of the mouse, not necessarily within the window bounds +mouseX :: HostExpr Float +mouseX = mkExpr GLAtom $ IOFloat "mouseX" + +-- | The vertical position of the mouse, not necessarily within the window bounds +mouseY :: HostExpr Float +mouseY = mkExpr GLAtom $ IOFloat "mouseY" + +-- | Equal to @vec2 mouseX mouseY@ +mousePos :: HostExpr (Vec 2 Float) +mousePos = mkExpr GLGenExpr $ GLVec2 mouseX mouseY + + +-- * Drawables + +-- | Anything that can be drawn using a given 'Backend' +class Drawable a where + draw :: Backend -> a -> IO () + +-- | A 'GLObj' is drawn by constructing primitives from its 'position' and +-- 'indices' expressions, according to its 'primitiveMode', and coloring the +-- resulting fragments according to its 'color' expression. +instance Drawable GLObj where + draw backend obj = draw backend [obj] + +-- | A set of 'GLObj's is drawn by drawing each 'GLObj' individually and with the +-- same blending mode as that used to draw a single 'GLObj'. +instance Drawable [GLObj] where + draw (GlutBackend userInit) objs = runGlut userInit objs + +defaultObj = GLObj { + primitiveMode = OpenGL.Points, + indices = Nothing, + position = vec4 0 0 0 0, + color = vec4 0 0 0 0, + discardWhen = false +} + +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.Points' +points = defaultObj { primitiveMode = OpenGL.Points } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.Lines' +lines = defaultObj { primitiveMode = OpenGL.Lines } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.LineLoop' +lineLoop = defaultObj { primitiveMode = OpenGL.LineLoop } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.LineStrip' +lineStrip = defaultObj { primitiveMode = OpenGL.LineStrip } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.Triangles' +triangles = defaultObj { primitiveMode = OpenGL.Triangles } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.TriangleStrip' +triangleStrip = defaultObj { primitiveMode = OpenGL.TriangleStrip } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.TriangleFan' +triangleFan = defaultObj { primitiveMode = OpenGL.TriangleFan } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.Quads' +quads = defaultObj { primitiveMode = OpenGL.Quads } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.QuadStrip' +quadStrip = defaultObj { primitiveMode = OpenGL.QuadStrip } +-- | An incompletely specified object with 'PrimitiveMode' equal to 'OpenGL.Polygon' +polygon = defaultObj { primitiveMode = OpenGL.Polygon } + + +-- * Backends + +-- | A backend that can interpret (draw) a 'Drawable'. +-- Unless overridden the following OpenGL options are set by default in all backends: +-- +-- * Clear color equal to black +-- +-- * Depth testing enabled +-- +-- * Blending enabled with blend equation equal to GL_FUNC_ADD +-- +-- * Source blending factor equal to GL_SRC_ALPHA +-- +-- * Destination blending factor equal to GL_ONE_MINUS_SRC_ALPHA +data Backend = + + GlutBackend GlutOptions + +-- | Draw in a GLUT backend using default options +drawGlut :: Drawable a => a -> IO () +drawGlut = draw (GlutBackend defaultGlutOptions) + +-- | Draw in a GLUT backend using specified options +drawGlutCustom :: Drawable a => GlutOptions -> a -> IO () +drawGlutCustom options = draw (GlutBackend options) + +-- | Default options for a GLUT backend +-- +-- * @winSize = (768, 768)@ +-- * @clearCol = (0, 0, 0, 0)@ +-- * @runMode = GlutNormal@ +defaultGlutOptions :: GlutOptions +defaultGlutOptions = GlutOptions { + winPosition = Nothing, + winSize = (768, 768), + winFullscreen = False, + winTitle = Nothing, + clearCol = (0, 0, 0, 0), + runMode = GlutNormal, + openGLSetup = return () +} diff --git a/src/Graphics/HaGL/Backend.hs b/src/Graphics/HaGL/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Backend.hs @@ -0,0 +1,104 @@ +module Graphics.HaGL.Backend ( + RunObj(..), + genRunObj, + makeOff +) where + +import Prelude hiding (id) +import Control.Monad (unless) +import Foreign.Marshal.Array (withArray) +import Foreign.Ptr (Ptr, wordPtrToPtr) +import Graphics.Rendering.OpenGL hiding (PrimitiveMode) + +import qualified Data.Set as Set + +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr +import Graphics.HaGL.ExprID +import Graphics.HaGL.GLObj +import Graphics.HaGL.Eval +import Graphics.HaGL.CodeGen (GLProgram(GLProgram), InpVar(..), UniformVar(..), genProgram) + + +-- RunObj = GLProgram transformed to low-level OpenGL data + +data RunObj = RunObj { + primitiveMode :: PrimitiveMode, + indices :: Maybe [ConstExpr UInt], + uniformVars :: Set.Set UniformVar, + numVerts :: Int, + vao :: VertexArrayObject, + prog :: Program +} + +genRunObj :: GLObj -> IO RunObj +genRunObj = progToRunObj . genProgram + +progToRunObj :: GLProgram -> IO RunObj +progToRunObj (GLProgram primitiveMode indices + uniformVars inputVars numElts vertexShader fragmentShader) = do + + vs <- loadShader VertexShader $ show vertexShader + fs <- loadShader FragmentShader $ show fragmentShader + prog <- createProgram + attachShader prog vs + attachShader prog fs + linkProgram prog + + vao <- genObjectName + bindVertexArrayObject $= Just vao + + -- TODO: it is more efficient to form a + -- single buffer from all the input data + mapM_ (bindAttrDat prog) inputVars + + bindIndices indices + + return $ RunObj primitiveMode indices + uniformVars numElts vao prog + +loadShader :: ShaderType -> String -> IO Shader +loadShader stype src = do + shader <- createShader stype + shaderSourceBS shader $= packUtf8 src + compileShader shader + ok <- get (compileStatus shader) + infoLog <- get (shaderInfoLog shader) + unless (null infoLog || infoLog == "\NUL") + (mapM_ putStrLn ["Shader info log:", infoLog, ""]) + unless ok $ do + deleteObjectName shader + ioError (userError "shader compilation failed") + return shader + +bindAttrDat :: Program -> InpVar -> IO () +bindAttrDat prog (InpVar id xs) = do + arrayBuffer <- genObjectName + bindBuffer ArrayBuffer $= Just arrayBuffer + let val = map constEval xs + let size = fromIntegral $ eltSize val * numComponents val * length val + withArray (toStorableList val) $ \ptr -> + bufferData ArrayBuffer $= (size, ptr, StaticDraw) + + attr <- get (attribLocation prog $ idLabel id) + let numComps = fromIntegral $ numComponents val + let intHandling = case getGlslType val of + Int -> KeepIntegral + UnsignedInt -> KeepIntegral + Byte -> KeepIntegral + _ -> ToFloat + vertexAttribPointer attr $= + (intHandling, VertexArrayDescriptor numComps (getGlslType val) 0 (makeOff 0)) + vertexAttribArray attr $= Enabled + +bindIndices :: Maybe [ConstExpr UInt] -> IO () +bindIndices (Just inds) = do + elementArrayBuffer <- genObjectName + bindBuffer ElementArrayBuffer $= Just elementArrayBuffer + let indSize = fromIntegral $ 4 * length inds + withArray (map constEval inds) $ \ptr -> + bufferData ElementArrayBuffer $= (indSize, ptr, StaticDraw) +bindIndices _ = return () + +makeOff :: Int -> Ptr a +makeOff = wordPtrToPtr . fromIntegral diff --git a/src/Graphics/HaGL/Backend/GLUT.hs b/src/Graphics/HaGL/Backend/GLUT.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Backend/GLUT.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Graphics.HaGL.Backend.GLUT ( + GlutOptions(..), + GlutRunMode(..), + runGlut +) where + +import Prelude hiding (id) +import Control.Monad (when) +import Data.Functor.Identity +import Data.IORef +import Data.Time.Clock +import qualified Data.ByteString as BS +import Graphics.Rendering.OpenGL +import Graphics.Rendering.OpenGL.Capture +import Graphics.UI.GLUT + +import Graphics.HaGL.Backend +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr +import Graphics.HaGL.ExprID +import Graphics.HaGL.GLObj (GLObj) +import Graphics.HaGL.Eval +import Graphics.HaGL.CodeGen (UniformVar(..)) + +import qualified Graphics.HaGL.Util.DepMap as DepMap + + +-- | Options specific to a GLUT window +data GlutOptions = GlutOptions { + -- | The position of the window + winPosition :: Maybe (GLint, GLint), + -- | The size of the window + winSize :: (GLsizei, GLsizei), + -- | Whether to draw in fullscreen mode + winFullscreen :: Bool, + -- | The title of the window + winTitle :: Maybe String, + -- | The (background) color to use when clearing the screen + clearCol :: (Float, Float, Float, Float), + -- | The 'GlutRunMode' under which to run the application + runMode :: GlutRunMode, + -- | Any additional OpenGL-specific setup to run just after the window has + -- been set up. The typical use-case is to import the OpenGL bindings + -- ('Graphics.Rendering.OpenGL') and define a @StateVar@ such as @lineWidth@ + openGLSetup :: IO () +} + +-- | 'GlutRunMode' specifies how to run the resulting application +data GlutRunMode = + -- | Display the output in a window + GlutNormal | + -- | Display the output in a window, saving the latest frame in the + -- specified file location + GlutCaptureLatest String | + -- | Display the output in a window, saving all frames in the specified + -- directory + GlutCaptureFrames String | + -- | Display the output in a window for a brief period time, saving the + -- latest frame in the specified file location + GlutCaptureAndExit String + + +runGlut :: GlutOptions -> [GLObj] -> IO () +runGlut options glObjs = do + initWindow options + + ioState <- initIOState + + runObjs <- mapM genRunObj glObjs + + idleCallback $= Just (update (runMode options) ioState runObjs) + displayCallback $= display runObjs + mouseCallback $= Just (mouse ioState) + motionCallback $= Just (motion ioState) + passiveMotionCallback $= Just (motion ioState) + + clearColor $= let (r, g, b, a) = clearCol options in Color4 r g b a + -- override default OpenGL values + -- TODO: should access to values like these be provided + -- directly, in the form of additional GlutOptions? + lineWidth $= 3 + pointSize $= 3 + + openGLSetup options + + mainLoop + +initWindow :: GlutOptions -> IO () +initWindow options = do + (progName, _) <- getArgsAndInitialize + _ <- createWindow progName + maybe (return ()) (\(x, y) -> windowPosition $= Position x y) + (winPosition options) + windowSize $= (\(x, y) -> Size x y) (winSize options) + when (winFullscreen options) fullScreen + maybe (return ()) (windowTitle $=) (winTitle options) + actionOnWindowClose $= MainLoopReturns + + initialDisplayMode $= [RGBAMode, WithAlphaComponent] + depthFunc $= Just Lequal + blend $= Enabled + blendEquation $= FuncAdd + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + +-- I/O state + +data IOState = IOState { + initTime :: Float, + precMap :: IORef (DepMap.DepMap (GLExpr HostDomain) Identity), + mouseLeftDown :: Bool, + mouseRightDown :: Bool, + mouseWheel :: Float, + curMouseX :: Int, + curMouseY :: Int, + -- for stats such as FPS + totUpdates :: Int, + curNumUpdates :: Int, + lastStatsUpdate :: Float +} + +defIOState :: IOState +defIOState = IOState { + initTime = 0, + precMap = undefined, + mouseLeftDown = False, + mouseRightDown = False, + mouseWheel = 0, + curMouseX = 0, + curMouseY = 0, + totUpdates = 0, + curNumUpdates = 0, + lastStatsUpdate = 0 +} + +initIOState :: IO (IORef IOState) +initIOState = do + epoch <- getCurrentTime + let initTime = fromRational $ toRational $ utctDayTime epoch + pm <- newIORef DepMap.empty + newIORef defIOState { initTime = initTime, lastStatsUpdate = initTime, precMap = pm } + + +-- Update logic + +update :: GlutRunMode -> IORef IOState -> [RunObj] -> IdleCallback +update runMode ioState objs = do + outputStatsAndCapture runMode ioState + ioStateUpdate ioState + ioState <- readIORef ioState + let updateObj obj = do + currentProgram $= Just (prog obj) + mapM_ (setUniform ioState obj) (uniformVars obj) + mapM_ updateObj objs + -- prepare precMap for the next iteration + updatePrecMap ioState + postRedisplay Nothing + +outputStatsAndCapture :: GlutRunMode -> IORef IOState -> IO () +outputStatsAndCapture runMode ioStateRef = do + ioState <- readIORef ioStateRef + let numUpdates = curNumUpdates ioState + epoch <- getCurrentTime + let t = fromRational $ toRational $ utctDayTime epoch + dt = t - lastStatsUpdate ioState + if dt > 1 + then do + writeIORef ioStateRef $ ioState { + totUpdates = totUpdates ioState + 1, curNumUpdates = 0, lastStatsUpdate = t } + putStrLn $ "FPS: " ++ show (floor $ fromIntegral numUpdates / dt :: Int) + else + writeIORef ioStateRef $ ioState { + totUpdates = totUpdates ioState + 1, curNumUpdates = numUpdates + 1 } + -- TODO: implement own capturePPM/PNG to remove the unecessary dependency + let captureToFile fname = capturePPM >>= BS.writeFile (fname ++ ".ppm") + case runMode of + GlutNormal -> return () + GlutCaptureLatest fname -> + when (dt > 0.1) (captureToFile fname) + GlutCaptureFrames fname -> + captureToFile $ fname ++ "/frame" ++ show (totUpdates ioState) + GlutCaptureAndExit fname -> + when (totUpdates ioState > 30) $ do + captureToFile fname + leaveMainLoop + +-- note that shared uniforms are evaluated separately for each object +-- (except for any prec subexpressions) +-- it's possible that this may cause unexpected behaviour, in +-- which case a map of pre-computed shared values will be needed +setUniform :: IOState -> RunObj -> UniformVar -> IO () +setUniform ioState obj (UniformVar id x) = do + (UniformLocation ul) <- get (uniformLocation (prog obj) (idLabel id)) + val <- hostEval (ioEval ioState) x + uniformSet ul val + +updatePrecMap :: IOState -> IO () +updatePrecMap ioState = do + let updateVal ioState (GLAtom _ (IOPrec _ x) :: GLExpr HostDomain t) _ = + Identity <$> hostEval (ioEval ioState) x + pm <- readIORef $ precMap ioState + _ <- DepMap.traverseWithKey (updateVal ioState) pm + -- pm might have new keys so we need to read it again + -- FIXME: find an alternative to this really ugly solution + pm <- readIORef $ precMap ioState + pm1 <- DepMap.traverseWithKey (updateVal ioState) pm + writeIORef (precMap ioState) pm1 + + +-- Draw logic + +display :: [RunObj] -> DisplayCallback +display objs = do + clear [ColorBuffer, DepthBuffer] + let doVao obj = do + currentProgram $= Just (prog obj) + bindVertexArrayObject $= Just (vao obj) + draw (primitiveMode obj) (indices obj) (numVerts obj) + mapM_ doVao objs + flush + +draw :: PrimitiveMode -> Maybe [ConstExpr UInt] -> Int -> IO () +draw mode Nothing n = + drawArrays mode 0 (fromIntegral n) +draw mode (Just inds) _ = + drawElements mode (fromIntegral $ length inds) UnsignedInt (makeOff 0) + + +-- I/O + +ioStateUpdate :: IORef IOState -> IO () +ioStateUpdate ioState = + let decayWheel ioState = ioState { mouseWheel = 0.1 * mouseWheel ioState } + in modifyIORef ioState decayWheel + +mouse :: IORef IOState -> MouseCallback +mouse ioState LeftButton mouseState _ = + let updateLeft ioState = ioState { mouseLeftDown = mouseState == Down } + in modifyIORef ioState updateLeft +mouse ioState RightButton mouseState _ = + let updateRight ioState = ioState { mouseRightDown = mouseState == Down } + in modifyIORef ioState updateRight +mouse ioState WheelUp _ _ = + let updateWheel ioState = ioState { mouseWheel = 1 } + in modifyIORef ioState updateWheel +mouse ioState WheelDown _ _ = + let updateWheel ioState = ioState { mouseWheel = -1 } + in modifyIORef ioState updateWheel +mouse _ _ _ _ = return () + +motion :: IORef IOState -> MotionCallback +motion ioState (Position x y) = + let updatePos ioState = ioState { curMouseX = fromIntegral x, curMouseY = fromIntegral y } + in modifyIORef ioState updatePos + +ioEval :: IOState -> GLExpr HostDomain t -> IO t + +ioEval ioState e@(GLAtom _ (IOPrec x0 _)) = do + pm <- readIORef $ precMap ioState + case DepMap.lookup e pm of + Just val -> return $ runIdentity val + Nothing -> do + val <- hostEval (ioEval ioState) x0 + writeIORef (precMap ioState) $ DepMap.insert e (Identity val) pm + return val + +ioEval ioState (GLAtom _ (IOFloat "time")) = do + let t0 = initTime ioState + epoch <- getCurrentTime + let t = fromRational $ toRational $ utctDayTime epoch + return $ t - t0 + +ioEval ioState (GLAtom _ (IOBool "mouseLeft")) = + return $ (toEnum . fromEnum) $ mouseLeftDown ioState + +ioEval ioState (GLAtom _ (IOBool "mouseRight")) = + return $ (toEnum . fromEnum) $ mouseRightDown ioState + +ioEval ioState (GLAtom _ (IOFloat "mouseWheel")) = + return $ mouseWheel ioState + +ioEval ioState (GLAtom _ (IOFloat "mouseX")) = do + (Size width _) <- get windowSize + return $ fromIntegral (curMouseX ioState) / fromIntegral width + +ioEval ioState (GLAtom _ (IOFloat "mouseY")) = do + (Size _ height) <- get windowSize + return $ 1 - fromIntegral (curMouseY ioState) / fromIntegral height + diff --git a/src/Graphics/HaGL/CodeGen.hs b/src/Graphics/HaGL/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/CodeGen.hs @@ -0,0 +1,301 @@ +module Graphics.HaGL.CodeGen ( + GLProgram(..), + UniformVar(..), InpVar(..), + genProgram +) where + +import Prelude hiding (id) +import Control.Monad.State.Lazy (State, evalState, gets, modify, unless) +import Control.Exception (throw) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Graphics.HaGL.ExprID +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr +import Graphics.HaGL.GLAst +import Graphics.HaGL.GLObj +import Graphics.HaGL.Shader + + +-- GLProgram = output of code gen for a GLObj + +data GLProgram = GLProgram { + primitiveMode :: PrimitiveMode, + indices :: Maybe [ConstExpr UInt], + uniformVars :: Set.Set UniformVar, + inputVars :: Set.Set InpVar, + numElts :: Int, + vertexShader :: Shader, + fragmentShader :: Shader +} + +data UniformVar where + UniformVar :: GLType t => ExprID -> GLExpr HostDomain t -> UniformVar + +instance HasExprID UniformVar where + getID (UniformVar id _) = id +instance Eq UniformVar where + x1 == x2 = getID x1 == getID x2 +instance Ord UniformVar where + compare x1 x2 = compare (getID x1) (getID x2) + +data InpVar where + InpVar :: GLInputType t => + ExprID -> [GLExpr ConstDomain t] -> InpVar + +instance HasExprID InpVar where + getID (InpVar id _) = id +instance Eq InpVar where + x1 == x2 = getID x1 == getID x2 +instance Ord InpVar where + compare x1 x2 = compare (getID x1) (getID x2) + +instance Show GLProgram where + show glProg = {-}"\n" ++ + concatMap (\s -> show s ++ "\n") + (Set.toList $ inputVars glProg) ++ + "========\n\n" ++ + concatMap (\s -> show s ++ "\n") + (Set.toList $ uniformVars glProg) ++ + "========\n\n" ++-} + List.intercalate "\n\n" (map show + [vertexShader glProg, + fragmentShader glProg]) + + +-- Intermediate code gen state + +data CGDat = CGDat { + globalDefs :: Set.Set ExprID, + scopes :: Map.Map ScopeID Scope, + funcStack :: [(ExprID, [ExprID])], + program :: GLProgram +} + +initCGDat glObj = CGDat { + globalDefs = Set.empty, + scopes = Map.fromList $ + [(MainScope dom, emptyScope) | dom <- shaderDomains] ++ + [(GlobalScope, emptyScope), (LocalScope, emptyScope)], + funcStack = [], + program = GLProgram { + Graphics.HaGL.CodeGen.primitiveMode = + Graphics.HaGL.GLObj.primitiveMode glObj, + Graphics.HaGL.CodeGen.indices = + Graphics.HaGL.GLObj.indices glObj, + uniformVars = Set.empty, + inputVars = Set.empty, + numElts = 0, + vertexShader = Shader [] [] [], + fragmentShader = Shader [] [] [] + } +} + +data ScopeID = + MainScope GLDomain | + GlobalScope | + LocalScope + deriving (Eq, Ord) + +data Scope = Scope { + scopeExprs :: Set.Set ExprID, + scopeStmts :: [ShaderStmt] +} + +emptyScope :: Scope +emptyScope = Scope Set.empty [] + +type CGState = State CGDat + + +-- genProgram + +genProgram :: GLObj -> GLProgram +genProgram glObj = evalState gen (initCGDat glObj) where + gen :: CGState GLProgram + gen = do + posRef <- traverseGLExpr $ position glObj + colorRef <- traverseGLExpr $ color glObj + discardRef <- traverseGLExpr $ discardWhen glObj + + vertStmts <- scopeStmts <$> getScope (MainScope VertexDomain) + mapM_ (modifyShader VertexDomain . addStmt) vertStmts + modifyShader VertexDomain $ addStmt $ + VarAsmt "gl_Position" posRef + + fragStmts <- scopeStmts <$> getScope (MainScope FragmentDomain) + mapM_ (modifyShader FragmentDomain . addStmt) fragStmts + modifyShader FragmentDomain $ addDecl $ + OutDecl "" "fColor" "vec4" + modifyShader FragmentDomain $ addStmt $ + VarAsmt "fColor" colorRef + modifyShader FragmentDomain $ addStmt $ + DiscardStmt discardRef + + verifyProg <$> gets program + + verifyProg :: GLProgram -> GLProgram + verifyProg prog = + case map (\(InpVar _ dat) -> length dat) (Set.toList (inputVars prog)) of + [] -> throw NoInputVars + lngts | elem 0 lngts -> throw EmptyInputVar + n:lngts | all (== n) lngts -> prog { numElts = n } + _ -> throw MismatchedInputVars + + +-- Traversal + +traverseGLExpr :: IsGLDomain d => GLExpr d t -> CGState ShaderExpr +traverseGLExpr glExpr = let glAst = toGLAst glExpr in + traverseGLAst (MainScope $ getShaderType glExpr) glAst + +traverseGLAst :: ScopeID -> GLAst -> CGState ShaderExpr +traverseGLAst _ (GLAstAtom _ _ (Const x)) = + return $ ShaderConst x +traverseGLAst _ (GLAstAtom id _ GenVar) = do + boundParamIds <- snd . head <$> gets funcStack + if id `List.elem` boundParamIds + then return $ ShaderVarRef $ idLabel id + else + throw UnsupportedNameCapture +traverseGLAst _ (GLAstAtom id ti (Uniform x)) = + ifUndef GlobalScope id $ do + addUniformVar $ UniformVar id x + modifyShader (shaderType ti) $ addDecl $ + UniformDecl (idLabel id) (exprType ti) +traverseGLAst _ (GLAstAtom _ ti (GenericUniform label)) = do + let safeLabel = "u_" ++ label + modifyShader (shaderType ti) $ addDecl $ + UniformDecl safeLabel (exprType ti) + return $ ShaderVarRef safeLabel +traverseGLAst _ (GLAstAtom id ti (Inp xs)) = + ifUndef GlobalScope id $ do + addInputVar $ InpVar id xs + modifyShader (shaderType ti) $ addDecl $ + InpDecl "" (idLabel id) (exprType ti) +traverseGLAst _ (GLAstAtom id ti (Frag interpType x)) = + ifUndef GlobalScope id $ do + vertExpr <- traverseGLAst (MainScope VertexDomain) $ toGLAst x + scopedStmt (MainScope VertexDomain) $ + VarAsmt (idLabel id) vertExpr + modifyShader VertexDomain $ addDecl $ + OutDecl (show interpType) (idLabel id) (exprType ti) + modifyShader FragmentDomain $ addDecl $ + InpDecl (show interpType) (idLabel id) (exprType ti) +traverseGLAst _ (GLAstAtom _ _ _) = error "GLAst contains disallowed atomic variable" +traverseGLAst _ (GLAstFunc fnID ti (GLAstExpr _ _ "?:" [cond, ret, + GLAstFuncApp _ _ (GLAstFunc fnID' _ _ _) recArgs]) params) | fnID == fnID' = + defFn fnID (map getID params) $ do + let paramExprs = map glastToParamExpr params + ((condExpr, updateStmts, retExpr, retStmts), condStmts) <- localScope $ do + condExpr <- traverseGLAst LocalScope cond + (_, updateStmts) <- innerScope $ do + argExprs <- mapM (traverseGLAst LocalScope) recArgs + mapM_ (\(ShaderParam paramName _, argName) -> scopedStmt LocalScope $ + VarAsmt paramName argName) $ zip paramExprs argExprs + (retExpr, retStmts) <- innerScope $ traverseGLAst LocalScope ret + return (condExpr, updateStmts, retExpr, retStmts) + modifyShader (shaderType ti) $ addFn $ + ShaderLoopFn (idLabel fnID) (exprType ti) + paramExprs + condExpr + retExpr + condStmts + retStmts + updateStmts +traverseGLAst _ (GLAstFunc fnID ti r params) = + defFn fnID (map getID params) $ do + let paramExprs = map glastToParamExpr params + (rExpr, scopeStmts) <- localScope $ traverseGLAst LocalScope r + modifyShader (shaderType ti) $ addFn $ + ShaderFn (idLabel fnID) (exprType ti) + paramExprs + scopeStmts + rExpr +traverseGLAst scopeID (GLAstFuncApp callID ti fn args) = + ifUndef scopeID callID $ do + argExprs <- mapM (traverseGLAst scopeID) args + _ <- traverseGLAst LocalScope fn + scopedStmt scopeID $ VarDeclAsmt (idLabel callID) (exprType ti) + (ShaderExpr (idLabel $ getID fn) argExprs) +traverseGLAst scopeID (GLAstExpr id ti exprName subnodes) = + ifUndef scopeID id $ do + subexprs <- mapM (traverseGLAst scopeID) subnodes + scopedStmt scopeID $ VarDeclAsmt (idLabel id) (exprType ti) $ + ShaderExpr exprName subexprs + + +-- Scope management + +localScope :: CGState a -> CGState (a, [ShaderStmt]) +localScope action = innerScope $ do + modifyScope LocalScope $ const emptyScope + action + +innerScope :: CGState a -> CGState (a, [ShaderStmt]) +innerScope action = do + scopeBefore <- getScope LocalScope + modifyScope LocalScope $ \scope -> scope { scopeStmts = [] } + res <- action + scopeAfter <- getScope LocalScope + modifyScope LocalScope $ const scopeBefore + return (res, scopeStmts scopeAfter) + +getScope :: ScopeID -> CGState Scope +getScope scopeID = do + scopes <- gets scopes + return $ Map.findWithDefault emptyScope scopeID scopes + +modifyScope :: ScopeID -> (Scope -> Scope) -> CGState () +modifyScope scopeID f = do + modify $ \s -> s { scopes = Map.adjust f scopeID $ scopes s } + +ifUndef :: ScopeID -> ExprID -> CGState () -> CGState ShaderExpr +ifUndef scopeID id initFn = do + locals <- scopeExprs <$> getScope scopeID + unless (id `Set.member` locals) $ do + modifyScope scopeID $ \scope -> + scope { scopeExprs = Set.insert id $ scopeExprs scope } + initFn + return $ ShaderVarRef $ idLabel id + +scopedStmt :: ScopeID -> ShaderStmt -> CGState () +scopedStmt scopeID stmt = modifyScope scopeID $ \scope -> + scope { scopeStmts = scopeStmts scope ++ [stmt] } + + +-- Function construction helpers + +defFn :: ExprID -> [ExprID] -> CGState () -> CGState ShaderExpr +defFn id paramIds initFn = do + fns <- gets funcStack + if id `List.elem` map fst fns then + throw UnsupportedRecCall + else do + modify $ \s -> s { funcStack = (id, paramIds) : funcStack s } + res <- ifUndef GlobalScope id initFn + modify $ \s -> s { funcStack = tail $ funcStack s } + return res + +glastToParamExpr :: GLAst -> ShaderParam +glastToParamExpr (GLAstAtom id ti GenVar) = + ShaderParam (idLabel id) (exprType ti) + + +-- Shader modification + +modifyShader :: GLDomain -> (Shader -> Shader) -> CGState () +modifyShader VertexDomain f = modify (\s -> s { + program = (program s) { vertexShader = f $ vertexShader $ program s } }) +modifyShader FragmentDomain f = modify (\s -> s { + program = (program s) { fragmentShader = f $ fragmentShader $ program s } }) + +addUniformVar :: UniformVar -> CGState () +addUniformVar unif = modify (\s -> s { + program = (program s) { uniformVars = Set.insert unif $ uniformVars $ program s } }) + +addInputVar :: InpVar -> CGState () +addInputVar unif = modify (\s -> s { + program = (program s) { inputVars = Set.insert unif $ inputVars $ program s } }) diff --git a/src/Graphics/HaGL/Eval.hs b/src/Graphics/HaGL/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Eval.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Graphics.HaGL.Eval ( + constEval, + hostEval, + IOEvaluator, + EvalException(..) +) where + +import Prelude hiding (id) +import Control.Exception (Exception, throw) +import Control.Applicative (liftA2) +import Control.Monad.State.Lazy +import Data.Functor.Identity +import Data.Bits + +import Graphics.HaGL.Numerical +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr +import Graphics.HaGL.Util.Types (FinList(..)) +import qualified Graphics.HaGL.Util.DepMap as DepMap + + +type IOEvaluator = forall t. GLExpr HostDomain t -> IO t + + +data EvalException = + GenericUniformEval + +instance Exception EvalException + +instance Show EvalException where + show GenericUniformEval = "Attempted to evaluate a user-defined uniform variable" + + +constEval :: GLExpr ConstDomain t -> t +constEval expr = runIdentity $ + evalStateT (cachedEval expr) (EvalState eval DepMap.empty) + +hostEval :: IOEvaluator -> GLExpr HostDomain t -> IO t +hostEval ioev expr = + evalStateT (cachedEval expr) (EvalState (hEval ioev) DepMap.empty) + + +data EvalState d a = EvalState { + evalfn :: Monad a => forall t. GLExpr d t -> StateT (EvalState d a) a t, + cache :: DepMap.DepMap (GLExpr d) Identity +} + +cachedEval :: Monad a => GLExpr d t -> StateT (EvalState d a) a t +cachedEval expr = do + evfn <- gets evalfn + c <- gets cache + case DepMap.lookup expr c of + Just (Identity val) -> return val + Nothing -> do + val :: t <- evfn expr + modify (\s -> s { cache = DepMap.insert expr (Identity val) (cache s) }) + return val + + +hEval :: IOEvaluator -> GLExpr HostDomain t -> StateT (EvalState HostDomain IO) IO t + +hEval ioev e@(GLAtom _ (IOFloat _)) = lift $ ioev e +hEval ioev e@(GLAtom _ (IODouble _)) = lift $ ioev e +hEval ioev e@(GLAtom _ (IOInt _)) = lift $ ioev e +hEval ioev e@(GLAtom _ (IOUInt _)) = lift $ ioev e +hEval ioev e@(GLAtom _ (IOBool _)) = lift $ ioev e +hEval ioev e@(GLAtom _ (IOPrec _ _)) = lift $ ioev e +hEval ioev (GLAtom _ (Uniform x)) = hEval ioev x +hEval _ (GLAtom _ (GenericUniform _)) = throw GenericUniformEval +hEval _ e = eval e + + +eval :: Monad a => GLExpr d t -> StateT (EvalState d a) a t + +eval (GLAtom _ (Const x)) = return x +eval (GLAtom _ GenVar) = error "Attempted to evaluate an unknown variable" +eval (GLAtom _ (Uniform _)) = error "Attempted to purely evaluate a uniform variable" +eval (GLAtom _ (GenericUniform _)) = error "Attempted to purely evaluate a user-defined uniform variable" +eval (GLAtom _ (Inp _)) = error "Attempted to evaluate an expression in VertexDomain" +eval (GLAtom _ (Frag _ _)) = error "Attempted to evaluate an expression in FragmentDomain" +eval (GLAtom _ (GLLift0 x0)) = return x0 +eval (GLAtom _ (GLLift1 f x0)) = withEv1 x0 $ \x0 -> + return $ f x0 +eval (GLAtom _ (GLLift2 f x0 y0)) = withEv2 x0 y0 $ \x0 y0 -> + return $ f x0 y0 +eval (GLAtom _ (GLLift3 f x0 y0 z0)) = withEv3 x0 y0 z0 $ \x0 y0 z0 -> + return $ f x0 y0 z0 +eval (GLAtom _ (GLLift4 f x0 y0 z0 w0)) = withEv4 x0 y0 z0 w0 $ \x0 y0 z0 w0 -> + return $ f x0 y0 z0 w0 +eval (GLAtom _ (GLLift5 f x0 y0 z0 w0 u0)) = withEv5 x0 y0 z0 w0 u0 $ \x0 y0 z0 w0 u0 -> + return $ f x0 y0 z0 w0 u0 +eval (GLAtom _ (GLLift6 f x0 y0 z0 w0 u0 v0)) = withEv6 x0 y0 z0 w0 u0 v0 $ \x0 y0 z0 w0 u0 v0 -> + return $ f x0 y0 z0 w0 u0 v0 +eval (GLAtom _ _) = error "Attempted to purely evaluate an IO* variable" + +eval (GLFunc _ (GLFunc1 f _ x0)) = cachedEval $ f x0 +eval (GLFunc _ (GLFunc2 f _ _ x0 y0)) = cachedEval $ f x0 y0 +eval (GLFunc _ (GLFunc3 f _ _ _ x0 y0 z0)) = cachedEval $ f x0 y0 z0 +eval (GLFunc _ (GLFunc4 f _ _ _ _ x0 y0 z0 w0)) = cachedEval $ f x0 y0 z0 w0 +eval (GLFunc _ (GLFunc5 f _ _ _ _ _ x0 y0 z0 w0 u0)) = cachedEval $ f x0 y0 z0 w0 u0 +eval (GLFunc _ (GLFunc6 f _ _ _ _ _ _ x0 y0 z0 w0 u0 v0)) = cachedEval $ f x0 y0 z0 w0 u0 v0 + +eval (GLGenExpr _ (GLVec2 x y)) = withEv2 x y $ \x y -> + return $ x %| m0 %- y %| m0 +eval (GLGenExpr _ (GLVec3 x y z)) = withEv3 x y z $ \x y z -> + return $ x %| m0 %- y %| m0 %- z %| m0 +eval (GLGenExpr _ (GLVec4 x y z w)) = withEv4 x y z w $ \x y z w -> + return $ x %| m0 %- y %| m0 %- z %| m0 %- w %| m0 +eval (GLGenExpr _ (GLMat2x2 x y)) = withEv2 x y $ \x y -> + return $ tr $ tr x %- tr y +eval (GLGenExpr _ (GLMat2x3 x y z)) = withEv3 x y z $ \x y z -> + return $ tr $ tr x %- tr y %- tr z +eval (GLGenExpr _ (GLMat2x4 x y z w)) = withEv4 x y z w $ \x y z w -> + return $ tr $ tr x %- tr y %- tr z %- tr w +eval (GLGenExpr _ (GLMat3x2 x y)) = withEv2 x y $ \x y -> + return $ tr $ tr x %- tr y +eval (GLGenExpr _ (GLMat3x3 x y z)) = withEv3 x y z $ \x y z -> + return $ tr $ tr x %- tr y %- tr z +eval (GLGenExpr _ (GLMat3x4 x y z w)) = withEv4 x y z w $ \x y z w -> + return $ tr $ tr x %- tr y %- tr z %- tr w +eval (GLGenExpr _ (GLMat4x2 x y)) = withEv2 x y $ \x y -> + return $ tr $ tr x %- tr y +eval (GLGenExpr _ (GLMat4x3 x y z)) = withEv3 x y z $ \x y z -> + return $ tr $ tr x %- tr y %- tr z +eval (GLGenExpr _ (GLMat4x4 x y z w)) = withEv4 x y z w $ \x y z w -> + return $ tr $ tr x %- tr y %- tr z %- tr w +eval (GLGenExpr _ (Pre x xs)) = withEv2 x xs $ \x xs -> + return $ x %| m0 %- xs +eval (GLGenExpr _ (App xs x)) = withEv2 xs x $ \xs x -> + return $ vertConcat xs (x %| m0) +eval (GLGenExpr _ (Conc xs ys)) = withEv2 xs ys $ \xs ys -> + return $ vertConcat xs ys +eval (GLGenExpr _ (GLArray xs)) = + mapM cachedEval xs + +eval (GLGenExpr _ (OpCoord coords v)) = withEv1 v $ \v -> + return $ v `eltAt` coordToIndex coords +eval (GLGenExpr _ (OpCoordMulti coordList v)) = withEv1 v $ \v -> + return $ v `eltsAt` toFinList coordList where + toFinList :: GLCoordList l m -> FinList l (Int, Int) + toFinList CoordNil = FLNil + toFinList (CoordCons c cs) = FLCons (coordToIndex c) (toFinList cs) +eval (GLGenExpr _ (OpCol col m)) = withEv1 m $ \m -> + return $ m `matCol` colToIndex col +eval (GLGenExpr _ (OpArrayElt arr i)) = withEv2 arr i $ \arr i -> + return $ arr !! fromIntegral (i `mod` Prelude.length arr) + +eval (GLGenExpr _ (Cast x)) = withEv1 x $ \x -> + return $ glCast x +eval (GLGenExpr _ (MatCast x)) = withEv1 x $ \x -> + return $ fromList . map glCast . toList $ x + +eval (GLGenExpr _ (OpAdd x y)) = withEv2 x y $ \x y -> + return $ glZipWith (+) x y +eval (GLGenExpr _ (OpSubt x y)) = withEv2 x y $ \x y -> + return $ glZipWith (-) x y +eval (GLGenExpr _ (OpMult x y)) = withEv2 x y $ \x y -> + return $ glZipWith (*) x y +eval (GLGenExpr _ (OpDiv x y)) = withEv2 x y $ \x y -> + return $ glZipWith genDiv x y +eval (GLGenExpr _ (OpMod x y)) = withEv2 x y $ \x y -> + return $ glZipWith mod x y +eval (GLGenExpr _ (OpNeg x)) = withEv1 x $ \x -> + return $ glMap negate x +eval (GLGenExpr _ (OpLessThan x y)) = withEv2 x y $ \x y -> + return $ x < y +eval (GLGenExpr _ (OpLessThanEqual x y)) = withEv2 x y $ \x y -> + return $ x <= y +eval (GLGenExpr _ (OpGreaterThan x y)) = withEv2 x y $ \x y -> + return $ x > y +eval (GLGenExpr _ (OpGreaterThanEqual x y)) = withEv2 x y $ \x y -> + return $ x >= y +eval (GLGenExpr _ (OpEqual x y)) = withEv2 x y $ \x y -> + return $ x == y +eval (GLGenExpr _ (OpNotEqual x y)) = withEv2 x y $ \x y -> + return $ x /= y +eval (GLGenExpr _ (OpAnd x y)) = withEv2 x y $ \x y -> + return $ x .&. y +eval (GLGenExpr _ (OpOr x y)) = withEv2 x y $ \x y -> + return $ x .|. y +eval (GLGenExpr _ (OpXor x y)) = withEv2 x y $ \x y -> + return $ x `xor` y +eval (GLGenExpr _ (OpNot x)) = withEv1 x $ \x -> + return $ complement x +eval (GLGenExpr _ (OpCond x y z)) = + -- this is the only case where we have to be lazy + cachedEval x >>= \x -> if x then cachedEval y else cachedEval z +eval (GLGenExpr _ (OpCompl x)) = withEv1 x $ \x -> + return $ glMap complement x +eval (GLGenExpr _ (OpLshift x y)) = withEv2 x y $ \x y -> + return $ glZipWith (\x y -> x `shiftL` (fromInteger . toInteger) y) x y +eval (GLGenExpr _ (OpRshift x y)) = withEv2 x y $ \x y -> + return $ glZipWith (\x y -> x `shiftR` (fromInteger . toInteger) y) x y +eval (GLGenExpr _ (OpBitAnd x y)) = withEv2 x y $ \x y -> + return $ glZipWith (.&.) x y +eval (GLGenExpr _ (OpBitOr x y)) = withEv2 x y $ \x y -> + return $ glZipWith (.|.) x y +eval (GLGenExpr _ (OpBitXor x y)) = withEv2 x y $ \x y -> + return $ glZipWith xor x y +eval (GLGenExpr _ (OpScalarMult x y)) = withEv2 x y $ \x y -> + return $ glMap (x *) y +eval (GLGenExpr _ (OpMatrixMult x y)) = withEv2 x y $ \x y -> + return $ matMult x y + +eval (GLGenExpr _ (Radians x)) = withEv1 x $ \x -> + return $ glMap radians x where + radians deg = (pi / 180) * deg +eval (GLGenExpr _ (Degrees x)) = withEv1 x $ \x -> + return $ glMap degrees x where + degrees rad = (180 / pi) * rad +eval (GLGenExpr _ (Sin x)) = withEv1 x $ \x -> + return $ glMap sin x +eval (GLGenExpr _ (Cos x)) = withEv1 x $ \x -> + return $ glMap cos x +eval (GLGenExpr _ (Tan x)) = withEv1 x $ \x -> + return $ glMap tan x +eval (GLGenExpr _ (Asin x)) = withEv1 x $ \x -> + return $ glMap asin x +eval (GLGenExpr _ (Acos x)) = withEv1 x $ \x -> + return $ glMap acos x +eval (GLGenExpr _ (Atan x)) = withEv1 x $ \x -> + return $ glMap atan x +eval (GLGenExpr _ (Sinh x)) = withEv1 x $ \x -> + return $ glMap sinh x +eval (GLGenExpr _ (Cosh x)) = withEv1 x $ \x -> + return $ glMap cosh x +eval (GLGenExpr _ (Tanh x)) = withEv1 x $ \x -> + return $ glMap tanh x +eval (GLGenExpr _ (Asinh x)) = withEv1 x $ \x -> + return $ glMap asinh x +eval (GLGenExpr _ (Acosh x)) = withEv1 x $ \x -> + return $ glMap acosh x +eval (GLGenExpr _ (Atanh x)) = withEv1 x $ \x -> + return $ glMap atanh x + +eval (GLGenExpr _ (Pow x y)) = withEv2 x y $ \x y -> + return $ glZipWith (**) x y +eval (GLGenExpr _ (Exp x)) = withEv1 x $ \x -> + return $ glMap exp x +eval (GLGenExpr _ (Log x)) = withEv1 x $ \x -> + return $ glMap log x +eval (GLGenExpr _ (Exp2 x)) = withEv1 x $ \x -> + return $ glMap (2 **) x +eval (GLGenExpr _ (Log2 x)) = withEv1 x $ \x -> + return $ glMap (logBase 2) x +eval (GLGenExpr _ (Sqrt x)) = withEv1 x $ \x -> + return $ glMap sqrt x +eval (GLGenExpr _ (Inversesqrt x)) = withEv1 x $ \x -> + return $ glMap (recip . sqrt) x + +eval (GLGenExpr _ (Abs x)) = withEv1 x $ \x -> + return $ glMap abs x +eval (GLGenExpr _ (Sign x)) = withEv1 x $ \x -> + return $ glMap signum x +eval (GLGenExpr _ (Floor x)) = withEv1 x $ \x -> + return $ glMap (fromIntegral . (floor :: _ -> Int)) x +eval (GLGenExpr _ (Trunc x)) = withEv1 x $ \x -> + return $ glMap (fromIntegral . (truncate :: _ -> Int)) x +eval (GLGenExpr _ (Round x)) = withEv1 x $ \x -> + return $ glMap (fromIntegral . (round :: _ -> Int)) x +eval (GLGenExpr _ (RoundEven x)) = withEv1 x $ \x -> + return $ glMap (fromIntegral . (round :: _ -> Int)) x +eval (GLGenExpr _ (Ceil x)) = withEv1 x $ \x -> + return $ glMap (fromIntegral . (ceiling :: _ -> Int)) x +eval (GLGenExpr _ (Fract x)) = withEv1 x $ \x -> + return $ glMap (snd . (properFraction :: _ -> (Int, _))) x +eval (GLGenExpr _ (Mod x y)) = withEv2 x y $ \x y -> + return $ glZipWith mod x y where + mod x y = x - y * (fromIntegral . (floor :: _ -> Int)) (x / y) +eval (GLGenExpr _ (Min x y)) = withEv2 x y $ \x y -> + return $ glZipWith min x y +eval (GLGenExpr _ (Max x y)) = withEv2 x y $ \x y -> + return $ glZipWith max x y +eval (GLGenExpr _ (Clamp x y z)) = withEv3 x y z $ \x y z -> + return $ glZipWith3 clamp x y z where + clamp x minVal maxVal = min (max x minVal) maxVal +eval (GLGenExpr _ (Mix x y z)) = withEv3 x y z $ \x y z -> + return $ glZipWith3 mix x y z where + mix x y a = x * (1 - a) + y * a +eval (GLGenExpr _ (Step x y)) = withEv2 x y $ \x y -> + return $ glZipWith step x y where + step edge x = if x < edge then 0 else 1 +eval (GLGenExpr _ (Smoothstep x y z)) = withEv3 x y z $ \x y z -> + return $ glZipWith3 smoothstep x y z where + smoothstep edge0 edge1 x = + let t = min (max ((x - edge0) / (edge1 - edge0)) 0) 1 + in t * t * (3 - 2 * t) + +eval (GLGenExpr _ (Length x)) = withEv1 x $ \x -> + return $ Graphics.HaGL.Numerical.length x +eval (GLGenExpr _ (Distance x y)) = withEv2 x y $ \x y -> + return $ x `distance` y +eval (GLGenExpr _ (Dot x y)) = withEv2 x y $ \x y -> + return $ x `dot` y +eval (GLGenExpr _ (Cross x y)) = withEv2 x y $ \x y -> + return $ x `cross` y +eval (GLGenExpr _ (Normalize x)) = withEv1 x $ \x -> + return $ normalize x +eval (GLGenExpr _ (Faceforward x y z)) = withEv3 x y z $ \x y z -> + return $ faceforward x y z where + faceforward n i nr = if dot nr i < 0 then n else -n +eval (GLGenExpr _ (Reflect x y)) = withEv2 x y $ \x y -> + return $ reflect x y where + c .# v = glMap (c *) v + reflect i n = i - 2 * dot n i .# n +eval (GLGenExpr _ (Refract x y z)) = withEv3 x y z $ \x y z -> + return $ refract x y z where + c .# v = glMap (c *) v + refract i n eta = + let k = 1 - eta * eta * (1 - dot n i * dot n i) + in if k < 0 then 0 else eta .# i - (eta * dot n i + sqrt k) .# n + +eval (GLGenExpr _ (MatrixCompMult x y)) = withEv2 x y $ \x y -> + return $ glZipWith (*) x y +eval (GLGenExpr _ (OuterProduct x y)) = withEv2 x y $ \x y -> + return $ x `outerProduct` y +eval (GLGenExpr _ (Transpose x)) = withEv1 x $ \x -> + return $ transpose x +eval (GLGenExpr _ (Determinant x)) = withEv1 x $ \x -> + return $ determinant x +eval (GLGenExpr _ (Inverse x)) = withEv1 x $ \x -> + return $ inverse x + +eval (GLGenExpr _ (LessThan x y)) = withEv2 x y $ \x y -> + return $ liftA2 (<) x y +eval (GLGenExpr _ (LessThanEqual x y)) = withEv2 x y $ \x y -> + return $ liftA2 (<=) x y +eval (GLGenExpr _ (GreaterThan x y)) = withEv2 x y $ \x y -> + return $ liftA2 (>) x y +eval (GLGenExpr _ (GreaterThanEqual x y)) = withEv2 x y $ \x y -> + return $ liftA2 (>=) x y +eval (GLGenExpr _ (Equal x y)) = withEv2 x y $ \x y -> + return $ liftA2 (==) x y +eval (GLGenExpr _ (NotEqual x y)) = withEv2 x y $ \x y -> + return $ liftA2 (/=) x y +eval (GLGenExpr _ (Any x)) = withEv1 x $ \x -> + return $ foldr (.|.) False x +eval (GLGenExpr _ (All x)) = withEv1 x $ \x -> + return $ foldr (.&.) True x +eval (GLGenExpr _ (Not x)) = withEv1 x $ \x -> + return $ fmap complement x + + +-- Helper functions + +withEv1 x act = do { x <- cachedEval x; act x } +withEv2 x y act = do { x <- cachedEval x; y <- cachedEval y; act x y } +withEv3 x y z act = do { x <- cachedEval x; y <- cachedEval y; z <- cachedEval z; act x y z } +withEv4 x y z w act = do { x <- cachedEval x; y <- cachedEval y; z <- cachedEval z; w <- cachedEval w; act x y z w } +withEv5 x y z w u act = do { x <- cachedEval x; y <- cachedEval y; z <- cachedEval z; w <- cachedEval w; u <- cachedEval u; act x y z w u } +withEv6 x y z w u v act = do { x <- cachedEval x; y <- cachedEval y; z <- cachedEval z; w <- cachedEval w; u <- cachedEval u; v <- cachedEval v; act x y z w u v } + +tr = transpose + +coordToIndex :: GLCoord m -> (Int, Int) +coordToIndex CoordX = (0, 0) +coordToIndex CoordY = (1, 0) +coordToIndex CoordZ = (2, 0) +coordToIndex CoordW = (3, 0) + +colToIndex :: GLCol m -> Int +colToIndex Col0 = 0 +colToIndex Col1 = 1 +colToIndex Col2 = 2 +colToIndex Col3 = 3 diff --git a/src/Graphics/HaGL/ExprID.hs b/src/Graphics/HaGL/ExprID.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/ExprID.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} + +module Graphics.HaGL.ExprID ( + ExprID, + genID, + combineIDs, + idLabel, + HasExprID(..) +) where + +import Prelude hiding (id) +import Data.Word (Word64) +import Data.Bits (shiftL, (.|.)) +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Crypto.Hash.MD5 as MD5 + +type ExprID = Word64 + +-- TODO: consider a hash consing approach which +-- would free us from shaky unsafePerformIO foundations, +-- at the expense of having ugly, long IDs in shader code + +{-# NOINLINE unsafeCounter #-} +unsafeCounter :: IORef ExprID +unsafeCounter = unsafePerformIO $ newIORef 0 + +-- All modules using this function should be +-- compiled with -fno-full-laziness!! +{-# NOINLINE genID #-} +genID :: a -> ExprID +genID _ = unsafePerformIO $ do + id <- readIORef unsafeCounter + writeIORef unsafeCounter (id + 1) + return id + +-- TODO: try to remove dependency on md5 and probabilistic assumptions +combineIDs :: [ExprID] -> ExprID +combineIDs = fromBytes . take 8 . map fromIntegral . BS.unpack . + MD5.hashlazy . BB.toLazyByteString . mconcat . map BB.word64BE where + fromBytes = fst . foldr (\x (s, i) -> (s .|. shiftL x i, i + 8)) (0, 0) + +idLabel :: ExprID -> String +idLabel id | id >= 0 = "x" ++ show id + | otherwise = "y" ++ show (negate id) + +class HasExprID a where + getID :: a -> ExprID + diff --git a/src/Graphics/HaGL/GLAst.hs b/src/Graphics/HaGL/GLAst.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/GLAst.hs @@ -0,0 +1,215 @@ +-- required due to use of genID +{-# OPTIONS_GHC -fno-full-laziness #-} + +module Graphics.HaGL.GLAst ( + GLAst(..), + GLTypeInfo(..), + IsGLDomain(..), + getID, + toGLAst +) where + +import Prelude hiding (id) +import Data.List (isPrefixOf) +import Control.Exception (throw) + +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr +import Graphics.HaGL.ExprID + + +data GLAst where + GLAstAtom :: ExprID -> GLTypeInfo -> GLAtom d t -> GLAst + GLAstFunc :: ExprID -> GLTypeInfo -> GLAst -> [GLAst] -> GLAst + GLAstFuncApp :: ExprID -> GLTypeInfo -> GLAst -> [GLAst] -> GLAst + GLAstExpr :: ExprID -> GLTypeInfo -> String -> [GLAst] -> GLAst + + +data GLTypeInfo = GLTypeInfo { + shaderType :: GLDomain, + exprType :: String +} + +class IsGLDomain (d :: GLDomain) where + getShaderType :: GLExpr d t -> GLDomain +instance IsGLDomain ConstDomain where + getShaderType = const ConstDomain +instance IsGLDomain HostDomain where + getShaderType = const HostDomain +instance IsGLDomain VertexDomain where + getShaderType = const VertexDomain +instance IsGLDomain FragmentDomain where + getShaderType = const FragmentDomain + +instance HasExprID GLAst where + getID (GLAstAtom id _ _) = id + getID (GLAstFunc id _ _ _) = id + getID (GLAstFuncApp id _ _ _) = id + getID (GLAstExpr id _ _ _) = id + + +getGLTypeInfo e = GLTypeInfo (getShaderType e) (showGlslType e) +mkGLFn funcID callID r params args = + GLAstFuncApp callID (getGLTypeInfo r) func args where + func = GLAstFunc funcID (getGLTypeInfo r) (toGLAst r) params +mkGLExpr id e = GLAstExpr id (getGLTypeInfo e) + +showSizedArrayType e n = takeWhile (/= ']') (showGlslType e) ++ show n ++ "]" +showPotentialArrayType e arr = + if arrayLen arr == 1 then showGlslType e else showSizedArrayType e (arrayLen arr) +-- TODO: keep this as an assertion, but enforce the constraint at the type level +vd = throw UnknownArraySize + + +toGLAst :: IsGLDomain d => GLExpr d t -> GLAst + +-- Special case where we need to extract a known array size +-- (the current assumption is that only uniform arrays are used in the shader) +toGLAst e@(GLAtom id x@(Uniform (GLGenExpr _ (GLArray arr)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showSizedArrayType e (length arr)) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift0 x0)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e x0) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift1 f _)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e (f vd)) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift2 f _ _)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e (f vd vd)) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift3 f _ _ _)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e (f vd vd vd)) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift4 f _ _ _ _)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e (f vd vd vd vd)) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift5 f _ _ _ _ _)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e (f vd vd vd vd vd)) +toGLAst e@(GLAtom id x@(Uniform (GLAtom _ (GLLift6 f _ _ _ _ _ _)))) = GLAstAtom id ti x where + ti = GLTypeInfo (getShaderType e) (showPotentialArrayType e (f vd vd vd vd vd vd)) +-- FIXME: we never consider the case when arrays appear in precs + +toGLAst e@(GLAtom id x) = GLAstAtom id (getGLTypeInfo e) x + +toGLAst e@(GLFunc fnID (GLFunc1 f x x0)) = mkGLFn fnID (getID e) (f x) [toGLAst x] [toGLAst x0] +toGLAst e@(GLFunc fnID (GLFunc2 f x y x0 y0)) = mkGLFn fnID (getID e) (f x y) [toGLAst x, toGLAst y] [toGLAst x0, toGLAst y0] +toGLAst e@(GLFunc fnID (GLFunc3 f x y z x0 y0 z0)) = mkGLFn fnID (getID e) (f x y z) [toGLAst x, toGLAst y, toGLAst z] [toGLAst x0, toGLAst y0, toGLAst z0] +toGLAst e@(GLFunc fnID (GLFunc4 f x y z w x0 y0 z0 w0)) = mkGLFn fnID (getID e) (f x y z w) [toGLAst x, toGLAst y, toGLAst z, toGLAst w] [toGLAst x0, toGLAst y0, toGLAst z0, toGLAst w0] +toGLAst e@(GLFunc fnID (GLFunc5 f x y z w u x0 y0 z0 w0 u0)) = mkGLFn fnID (getID e) (f x y z w u) [toGLAst x, toGLAst y, toGLAst z, toGLAst w, toGLAst u] [toGLAst x0, toGLAst y0, toGLAst z0, toGLAst w0, toGLAst u0] +toGLAst e@(GLFunc fnID (GLFunc6 f x y z w u v x0 y0 z0 w0 u0 v0)) = mkGLFn fnID (getID e) (f x y z w u v) [toGLAst x, toGLAst y, toGLAst z, toGLAst w, toGLAst u, toGLAst v] [toGLAst x0, toGLAst y0, toGLAst z0, toGLAst w0, toGLAst u0, toGLAst v0] + +toGLAst e@(GLGenExpr id (GLVec2 x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (GLVec3 x y z)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (GLVec4 x y z w)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z, toGLAst w] +toGLAst e@(GLGenExpr id (GLMat2x2 x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (GLMat2x3 x y z)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (GLMat2x4 x y z w)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z, toGLAst w] +toGLAst e@(GLGenExpr id (GLMat3x2 x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (GLMat3x3 x y z)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (GLMat3x4 x y z w)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z, toGLAst w] +toGLAst e@(GLGenExpr id (GLMat4x2 x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (GLMat4x3 x y z)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (GLMat4x4 x y z w)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y, toGLAst z, toGLAst w] +toGLAst e@(GLGenExpr id (Pre x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (App x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Conc x y)) = mkGLExpr id e (showGlslType e) [toGLAst x, toGLAst y] +-- FIXME: temporary patch-up to make printGLAST work +toGLAst e@(GLGenExpr id (GLArray _)) = mkGLExpr id e (showGlslType e) [] + +toGLAst e@(GLGenExpr id (OpCoord coord x)) = mkGLExpr id e ("." ++ show coord) [toGLAst x] +toGLAst e@(GLGenExpr id (OpCoordMulti coordList x)) = mkGLExpr id e ("." ++ show coordList) [toGLAst x] +toGLAst e@(GLGenExpr id (OpCol col x)) = mkGLExpr id e (show col) [toGLAst x] +toGLAst e@(GLGenExpr id (OpArrayElt arr i)) = mkGLExpr id e "[]" [toGLAst arr, toGLAst i] + +toGLAst e@(GLGenExpr id (Cast x)) = mkGLExpr id e (showGlslType e) [toGLAst x] +toGLAst e@(GLGenExpr id (MatCast x)) = mkGLExpr id e (showGlslType e) [toGLAst x] + +toGLAst e@(GLGenExpr id (OpAdd x y)) = mkGLExpr id e "+" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpSubt x y)) = mkGLExpr id e "-" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpMult x y)) = + let op = case showGlslType e of + ty | "mat" `isPrefixOf` ty -> "matrixCompMult" + ty | "dmat" `isPrefixOf` ty -> "matrixCompMult" + _ -> "*" + in mkGLExpr id e op [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpDiv x y)) = mkGLExpr id e "/" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpMod x y)) = mkGLExpr id e "%" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpNeg x)) = mkGLExpr id e "-" [toGLAst x] +toGLAst e@(GLGenExpr id (OpLessThan x y)) = mkGLExpr id e "<" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpLessThanEqual x y)) = mkGLExpr id e "<=" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpGreaterThan x y)) = mkGLExpr id e ">" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpGreaterThanEqual x y)) = mkGLExpr id e ">=" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpEqual x y)) = mkGLExpr id e "==" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpNotEqual x y)) = mkGLExpr id e "!=" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpAnd x y)) = mkGLExpr id e "&&" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpOr x y)) = mkGLExpr id e "||" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpXor x y)) = mkGLExpr id e "^^" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpNot x)) = mkGLExpr id e "!" [toGLAst x] +toGLAst e@(GLGenExpr id (OpCond x y z)) = mkGLExpr id e "?:" [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (OpCompl x)) = mkGLExpr id e "~" [toGLAst x] +toGLAst e@(GLGenExpr id (OpLshift x y)) = mkGLExpr id e "<<" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpRshift x y)) = mkGLExpr id e ">>" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpBitAnd x y)) = mkGLExpr id e "&" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpBitOr x y)) = mkGLExpr id e "|" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpBitXor x y)) = mkGLExpr id e "^" [toGLAst x, toGLAst y] + +toGLAst e@(GLGenExpr id (OpScalarMult x y)) = mkGLExpr id e "*" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OpMatrixMult x y)) = mkGLExpr id e "*" [toGLAst x, toGLAst y] + +toGLAst e@(GLGenExpr id (Radians x)) = mkGLExpr id e "radians" [toGLAst x] +toGLAst e@(GLGenExpr id (Degrees x)) = mkGLExpr id e "degrees" [toGLAst x] +toGLAst e@(GLGenExpr id (Sin x)) = mkGLExpr id e "sin" [toGLAst x] +toGLAst e@(GLGenExpr id (Cos x)) = mkGLExpr id e "cos" [toGLAst x] +toGLAst e@(GLGenExpr id (Tan x)) = mkGLExpr id e "tan" [toGLAst x] +toGLAst e@(GLGenExpr id (Asin x)) = mkGLExpr id e "asin" [toGLAst x] +toGLAst e@(GLGenExpr id (Acos x)) = mkGLExpr id e "acos" [toGLAst x] +toGLAst e@(GLGenExpr id (Atan x)) = mkGLExpr id e "atan" [toGLAst x] +toGLAst e@(GLGenExpr id (Sinh x)) = mkGLExpr id e "sinh" [toGLAst x] +toGLAst e@(GLGenExpr id (Cosh x)) = mkGLExpr id e "cosh" [toGLAst x] +toGLAst e@(GLGenExpr id (Tanh x)) = mkGLExpr id e "tanh" [toGLAst x] +toGLAst e@(GLGenExpr id (Asinh x)) = mkGLExpr id e "asinh" [toGLAst x] +toGLAst e@(GLGenExpr id (Acosh x)) = mkGLExpr id e "acosh" [toGLAst x] +toGLAst e@(GLGenExpr id (Atanh x)) = mkGLExpr id e "atanh" [toGLAst x] + +toGLAst e@(GLGenExpr id (Pow x y)) = mkGLExpr id e "pow" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Exp x)) = mkGLExpr id e "exp" [toGLAst x] +toGLAst e@(GLGenExpr id (Log x)) = mkGLExpr id e "log" [toGLAst x] +toGLAst e@(GLGenExpr id (Exp2 x)) = mkGLExpr id e "exp2" [toGLAst x] +toGLAst e@(GLGenExpr id (Log2 x)) = mkGLExpr id e "log2" [toGLAst x] +toGLAst e@(GLGenExpr id (Sqrt x)) = mkGLExpr id e "sqrt" [toGLAst x] +toGLAst e@(GLGenExpr id (Inversesqrt x)) = mkGLExpr id e "inversesqrt" [toGLAst x] + +toGLAst e@(GLGenExpr id (Abs x)) = mkGLExpr id e "abs" [toGLAst x] +toGLAst e@(GLGenExpr id (Sign x)) = mkGLExpr id e "sign" [toGLAst x] +toGLAst e@(GLGenExpr id (Floor x)) = mkGLExpr id e "floor" [toGLAst x] +toGLAst e@(GLGenExpr id (Trunc x)) = mkGLExpr id e "trunc" [toGLAst x] +toGLAst e@(GLGenExpr id (Round x)) = mkGLExpr id e "round" [toGLAst x] +toGLAst e@(GLGenExpr id (RoundEven x)) = mkGLExpr id e "roundEven" [toGLAst x] +toGLAst e@(GLGenExpr id (Ceil x)) = mkGLExpr id e "ceil" [toGLAst x] +toGLAst e@(GLGenExpr id (Fract x)) = mkGLExpr id e "fract" [toGLAst x] +toGLAst e@(GLGenExpr id (Mod x y)) = mkGLExpr id e "mod" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Min x y)) = mkGLExpr id e "min" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Max x y)) = mkGLExpr id e "max" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Clamp x y z)) = mkGLExpr id e "clamp" [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (Mix x y z)) = mkGLExpr id e "mix" [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (Step x y)) = mkGLExpr id e "step" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Smoothstep x y z)) = mkGLExpr id e "smoothstep" [toGLAst x, toGLAst y, toGLAst z] + +toGLAst e@(GLGenExpr id (Length x)) = mkGLExpr id e "length" [toGLAst x] +toGLAst e@(GLGenExpr id (Distance x y)) = mkGLExpr id e "distance" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Dot x y)) = mkGLExpr id e "dot" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Cross x y)) = mkGLExpr id e "cross" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Normalize x)) = mkGLExpr id e "normalize" [toGLAst x] +toGLAst e@(GLGenExpr id (Faceforward x y z)) = mkGLExpr id e "faceforward" [toGLAst x, toGLAst y, toGLAst z] +toGLAst e@(GLGenExpr id (Reflect x y)) = mkGLExpr id e "reflect" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Refract x y z)) = mkGLExpr id e "refract" [toGLAst x, toGLAst y, toGLAst z] + +toGLAst e@(GLGenExpr id (MatrixCompMult x y)) = mkGLExpr id e "matrixCompMult" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (OuterProduct x y)) = mkGLExpr id e "outerProduct" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Transpose x)) = mkGLExpr id e "transpose" [toGLAst x] +toGLAst e@(GLGenExpr id (Determinant x)) = mkGLExpr id e "determinant" [toGLAst x] +toGLAst e@(GLGenExpr id (Inverse x)) = mkGLExpr id e "inverse" [toGLAst x] + +toGLAst e@(GLGenExpr id (LessThan x y)) = mkGLExpr id e "lessThan" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (LessThanEqual x y)) = mkGLExpr id e "lessThanEqual" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (GreaterThan x y)) = mkGLExpr id e "greaterThan" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (GreaterThanEqual x y)) = mkGLExpr id e "greaterThanEqual" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Equal x y)) = mkGLExpr id e "equal" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (NotEqual x y)) = mkGLExpr id e "notEqual" [toGLAst x, toGLAst y] +toGLAst e@(GLGenExpr id (Any x)) = mkGLExpr id e "any" [toGLAst x] +toGLAst e@(GLGenExpr id (All x)) = mkGLExpr id e "all" [toGLAst x] +toGLAst e@(GLGenExpr id (Not x)) = mkGLExpr id e "not" [toGLAst x] diff --git a/src/Graphics/HaGL/GLExpr.hs b/src/Graphics/HaGL/GLExpr.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/GLExpr.hs @@ -0,0 +1,431 @@ +module Graphics.HaGL.GLExpr ( + GLExpr(..), + GLAtom(..), + GLFunc(..), + GLGenExpr(..), + GLDomain(..), + shaderDomains, + InterpolationType(..), + IOVarID, + GLCoord(..), + GLCoordList(..), + GLCol(..), + GLExprException(..), + ConstExpr, + HostExpr, + VertExpr, + FragExpr +) where + +import Prelude hiding (id) +import GHC.TypeNats +import Control.Exception (Exception) + +import Graphics.HaGL.GLType +import Graphics.HaGL.ExprID +import Graphics.HaGL.Util.Types +import qualified Graphics.HaGL.Util.DepMap as DepMap + + +-- * Expression definitions + +-- | A generic HaGL expression with domain of computation @d@ and underlying type @t@ +data GLExpr (d :: GLDomain) (t :: *) where + GLAtom :: GLType t => ExprID -> GLAtom d t -> GLExpr d t + GLFunc :: GLType t => ExprID -> GLFunc d t -> GLExpr d t + GLGenExpr :: GLType t => ExprID -> GLGenExpr d t -> GLExpr d t + + +-- Irreducible variables and placeholders + +data GLAtom (d :: GLDomain) (t :: *) where + + Const :: GLType t => + t -> GLAtom d t + -- Generic variables; e.g., function parameters + GenVar :: GLType t => GLAtom d t + Uniform :: GLType t => + GLExpr HostDomain t -> GLAtom d t + GenericUniform :: GLType t => + String -> GLAtom d t + Inp :: GLInputType t => + [GLExpr ConstDomain t] -> GLAtom VertexDomain t + Frag :: GLInputType t => + InterpolationType -> GLExpr VertexDomain t -> GLAtom FragmentDomain t + + -- IO variables and placeholders exclusive to HostDomain + IOFloat :: IOVarID -> GLAtom HostDomain Float + IODouble :: IOVarID -> GLAtom HostDomain Double + IOInt :: IOVarID -> GLAtom HostDomain Int + IOUInt :: IOVarID -> GLAtom HostDomain UInt + IOBool :: IOVarID -> GLAtom HostDomain Bool + IOPrec :: GLType t => GLExpr HostDomain t -> GLExpr HostDomain t -> GLAtom HostDomain t + GLLift0 :: GLType t => + t -> GLAtom HostDomain t + GLLift1 :: (GLType t, GLType t1) => + (t1 -> t) -> GLExpr HostDomain t1 -> GLAtom HostDomain t + GLLift2 :: (GLType t, GLType t1, GLType t2) => + (t1 -> t2 -> t) -> GLExpr HostDomain t1 -> GLExpr HostDomain t2 -> GLAtom HostDomain t + GLLift3 :: (GLType t, GLType t1, GLType t2, GLType t3) => + (t1 -> t2 -> t3 -> t) -> GLExpr HostDomain t1 -> GLExpr HostDomain t2 -> GLExpr HostDomain t3 -> GLAtom HostDomain t + GLLift4 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4) => + (t1 -> t2 -> t3 -> t4 -> t) -> GLExpr HostDomain t1 -> GLExpr HostDomain t2 -> GLExpr HostDomain t3 -> GLExpr HostDomain t4 -> GLAtom HostDomain t + GLLift5 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4, GLType t5) => + (t1 -> t2 -> t3 -> t4 -> t5 -> t) -> GLExpr HostDomain t1 -> GLExpr HostDomain t2 -> GLExpr HostDomain t3 -> GLExpr HostDomain t4 -> GLExpr HostDomain t5 -> GLAtom HostDomain t + GLLift6 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4, GLType t5, GLType t6) => + (t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> t) -> GLExpr HostDomain t1 -> GLExpr HostDomain t2 -> GLExpr HostDomain t3 -> GLExpr HostDomain t4 -> GLExpr HostDomain t5 -> GLExpr HostDomain t6 -> GLAtom HostDomain t + + +-- User-defined functions + +data GLFunc (d :: GLDomain) (t :: *) where + + GLFunc1 :: (GLType t, GLType t1) => + (GLExpr d t1 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t1 -> GLFunc d t + GLFunc2 :: (GLType t, GLType t1, GLType t2) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> + GLExpr d t1 -> GLExpr d t2 -> GLFunc d t + GLFunc3 :: (GLType t, GLType t1, GLType t2, GLType t3) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLFunc d t + GLFunc4 :: (GLType t, GLType t1, GLType t2, GLType t3) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLFunc d t + GLFunc5 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4, GLType t5) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLFunc d t + GLFunc6 :: (GLType t, GLType t1, GLType t2, GLType t3, GLType t4, GLType t5, GLType t6) => + (GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t6 -> GLExpr d t) -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t6 -> + GLExpr d t1 -> GLExpr d t2 -> GLExpr d t3 -> GLExpr d t4 -> GLExpr d t5 -> GLExpr d t6 -> GLFunc d t + + +-- Compound expressions corresponding to built-in functions and operators + +data GLGenExpr (d :: GLDomain) (t :: *) where + + GLVec2 :: (GLType (Vec 2 t)) => + GLExpr d t -> GLExpr d t -> GLGenExpr d (Vec 2 t) + GLVec3 :: (GLType (Vec 3 t)) => + GLExpr d t -> GLExpr d t -> GLExpr d t -> GLGenExpr d (Vec 3 t) + GLVec4 :: (GLType (Vec 4 t)) => + GLExpr d t -> GLExpr d t -> GLExpr d t -> GLExpr d t -> GLGenExpr d (Vec 4 t) + GLMat2x2 :: (GLFloating t, GLType (Vec 2 t), GLType (Mat 2 2 t)) => + GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) -> GLGenExpr d (Mat 2 2 t) + GLMat2x3 :: (GLFloating t, GLType (Vec 2 t), GLType (Mat 2 3 t)) => + GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) -> GLGenExpr d (Mat 2 3 t) + GLMat2x4 :: (GLFloating t, GLType (Vec 2 t), GLType (Mat 2 4 t)) => + GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) -> GLExpr d (Vec 2 t) -> GLGenExpr d (Mat 2 4 t) + GLMat3x2 :: (GLFloating t, GLType (Vec 3 t), GLType (Mat 3 2 t)) => + GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLGenExpr d (Mat 3 2 t) + GLMat3x3 :: (GLFloating t, GLType (Vec 3 t), GLType (Mat 3 3 t)) => + GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLGenExpr d (Mat 3 3 t) + GLMat3x4 :: (GLFloating t, GLType (Vec 3 t), GLType (Mat 3 4 t)) => + GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLGenExpr d (Mat 3 4 t) + GLMat4x2 :: (GLFloating t, GLType (Vec 4 t), GLType (Mat 4 2 t)) => + GLExpr d (Vec 4 t) -> GLExpr d (Vec 4 t) -> GLGenExpr d (Mat 4 2 t) + GLMat4x3 :: (GLFloating t, GLType (Vec 4 t), GLType (Mat 4 3 t)) => + GLExpr d (Vec 4 t) -> GLExpr d (Vec 4 t) -> GLExpr d (Vec 4 t) -> GLGenExpr d (Mat 4 3 t) + GLMat4x4 :: (GLFloating t, GLType (Vec 4 t), GLType (Mat 4 4 t)) => + GLExpr d (Vec 4 t) -> GLExpr d (Vec 4 t) -> GLExpr d (Vec 4 t) -> GLExpr d (Vec 4 t) -> GLGenExpr d (Mat 4 4 t) + Pre :: (GLType (Vec n t), GLType (Vec (n + 1) t)) => + GLExpr d t -> GLExpr d (Vec n t) -> GLGenExpr d (Vec (n + 1) t) + App :: (GLType (Vec n t), GLType t, GLType (Vec (n + 1) t)) => + GLExpr d (Vec n t) -> GLExpr d t -> GLGenExpr d (Vec (n + 1) t) + Conc :: (GLType (Vec m t), GLType (Vec n t), GLType (Vec (m + n) t)) => + GLExpr d (Vec m t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec (m + n) t) + GLArray :: GLType [t] => + [GLExpr HostDomain t] -> GLGenExpr HostDomain [t] + + OpCoord :: (GLType (Vec n t), m <= n) => + GLCoord m -> GLExpr d (Vec n t) -> GLGenExpr d t + OpCoordMulti :: (GLType (Vec n t), GLType (Vec l t), m <= n) => + GLCoordList l m -> GLExpr d (Vec n t) -> GLGenExpr d (Vec l t) + OpCol :: (GLType (Mat r c t), GLType (Vec r t), m + 1 <= c) => + GLCol m -> GLExpr d (Mat r c t) -> GLGenExpr d (Vec r t) + OpArrayElt :: (GLType [t], GLType t) => + GLExpr d [t] -> GLExpr d Int -> GLGenExpr d t + + Cast :: (GLPrim t1, GLPrim t2) => + GLExpr d t1 -> GLGenExpr d t2 + MatCast :: (GLPrim t1, GLPrim t2, KnownNat p, KnownNat q) => + GLExpr d (Mat p q t1) -> GLGenExpr d (Mat p q t2) + + OpAdd :: (GLNumeric (GLElt t), GLType t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpSubt :: (GLNumeric (GLElt t), GLType t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpMult :: (GLNumeric (GLElt t), GLType t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpDiv :: (GLNumeric (GLElt t), GLType t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpMod :: (GLInteger (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpNeg :: (GLNumeric (GLElt t), GLType t) => + GLExpr d t -> GLGenExpr d t + OpLessThan :: GLNumeric t => + GLExpr d t -> GLExpr d t -> GLGenExpr d Bool + OpLessThanEqual :: GLNumeric t => + GLExpr d t -> GLExpr d t -> GLGenExpr d Bool + OpGreaterThan :: GLNumeric t => + GLExpr d t -> GLExpr d t -> GLGenExpr d Bool + OpGreaterThanEqual :: GLNumeric t => + GLExpr d t -> GLExpr d t -> GLGenExpr d Bool + OpEqual :: GLType t => + GLExpr d t -> GLExpr d t -> GLGenExpr d Bool + OpNotEqual :: GLType t => + GLExpr d t -> GLExpr d t -> GLGenExpr d Bool + OpAnd :: GLExpr d Bool -> GLExpr d Bool -> GLGenExpr d Bool + OpOr :: GLExpr d Bool -> GLExpr d Bool -> GLGenExpr d Bool + OpXor :: GLExpr d Bool -> GLExpr d Bool -> GLGenExpr d Bool + OpNot :: GLExpr d Bool -> GLGenExpr d Bool + OpCond :: GLType t => + GLExpr d Bool -> GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpCompl :: GLSupportsBitwiseOps t => + GLExpr d t -> GLGenExpr d t + OpLshift :: GLSupportsBitwiseOps t => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpRshift :: GLSupportsBitwiseOps t => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpBitAnd :: GLSupportsBitwiseOps t => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpBitOr :: GLSupportsBitwiseOps t => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpBitXor :: GLSupportsBitwiseOps t => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + OpScalarMult :: (GLNumeric t, GLType (Mat p q t)) => + GLExpr d t -> GLExpr d (Mat p q t) -> GLGenExpr d (Mat p q t) + OpMatrixMult :: (GLFloating t, GLType (Mat p q t), GLType (Mat q r t), GLType (Mat p r t)) => + GLExpr d (Mat p q t) -> GLExpr d (Mat q r t) -> GLGenExpr d (Mat p r t) + + Radians :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Degrees :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Sin :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Cos :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Tan :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Asin :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Acos :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Atan :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Sinh :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Cosh :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Tanh :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Asinh :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Acosh :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Atanh :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + + Pow :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + Exp :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Log :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Exp2 :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Log2 :: (GLElt t ~ Float, GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Sqrt :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Inversesqrt :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + + Abs :: (GLSigned (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Sign :: (GLSigned (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Floor :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Trunc :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Round :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + RoundEven :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Ceil :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Fract :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLGenExpr d t + Mod :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + Min :: (GLNumeric (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + Max :: (GLNumeric (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + Clamp :: (GLNumeric (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLExpr d t -> GLGenExpr d t + Mix :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLExpr d t -> GLGenExpr d t + Step :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLGenExpr d t + Smoothstep :: (GLFloating (GLElt t), GLPrimOrVec t) => + GLExpr d t -> GLExpr d t -> GLExpr d t -> GLGenExpr d t + + Length :: GLFloating t => + GLExpr d (Vec n t) -> GLGenExpr d t + Distance :: GLFloating t => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d t + Dot :: (GLFloating t, GLType (Vec n t)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d t + Cross :: (GLFloating t, GLType (Vec 3 t)) => + GLExpr d (Vec 3 t) -> GLExpr d (Vec 3 t) -> GLGenExpr d (Vec 3 t) + Normalize :: (GLFloating t, GLType (Vec n t))=> + GLExpr d (Vec n t) -> GLGenExpr d (Vec n t) + Faceforward :: (GLFloating t, KnownNat n, GLType (Vec n t)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n t) + Reflect :: (GLFloating t, KnownNat n, GLType (Vec n t)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n t) + Refract :: (GLFloating t, KnownNat n, GLType (Vec n t), GLType t) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLExpr d t -> GLGenExpr d (Vec n t) + + MatrixCompMult :: (GLFloating t, GLType (Mat p q t), GLType (Mat p q t)) => + GLExpr d (Mat p q t) -> GLExpr d (Mat p q t) -> GLGenExpr d (Mat p q t) + OuterProduct :: (GLFloating t, GLType (Vec q t), GLType (Mat p q t)) => + GLExpr d (Vec p t) -> GLExpr d (Vec q t) -> GLGenExpr d (Mat p q t) + Transpose :: (GLFloating t, GLType (Mat p q t), GLType (Mat q p t)) => + GLExpr d (Mat p q t) -> GLGenExpr d (Mat q p t) + Determinant :: GLType (Mat p p Float) => + GLExpr d (Mat p p Float) -> GLGenExpr d Float + Inverse :: GLType (Mat p p Float) => + GLExpr d (Mat p p Float) -> GLGenExpr d (Mat p p Float) + + LessThan :: (GLSingleNumeric t, KnownNat n, GLType (Vec n Bool)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n Bool) + LessThanEqual :: (GLSingleNumeric t, KnownNat n, GLType (Vec n Bool)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n Bool) + GreaterThan :: (GLSingleNumeric t, KnownNat n, GLType (Vec n Bool)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n Bool) + GreaterThanEqual :: (GLSingleNumeric t, KnownNat n, GLType (Vec n Bool)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n Bool) + Equal :: (GLSingle t, KnownNat n, GLType (Vec n Bool)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n Bool) + NotEqual :: (GLSingle t, KnownNat n, GLType (Vec n Bool)) => + GLExpr d (Vec n t) -> GLExpr d (Vec n t) -> GLGenExpr d (Vec n Bool) + Any :: GLType (Vec n Bool) => + GLExpr d (Vec n Bool) -> GLGenExpr d Bool + All :: GLType (Vec n Bool) => + GLExpr d (Vec n Bool) -> GLGenExpr d Bool + Not :: GLType (Vec n Bool) => + GLExpr d (Vec n Bool) -> GLGenExpr d (Vec n Bool) + +-- | A label for the domain where a given computation make take place +data GLDomain = + -- | Labels a constant value computed on the host CPU + ConstDomain | + -- | Labels a potentially I/O-dependent value computed on the host CPU + HostDomain | + -- | Labels a vertex shader variable + VertexDomain | + -- | Labels a fragment shader variable + FragmentDomain + deriving (Eq, Ord) + +shaderDomains :: [GLDomain] +shaderDomains = [VertexDomain, FragmentDomain] + + +-- * Internal auxillary types + +data InterpolationType = Smooth | NoPerspective | Flat + +instance Show InterpolationType where + show Smooth = "smooth" + show NoPerspective = "noperspective" + show Flat = "flat" + +type IOVarID = String + +data GLCoord (m :: Nat) where + CoordX :: GLCoord 1 + CoordY :: GLCoord 2 + CoordZ :: GLCoord 3 + CoordW :: GLCoord 4 + +data GLCoordList (l :: Nat) (m :: Nat) where + CoordNil :: GLCoordList 0 0 + CoordCons :: GLCoord m1 -> GLCoordList l2 m2 -> GLCoordList (l2 + 1) (Max m1 m2) + +instance Show (GLCoord m) where + show CoordX = "x" + show CoordY = "y" + show CoordZ = "z" + show CoordW = "w" + +instance Show (GLCoordList l m) where + show CoordNil = "" + show (CoordCons c cs) = show c ++ show cs + +data GLCol (m :: Nat) where + Col0 :: GLCol 0 + Col1 :: GLCol 1 + Col2 :: GLCol 2 + Col3 :: GLCol 3 + +instance Show (GLCol m) where + show Col0 = "[0]" + show Col1 = "[1]" + show Col2 = "[2]" + show Col3 = "[3]" + + +-- * glExprID + +instance HasExprID (GLExpr d t) where + getID (GLAtom id _) = id + getID (GLFunc fnID (GLFunc1 _ _ x0)) = + combineIDs [fnID, getID x0] + getID (GLFunc fnID (GLFunc2 _ _ _ x0 y0)) = + combineIDs [fnID, getID x0, getID y0] + getID (GLFunc fnID (GLFunc3 _ _ _ _ x0 y0 z0)) = + combineIDs [fnID, getID x0, getID y0, getID z0] + getID (GLFunc fnID (GLFunc4 _ _ _ _ _ x0 y0 z0 w0)) = + combineIDs [fnID, getID x0, getID y0, getID z0, getID w0] + getID (GLFunc fnID (GLFunc5 _ _ _ _ _ _ x0 y0 z0 w0 u0)) = + combineIDs [fnID, getID x0, getID y0, getID z0, getID w0, getID u0] + getID (GLFunc fnID (GLFunc6 _ _ _ _ _ _ _ x0 y0 z0 w0 u0 v0)) = + combineIDs [fnID, getID x0, getID y0, getID z0, getID w0, getID u0, getID v0] + getID (GLGenExpr id _) = id + +instance DepMap.GenHashable (GLExpr d) where + genHash = getID + + +-- * Exceptions for illegal expressions that are difficult to disallow at the type level + +data GLExprException = + UnsupportedRecCall | + UnsupportedNameCapture | + UnknownArraySize + deriving Eq + +instance Show GLExprException where + show UnsupportedRecCall = "Unsupported recursive function call" + show UnsupportedNameCapture = "Unsupported name capture in nested glFunc" + show UnknownArraySize = "GLLift*: Function may only return a fixed-size list" + +instance Exception GLExprException + + +-- * Synonyms + +type ConstExpr = GLExpr ConstDomain +type HostExpr = GLExpr HostDomain +type VertExpr = GLExpr VertexDomain +type FragExpr = GLExpr FragmentDomain diff --git a/src/Graphics/HaGL/GLObj.hs b/src/Graphics/HaGL/GLObj.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/GLObj.hs @@ -0,0 +1,55 @@ +module Graphics.HaGL.GLObj ( + GLObj(..), + Graphics.HaGL.GLObj.PrimitiveMode, + GLObjException(..) +) where + +import Control.Exception (Exception) +import qualified Graphics.Rendering.OpenGL.GL.PrimitiveMode (PrimitiveMode) + +import Graphics.HaGL.Numerical (Vec) +import Graphics.HaGL.GLType +import Graphics.HaGL.GLExpr + + +-- TODO: should the indices be bundled with the PrimitiveMode? +-- | A drawable object specified by a set of variables of type 'GLExpr' and +-- the 'PrimitiveMode' according to which output vertices of the variable +-- 'position', indexed by 'indices', should be interpreted. +-- +-- When using the convenience functions 'Graphics.HaGL.points', +-- 'Graphics.HaGL.triangles', etc., to define a 'GLObj' with the corresponding +-- 'PrimitiveMode', at the very minimum the fields 'position' and 'color' must +-- be set before drawing the 'GLObj'. +data GLObj = GLObj { + -- | The 'PrimitiveMode' that will be used to draw the object + primitiveMode :: PrimitiveMode, + -- | A set of position indices used to construct the primitives of the object + indices :: Maybe [ConstExpr UInt], + -- | A vertex variable specifying the position of an arbitrary vertex + position :: VertExpr (Vec 4 Float), + -- | A fragment variable specifying the color of an arbitrary fragment + color :: FragExpr (Vec 4 Float), + -- | An fragment variable specifying the condition for discarding an arbitrary + -- fragment + discardWhen :: FragExpr Bool +} + +-- | See [Graphics.Rendering.OpenGL.GL.PrimitiveMode] +-- (https://hackage.haskell.org/package/OpenGL-3.0.3.0/docs/Graphics-Rendering-OpenGL-GL-PrimitiveMode.html#g:1) +-- for a description of each @PrimitiveMode@ +type PrimitiveMode = + Graphics.Rendering.OpenGL.GL.PrimitiveMode.PrimitiveMode + +data GLObjException = + NoInputVars | + EmptyInputVar | + MismatchedInputVars + deriving Eq + +instance Show GLObjException where + show NoInputVars = "Attempted to process a GLObj containing no input variables" + show EmptyInputVar = "Input variable initialized using empty list" + show MismatchedInputVars = "Dimensions of input variables do not match" + +instance Exception GLObjException diff --git a/src/Graphics/HaGL/GLType.hs b/src/Graphics/HaGL/GLType.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/GLType.hs @@ -0,0 +1,919 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Graphics.HaGL.GLType ( + UInt, + Vec, + Mat, + GLType(..), + GLPrimOrVec, + GLInputType(..), + GLSupportsSmoothInterp, + GLSupportsBitwiseOps, + GLElt, + GLPrim(..), + GLSingle, + GLNumeric, + GLSigned, + GLFloating, + GLSingleNumeric, + GLInteger, + genDiv +) where + +import Control.Applicative (liftA2, liftA3) +import Data.Bits +import Data.Int (Int32) +import Data.Word (Word32) +import Data.List (intercalate) +import Foreign.Storable (Storable) +import Foreign.Marshal.Array (withArray) +import qualified Graphics.Rendering.OpenGL as OpenGL +import qualified Graphics.GL as RawGL + +import Graphics.HaGL.Numerical + + +-- * Raw types + +-- | An unsigned integer +type UInt = Word32 + +-- | The class of base raw types. Users should not and +-- need not implement any instances of this class. +class (Eq t, Show t) => GLType t where + showGlslType :: a t -> String + showGlslVal :: t -> String + glMap :: (GLElt t -> GLElt t) -> t -> t + glZipWith :: (GLElt t -> GLElt t -> GLElt t) -> t -> t -> t + glZipWith3 :: (GLElt t -> GLElt t -> GLElt t -> GLElt t) -> t -> t -> t -> t + eltSize :: [t] -> Int + numComponents :: [t] -> Int + arrayLen :: t -> Int + getGlslType :: [t] -> OpenGL.DataType + uniformSet :: OpenGL.GLint -> t -> IO () + +instance GLType Float where + showGlslType = const "float" + showGlslVal = show + glMap = id + glZipWith = id + glZipWith3 = id + eltSize = const 4 + numComponents = const 1 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet = RawGL.glUniform1f +instance GLType Double where + showGlslType = const "double" + showGlslVal = show + glMap = id + glZipWith = id + glZipWith3 = id + eltSize = const 8 + numComponents = const 1 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet = RawGL.glUniform1d +instance GLType Int where + showGlslType = const "int" + showGlslVal = show + glMap = id + glZipWith = id + glZipWith3 = id + eltSize = const 4 + numComponents = const 1 + arrayLen = const 1 + getGlslType = const OpenGL.Int + uniformSet i x = RawGL.glUniform1i i (toEnum x) +instance GLType UInt where + showGlslType = const "uint" + showGlslVal x = show x ++ "u" + glMap = id + glZipWith = id + glZipWith3 = id + eltSize = const 4 + numComponents = const 1 + arrayLen = const 1 + getGlslType = const OpenGL.UnsignedInt + uniformSet = RawGL.glUniform1ui +instance GLType Bool where + showGlslType = const "bool" + showGlslVal x = if x then "true" else "false" + glMap = id + glZipWith = id + glZipWith3 = id + eltSize = const 1 + numComponents = const 1 + arrayLen = const 1 + getGlslType = const OpenGL.Byte + uniformSet i x = RawGL.glUniform1i i (fromBool x) +instance GLType (Vec 2 Float) where + showGlslType = const "vec2" + showGlslVal v = printVec "vec2" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 2 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul v = RawGL.glUniform2f ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) +instance GLType (Vec 3 Float) where + showGlslType = const "vec3" + showGlslVal v = printVec "vec3" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 3 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul v = RawGL.glUniform3f ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) (v `eltAt` (2, 0)) +instance GLType (Vec 4 Float) where + showGlslType = const "vec4" + showGlslVal v = printVec "vec4" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul v = RawGL.glUniform4f ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) (v `eltAt` (2, 0)) (v `eltAt` (3, 0)) +instance GLType (Vec 2 Double) where + showGlslType = const "dvec2" + showGlslVal v = printVec "dvec2" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 2 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul v = RawGL.glUniform2d ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) +instance GLType (Vec 3 Double) where + showGlslType = const "dvec3" + showGlslVal v = printVec "dvec3" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 3 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul v = RawGL.glUniform3d ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) (v `eltAt` (2, 0)) +instance GLType (Vec 4 Double) where + showGlslType = const "dvec4" + showGlslVal v = printVec "dvec4" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul v = RawGL.glUniform4d ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) (v `eltAt` (2, 0)) (v `eltAt` (3, 0)) +instance GLType (Vec 2 Int) where + showGlslType = const "ivec2" + showGlslVal v = printVec "ivec2" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 2 + arrayLen = const 1 + getGlslType = const OpenGL.Int + uniformSet ul v = RawGL.glUniform2i ul + (toEnum $ v `eltAt` (0, 0)) (toEnum $ v `eltAt` (1, 0)) +instance GLType (Vec 3 Int) where + showGlslType = const "ivec3" + showGlslVal v = printVec "ivec3" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 3 + arrayLen = const 1 + getGlslType = const OpenGL.Int + uniformSet ul v = RawGL.glUniform3i ul + (toEnum $ v `eltAt` (0, 0)) (toEnum $ v `eltAt` (1, 0)) (toEnum $ v `eltAt` (2, 0)) +instance GLType (Vec 4 Int) where + showGlslType = const "ivec4" + showGlslVal v = printVec "ivec4" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.Int + uniformSet ul v = RawGL.glUniform4i ul + (toEnum $ v `eltAt` (0, 0)) (toEnum $ v `eltAt` (1, 0)) (toEnum $ v `eltAt` (2, 0)) (toEnum $ v `eltAt` (3, 0)) +instance GLType (Vec 2 UInt) where + showGlslType = const "uvec2" + showGlslVal v = printVec "uvec2" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 2 + arrayLen = const 1 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul v = RawGL.glUniform2ui ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) +instance GLType (Vec 3 UInt) where + showGlslType = const "uvec3" + showGlslVal v = printVec "uvec3" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 3 + arrayLen = const 1 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul v = RawGL.glUniform3ui ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) (v `eltAt` (2, 0)) +instance GLType (Vec 4 UInt) where + showGlslType = const "uvec4" + showGlslVal v = printVec "uvec4" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul v = RawGL.glUniform4ui ul + (v `eltAt` (0, 0)) (v `eltAt` (1, 0)) (v `eltAt` (2, 0)) (v `eltAt` (3, 0)) +instance GLType (Vec 2 Bool) where + showGlslType = const "bvec2" + showGlslVal v = printVec "bvec2" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 2 + arrayLen = const 1 + getGlslType = const OpenGL.Byte + uniformSet ul v = RawGL.glUniform2i ul + (fromBool $ v `eltAt` (0, 0)) (fromBool $ v `eltAt` (1, 0)) +instance GLType (Vec 3 Bool) where + showGlslType = const "bvec3" + showGlslVal v = printVec "bvec3" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 3 + arrayLen = const 1 + getGlslType = const OpenGL.Byte + uniformSet ul v = RawGL.glUniform3i ul + (fromBool $ v `eltAt` (0, 0)) (fromBool $ v `eltAt` (1, 0)) (fromBool $ v `eltAt` (2, 0)) +instance GLType (Vec 4 Bool) where + showGlslType = const "bvec4" + showGlslVal v = printVec "bvec4" (toList v) + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.Byte + uniformSet ul v = RawGL.glUniform4i ul + (fromBool $ v `eltAt` (0, 0)) (fromBool $ v `eltAt` (1, 0)) (fromBool $ v `eltAt` (2, 0)) (fromBool $ v `eltAt` (3, 0)) +instance GLType (Mat 2 2 Float) where + showGlslVal m = printVec "mat2x2" (toList $ transpose m) + showGlslType = const "mat2x2" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix2fv ul (toList $ transpose m) +instance GLType (Mat 2 3 Float) where + showGlslVal m = printVec "mat3x2" (toList $ transpose m) + showGlslType = const "mat3x2" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 6 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix3x2fv ul (toList $ transpose m) +instance GLType (Mat 2 4 Float) where + showGlslVal m = printVec "mat4x2" (toList $ transpose m) + showGlslType = const "mat4x2" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 8 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix4x2fv ul (toList $ transpose m) +instance GLType (Mat 3 2 Float) where + showGlslVal m = printVec "mat2x3" (toList $ transpose m) + showGlslType = const "mat2x3" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 6 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix2x3fv ul (toList $ transpose m) +instance GLType (Mat 3 3 Float) where + showGlslVal m = printVec "mat3x3" (toList $ transpose m) + showGlslType = const "mat3x3" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 9 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix3fv ul (toList $ transpose m) +instance GLType (Mat 3 4 Float) where + showGlslVal m = printVec "mat4x3" (toList $ transpose m) + showGlslType = const "mat4x3" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 12 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix4x3fv ul (toList $ transpose m) +instance GLType (Mat 4 2 Float) where + showGlslVal m = printVec "mat2x4" (toList $ transpose m) + showGlslType = const "mat2x4" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 8 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix2x4fv ul (toList $ transpose m) +instance GLType (Mat 4 3 Float) where + showGlslVal m = printVec "mat3x4" (toList $ transpose m) + showGlslType = const "mat3x4" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 12 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix3x4fv ul (toList $ transpose m) +instance GLType (Mat 4 4 Float) where + showGlslVal m = printVec "mat4x4" (toList $ transpose m) + showGlslType = const "mat4x4" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 4 + numComponents = const 16 + arrayLen = const 1 + getGlslType = const OpenGL.Float + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix4fv ul (toList $ transpose m) +instance GLType (Mat 2 2 Double) where + showGlslVal m = printVec "dmat2x2" (toList $ transpose m) + showGlslType = const "dmat2x2" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 4 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix2dv ul (toList $ transpose m) +instance GLType (Mat 2 3 Double) where + showGlslVal m = printVec "dmat3x2" (toList $ transpose m) + showGlslType = const "dmat3x2" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 6 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix3x2dv ul (toList $ transpose m) +instance GLType (Mat 2 4 Double) where + showGlslVal m = printVec "dmat4x2" (toList $ transpose m) + showGlslType = const "dmat4x2" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 8 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix4x2dv ul (toList $ transpose m) +instance GLType (Mat 3 2 Double) where + showGlslVal m = printVec "dmat2x3" (toList $ transpose m) + showGlslType = const "dmat2x3" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 6 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix2x3dv ul (toList $ transpose m) +instance GLType (Mat 3 3 Double) where + showGlslVal m = printVec "dmat3x3" (toList $ transpose m) + showGlslType = const "dmat3x3" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 9 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix3dv ul (toList $ transpose m) +instance GLType (Mat 3 4 Double) where + showGlslVal m = printVec "dmat4x3" (toList $ transpose m) + showGlslType = const "dmat4x3" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 12 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix4x3dv ul (toList $ transpose m) +instance GLType (Mat 4 2 Double) where + showGlslVal m = printVec "dmat2x4" (toList $ transpose m) + showGlslType = const "dmat2x4" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 8 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix2x4dv ul (toList $ transpose m) +instance GLType (Mat 4 3 Double) where + showGlslVal m = printVec "dmat3x4" (toList $ transpose m) + showGlslType = const "dmat3x4" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + eltSize = const 8 + numComponents = const 12 + arrayLen = const 1 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix3x4dv ul (toList $ transpose m) +instance GLType (Mat 4 4 Double) where + showGlslVal m = printVec "dmat4x4" (toList $ transpose m) + showGlslType = const "dmat4x4" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = const 1 + eltSize = const 8 + numComponents = const 16 + getGlslType = const OpenGL.Double + uniformSet ul m = + makeMatSetter RawGL.glUniformMatrix4dv ul (toList $ transpose m) +instance GLType [Float] where + showGlslVal xs = "float[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "float[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 1 + getGlslType = const OpenGL.Float + uniformSet ul xs = + withArray xs $ RawGL.glUniform1fv ul (fromIntegral $ Prelude.length xs) +instance GLType [Vec 2 Float] where + showGlslVal xs = "vec2[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "vec2[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 2 + getGlslType = const OpenGL.Float + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform2fv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 3 Float] where + showGlslVal xs = "vec3[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "vec3[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 3 + getGlslType = const OpenGL.Float + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform3fv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 4 Float] where + showGlslVal xs = "vec4[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "vec4[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 4 + getGlslType = const OpenGL.Float + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform4fv ul (fromIntegral $ Prelude.length xs') +instance GLType [Double] where + showGlslVal xs = "double[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "double[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 8 + numComponents = const 1 + getGlslType = const OpenGL.Double + uniformSet ul xs = + withArray xs $ RawGL.glUniform1dv ul (fromIntegral $ Prelude.length xs) +instance GLType [Vec 2 Double] where + showGlslVal xs = "dvec2[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "dvec2[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 8 + numComponents = const 2 + getGlslType = const OpenGL.Double + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform2dv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 3 Double] where + showGlslVal xs = "dvec3[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "dvec3[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 8 + numComponents = const 3 + getGlslType = const OpenGL.Double + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform3dv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 4 Double] where + showGlslVal xs = "dvec4[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "dvec4[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 8 + numComponents = const 4 + getGlslType = const OpenGL.Double + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform4dv ul (fromIntegral $ Prelude.length xs') +instance GLType [Int] where + showGlslVal xs = "int[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "int[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 1 + getGlslType = const OpenGL.Int + uniformSet ul xs = let xs' = map toEnum xs in + withArray xs' $ RawGL.glUniform1iv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 2 Int] where + showGlslVal xs = "ivec2[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "ivec2[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 2 + getGlslType = const OpenGL.Int + uniformSet ul xs = let xs' = map toEnum $ concatMap toList xs in + withArray xs' $ RawGL.glUniform2iv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 3 Int] where + showGlslVal xs = "ivec3[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "ivec3[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 3 + getGlslType = const OpenGL.Int + uniformSet ul xs = let xs' = map toEnum $ concatMap toList xs in + withArray xs' $ RawGL.glUniform3iv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 4 Int] where + showGlslVal xs = "ivec4[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "ivec4[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 4 + getGlslType = const OpenGL.Int + uniformSet ul xs = let xs' = map toEnum $ concatMap toList xs in + withArray xs' $ RawGL.glUniform4iv ul (fromIntegral $ Prelude.length xs') +instance GLType [UInt] where + showGlslVal xs = "uint[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "uint[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 1 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul xs = + withArray xs $ RawGL.glUniform1uiv ul (fromIntegral $ Prelude.length xs) +instance GLType [Vec 2 UInt] where + showGlslVal xs = "uvec2[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "uvec2[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 2 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform2uiv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 3 UInt] where + showGlslVal xs = "uvec3[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "uvec3[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 3 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform3uiv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 4 UInt] where + showGlslVal xs = "uvec4[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "uvec4[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 4 + numComponents = const 4 + getGlslType = const OpenGL.UnsignedInt + uniformSet ul xs = let xs' = concatMap toList xs in + withArray xs' $ RawGL.glUniform4uiv ul (fromIntegral $ Prelude.length xs') +instance GLType [Bool] where + showGlslVal xs = "bool[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "bool[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 1 + numComponents = const 1 + getGlslType = const OpenGL.Byte + uniformSet ul xs = let xs' = map fromBool xs in + withArray xs' $ RawGL.glUniform1iv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 2 Bool] where + showGlslVal xs = "bvec2[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "bvec2[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 1 + numComponents = const 2 + getGlslType = const OpenGL.Byte + uniformSet ul xs = let xs' = map fromBool $ concatMap toList xs in + withArray xs' $ RawGL.glUniform2iv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 3 Bool] where + showGlslVal xs = "bvec3[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "bvec3[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 1 + numComponents = const 3 + getGlslType = const OpenGL.Byte + uniformSet ul xs = let xs' = map fromBool $ concatMap toList xs in + withArray xs' $ RawGL.glUniform3iv ul (fromIntegral $ Prelude.length xs') +instance GLType [Vec 4 Bool] where + showGlslVal xs = "bvec4[](" ++ intercalate ", " (map showGlslVal xs) ++ ")" + showGlslType = const "bvec4[]" + glMap = fmap + glZipWith = liftA2 + glZipWith3 = liftA3 + arrayLen = Prelude.length + eltSize = const 1 + numComponents = const 4 + getGlslType = const OpenGL.Byte + uniformSet ul xs = let xs' = map fromBool $ concatMap toList xs in + withArray xs' $ RawGL.glUniform4iv ul (fromIntegral $ Prelude.length xs') + +fromBool = toEnum . fromEnum + +printVec name xs = name ++ "(" ++ intercalate ", " (map showGlslVal xs) ++ ")" + +makeMatSetter rawSetter ul xs = do + m :: OpenGL.GLmatrix t <- OpenGL.newMatrix OpenGL.RowMajor xs + OpenGL.withMatrix m $ const $ rawSetter ul 1 0 + + +-- | A primitive type or a vector type +class GLType t => GLPrimOrVec t + +instance GLPrimOrVec Float +instance GLPrimOrVec Double +instance GLPrimOrVec Int +instance GLPrimOrVec UInt +instance GLPrimOrVec (Vec 2 Float) +instance GLPrimOrVec (Vec 3 Float) +instance GLPrimOrVec (Vec 4 Float) +instance GLPrimOrVec (Vec 2 Double) +instance GLPrimOrVec (Vec 3 Double) +instance GLPrimOrVec (Vec 4 Double) +instance GLPrimOrVec (Vec 2 Int) +instance GLPrimOrVec (Vec 3 Int) +instance GLPrimOrVec (Vec 4 Int) +instance GLPrimOrVec (Vec 2 UInt) +instance GLPrimOrVec (Vec 3 UInt) +instance GLPrimOrVec (Vec 4 UInt) + +-- | The underlying type of a vertex input variable. +-- Double-precision types are currently not permitted due to an issue in the +-- OpenGL bindings. +class (GLPrimOrVec t, Storable (StoreElt t)) => GLInputType t where + type StoreElt t + toStorableList :: [t] -> [StoreElt t] + +instance GLInputType Float where + type StoreElt Float = Float + toStorableList = id +-- Not currently supported due to +-- https://github.com/haskell-opengl/OpenGL/issues/94 +{-instance GLInputType Double where + type StoreElt Double = Double + toStorableList = id-} +instance GLInputType Int where + type StoreElt Int = Int32 + toStorableList = map fromIntegral +instance GLInputType UInt where + type StoreElt UInt = Word32 + toStorableList = id +instance GLInputType (Vec 2 Float) where + type StoreElt (Vec 2 Float) = Float + toStorableList = concatMap toList +instance GLInputType (Vec 3 Float) where + type StoreElt (Vec 3 Float) = Float + toStorableList = concatMap toList +instance GLInputType (Vec 4 Float) where + type StoreElt (Vec 4 Float) = Float + toStorableList = concatMap toList +-- Not currently supported due to +-- https://github.com/haskell-opengl/OpenGL/issues/94 +{-instance GLInputType (Vec 2 Double) where + type StoreElt (Vec 2 Double) = Double + toStorableList = concatMap toList +instance GLInputType (Vec 3 Double) where + type StoreElt (Vec 3 Double) = Double + toStorableList = concatMap toList +instance GLInputType (Vec 4 Double) where + type StoreElt (Vec 4 Double) = Double + toStorableList = concatMap toList-} +instance GLInputType (Vec 2 Int) where + type StoreElt (Vec 2 Int) = Int32 + toStorableList = concatMap (map fromIntegral . toList) +instance GLInputType (Vec 3 Int) where + type StoreElt (Vec 3 Int) = Int32 + toStorableList = concatMap (map fromIntegral . toList) +instance GLInputType (Vec 4 Int) where + type StoreElt (Vec 4 Int) = Int32 + toStorableList = concatMap (map fromIntegral . toList) +instance GLInputType (Vec 2 UInt) where + type StoreElt (Vec 2 UInt) = Word32 + toStorableList = concatMap toList +instance GLInputType (Vec 3 UInt) where + type StoreElt (Vec 3 UInt) = Word32 + toStorableList = concatMap toList +instance GLInputType (Vec 4 UInt) where + type StoreElt (Vec 4 UInt) = Word32 + toStorableList = concatMap toList + +-- | Any type whose values can be interpolated smoothly when constructing a +-- fragment variable +class GLInputType t => GLSupportsSmoothInterp t + +instance GLSupportsSmoothInterp Float +instance GLSupportsSmoothInterp (Vec 2 Float) +instance GLSupportsSmoothInterp (Vec 3 Float) +instance GLSupportsSmoothInterp (Vec 4 Float) + +-- | Any type which supports bitwise operations +class (GLType t, Integral (GLElt t), Bits (GLElt t)) => GLSupportsBitwiseOps t + +instance GLSupportsBitwiseOps Int +instance GLSupportsBitwiseOps UInt +instance GLSupportsBitwiseOps (Vec 2 Int) +instance GLSupportsBitwiseOps (Vec 3 Int) +instance GLSupportsBitwiseOps (Vec 4 Int) +instance GLSupportsBitwiseOps (Vec 2 UInt) +instance GLSupportsBitwiseOps (Vec 3 UInt) +instance GLSupportsBitwiseOps (Vec 4 UInt) + + +-- | The type of the elements of @t@ or @t@ itself if @t@ is primitive +type family GLElt t where + GLElt (Mat r c t) = t + GLElt [t] = t + GLElt Float = Float + GLElt Double = Double + GLElt Int = Int + GLElt UInt = UInt + GLElt Bool = Bool + + +-- * Primitive GLTypes + +-- | Any primitive type +class (GLType t, Storable t, Enum t, Eq t, Ord t) => GLPrim t where + glCast :: GLPrim t0 => t0 -> t +instance GLPrim Float where + glCast = fromIntegral . fromEnum +instance GLPrim Double where + glCast = fromIntegral . fromEnum +instance GLPrim Int where + glCast = fromEnum +instance GLPrim UInt where + glCast = fromIntegral . fromEnum +instance GLPrim Bool where + glCast = (/= toEnum 0) + +-- | Any single-precision primitive type +class (GLPrim t, Storable t, Enum t, Eq t, Ord t) => GLSingle t +instance GLSingle Float +instance GLSingle Int +instance GLSingle UInt +instance GLSingle Bool + +-- | Any numeric primitive type +class (GLPrim t, Num t) => GLNumeric t where + genDiv :: t -> t -> t +instance GLNumeric Float where genDiv = (/) +instance GLNumeric Double where genDiv = (/) +instance GLNumeric Int where genDiv = div +instance GLNumeric UInt where genDiv = div + +-- | Any signed primitive type +class GLNumeric t => GLSigned t where +instance GLSigned Float +instance GLSigned Double +instance GLSigned Int + +-- | Any single- or double-precision floating-point type +class (GLSigned t, RealFrac t, Floating t) => GLFloating t +instance GLFloating Float +instance GLFloating Double + +-- | Any single-precision signed primitive type +class GLSigned t => GLSingleNumeric t +instance GLSingleNumeric Float +instance GLSingleNumeric Int + +-- | Any signed or unsigned integer type +class (GLPrim t, Integral t, Bits t) => GLInteger t +instance GLInteger Int +instance GLInteger UInt diff --git a/src/Graphics/HaGL/Internal.hs b/src/Graphics/HaGL/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Internal.hs @@ -0,0 +1,25 @@ +module Graphics.HaGL.Internal ( + constEval, + hostEval, + printGLExpr, + dumpGlsl, + genericUniform, + IOEvaluator, + GLExprException(..), + GLObjException(..), + EvalException(..) +) where + +import Graphics.HaGL.GLType (GLType) +import Graphics.HaGL.ExprID (genID) +import Graphics.HaGL.GLExpr +import Graphics.HaGL.GLObj +import Graphics.HaGL.Eval +import Graphics.HaGL.CodeGen +import Graphics.HaGL.Print + +dumpGlsl :: GLObj -> String +dumpGlsl = show . genProgram + +genericUniform :: GLType t => String -> GLExpr d t +genericUniform label = GLAtom (genID ()) $ GenericUniform label diff --git a/src/Graphics/HaGL/Numerical.hs b/src/Graphics/HaGL/Numerical.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Numerical.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Graphics.HaGL.Numerical ( + Mat, Vec, RowVec, + m0, (%|), (%-), + horConcat, vertConcat, + toList, + fromMapping, + fromList, + eltAt, eltsAt, matCol, + Graphics.HaGL.Numerical.length, + distance, + dot, + cross, + normalize, + transpose, + matMult, + outerProduct, + determinant, + inverse +) where + +import Data.Array +import Data.List (intercalate, length) +import Data.Proxy +import GHC.TypeLits + +import qualified Data.Matrix as Mat (fromList, toList, inverse, detLU) + +import Graphics.HaGL.Util.Types (FinList, flToList) +import Graphics.HaGL.Util (warn) + +-- | A matrix with @p@ rows, @q@ columns, and element type @t@ +data Mat (p :: Nat) (q :: Nat) (t :: *) where + Mat :: Array (Int, Int) t -> Mat p q t + +-- | A column vector with @n@ elements and element type @t@ +type Vec n t = Mat n 1 t + +type RowVec n t = Mat 1 n t + +m0 :: Mat 1 0 t +m0 = Mat $ array ((0, 0),(-1, -1)) [] + +infixr 9 %| +infixr 8 %- + +(%|) :: t -> RowVec q t -> RowVec (q + 1) t +x %| Mat xs = Mat $ listArray ((0, 0), (0, q + 1)) (x : elems xs) where + ((0, 0), (_, q)) = bounds xs + +(%-) :: RowVec q t -> Mat p q t -> Mat (p + 1) q t +Mat xs %- Mat ys = Mat $ listArray ((0, 0), (p + 1, q)) (elems xs ++ elems ys) where + ((0, 0), (p, q)) = bounds ys + +horConcat :: Mat p q1 t -> Mat p q2 t -> Mat p (q1 + q2) t +horConcat m1 m2 = transpose (vertConcat (transpose m1) (transpose m2)) + +vertConcat :: Mat p1 q t -> Mat p2 q t -> Mat (p1 + p2) q t +vertConcat (Mat xs) (Mat ys) = Mat $ listArray ((0, 0), (p1 + p2 + 1, q)) (elems xs ++ elems ys) where + ((0, 0), (p1, q)) = bounds xs + ((0, 0), (p2, _)) = bounds ys + +instance Eq t => Eq (Mat p q t) where + (Mat xs) == (Mat ys) = xs == ys + +instance Functor (Mat p q) where + fmap f (Mat xs) = Mat (fmap f xs) + +instance Foldable (Mat p q) where + foldr f z (Mat xs) = foldr f z xs + +instance (KnownNat p, KnownNat q) => Applicative (Mat p q) where + pure x = let p = fromInteger $ natVal (Proxy :: Proxy p) + q = fromInteger $ natVal (Proxy :: Proxy q) + in Mat $ listArray ((0, 0),(p-1, q-1)) (replicate (p*q) x) + Mat fs <*> Mat xs = Mat $ listArray (bounds fs) + [(fs ! ind) (xs ! ind) | ind <- range (bounds fs)] + +instance (KnownNat p, KnownNat q, Num t) => Num (Mat p q t) where + m1 + m2 = (+) <$> m1 <*> m2 + m1 - m2 = (-) <$> m1 <*> m2 + m1 * m2 = (*) <$> m1 <*> m2 + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance (KnownNat p, KnownNat q, Fractional t) => Fractional (Mat p q t) where + m1 / m2 = (/) <$> m1 <*> m2 + fromRational = pure . fromRational + +-- TODO: Integral support? + +instance Show t => Show (Mat p q t) where + show (Mat xs) = intercalate "\n" [showRow i | i <- [0..p]] ++ "\n" where + showRow i = intercalate " " [showElt i j | j <- [0..q]] + showElt i j = show $ xs ! (i, j) + ((0, 0), (p, q)) = bounds xs + + +toList :: Mat p q t -> [t] +toList (Mat xs) = elems xs + +-- | Construct a matrix from a mapping that maps indices @(i, j)@ to +-- the element at row @i@ and column @j@ +fromMapping :: forall p q t. (KnownNat p, KnownNat q) => ((Int, Int) -> t) -> Mat p q t +fromMapping f = + let p = fromInteger $ natVal (Proxy :: Proxy p) + q = fromInteger $ natVal (Proxy :: Proxy q) + in Mat $ array ((0, 0), (p-1, q-1)) + [(ind, f ind) | ind <- range ((0, 0), (p-1, q-1))] + +-- | Construct a matrix from a list of the matrix elements in row-major order +fromList :: forall p q t. (KnownNat p, KnownNat q) => [t] -> Mat p q t +fromList xs = + let p = fromInteger $ natVal (Proxy :: Proxy p) + q = fromInteger $ natVal (Proxy :: Proxy q) + in Mat $ listArray ((0, 0), (p-1, q-1)) xs + +eltAt :: Mat p q t -> (Int, Int) -> t +eltAt (Mat xs) (i, j) = xs ! (i, j) + +eltsAt :: Mat p q t -> FinList m (Int, Int) -> Vec m t +eltsAt (Mat xs) fl = Mat $ listArray ((0, 0), (m-1, 0)) vs where + vs = [xs ! ind | ind <- inds] + inds = flToList fl + m = Data.List.length inds + +matCol :: Mat p q t -> Int -> Vec p t +matCol (Mat xs) j = Mat $ listArray ((0, 0), (p, 0)) vs where + vs = [xs ! (i, j) | i <- [0..p]] + ((0, 0), (p, _)) = bounds xs + + +length :: Floating t => Vec n t -> t +length (Mat xs) = sqrt $ sum + [(xs ! (i, 0)) ** 2 | (i, 0) <- range $ bounds xs] + +distance :: Floating t => Vec n t -> Vec n t -> t +distance (Mat xs) (Mat ys) = sqrt $ sum + [((xs ! (i, 0)) - (ys ! (i, 0))) ** 2 | (i, 0) <- range $ bounds xs] + +dot :: Num t => Vec n t -> Vec n t -> t +dot (Mat xs) (Mat ys) = + sum [(xs ! (i, 0)) * (ys ! (i, 0)) | (i, 0) <- range $ bounds xs] + +cross :: Num t => Vec 3 t -> Vec 3 t -> Vec 3 t +cross (Mat xs) (Mat ys) = Mat $ listArray (bounds xs) zs where + zs = [(xs ! (1, 0)) * (ys ! (2, 0)) - (xs ! (2, 0)) * (ys ! (1, 0)), + (xs ! (0, 0)) * (ys ! (2, 0)) - (xs ! (2, 0)) * (ys ! (0, 0)), + (xs ! (0, 0)) * (ys ! (1, 0)) - (xs ! (1, 0)) * (ys ! (0, 0))] + +normalize :: Floating t => Vec n t -> Vec n t +normalize v@(Mat xs) = + Mat $ listArray (bounds xs) (map (/ Graphics.HaGL.Numerical.length v) (elems xs)) + + +transpose :: Mat p q t -> Mat q p t +transpose (Mat xs) = Mat $ array ((0, 0), (q, p)) xst where + xst = [((j, i), xs ! (i, j)) | (i, j) <- range ((0, 0), (p, q))] + ((0, 0), (p, q)) = bounds xs + +matMult :: Num t => Mat p q t -> Mat q r t -> Mat p r t +matMult (Mat xs) (Mat ys) = Mat $ array ((0, 0), (p, r)) zs where + zs = [((i, j), matElt i j) | (i, j) <- range ((0, 0), (p, r))] + matElt i j = sum [(xs ! (i, k)) * (ys ! (k, j)) | k <- [0..q]] + ((0, 0), (p, q)) = bounds xs + ((0, 0), (_, r)) = bounds ys + +outerProduct :: Num t => Vec p t -> Vec q t -> Mat p q t +outerProduct (Mat xs) (Mat ys) = Mat $ array ((0, 0), (p, q)) zs where + zs = [((i, j), (xs ! (i, 1)) * (ys ! (j, 1))) | (i, j) <- range ((0, 0), (p, q))] + ((0, 0), (p, 1)) = bounds xs + ((0, 0), (q, 1)) = bounds ys + +determinant :: (Fractional t, Ord t) => Mat p p t -> t +determinant (Mat xs) = Mat.detLU $ Mat.fromList (p + 1) (p + 1) (elems xs) where + ((0, 0), (p, _)) = bounds xs + +inverse :: (Fractional t, Eq t) => Mat p p t -> Mat p p t +inverse (Mat xs) = + case Mat.inverse $ Mat.fromList (p + 1) (p + 1) (elems xs) of + Right m -> Mat $ listArray ((0, 0), (p, p)) $ Mat.toList m + Left msg -> warn msg (Mat xs) + where ((0, 0), (p, _)) = bounds xs diff --git a/src/Graphics/HaGL/Print.hs b/src/Graphics/HaGL/Print.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Print.hs @@ -0,0 +1,120 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Graphics.HaGL.Print (printGLExpr) where + +import Prelude hiding (id) +import Control.Monad.State.Lazy (State, execState, gets, modify) +import qualified Data.Set as Set + +import Graphics.HaGL.GLExpr +import Graphics.HaGL.ExprID +import Graphics.HaGL.GLAst + + +-- GLAst printers for debugging purposes + +printGLExpr :: IsGLDomain d => GLExpr d t -> String +printGLExpr = show . toGLAst + +instance Show GLAst where + show = runPrinter . printGLAst + +instance Show GLDomain where + show ConstDomain = "const" + show HostDomain = "host" + show VertexDomain = "vert" + show FragmentDomain = "frag" + +-- set to 0 for no limit +maxDepth = 16 + +data PrintState = PrintState { + depth :: Int, + traversedIds :: Set.Set ExprID, + buf :: String +} + +type Printer = State PrintState () + +runPrinter :: Printer -> String +runPrinter pr = buf $ execState pr + PrintState { depth = 0, traversedIds = Set.empty, buf = "" } + +printGLAst :: GLAst -> Printer +printGLAst (GLAstAtom id ty (Const _)) = + printNode id ty "const" +printGLAst (GLAstAtom id ty GenVar) = + printNode id ty "genVar" +printGLAst (GLAstAtom id ty (Uniform x)) = do + printNode id ty "uniform" + ifNotTraversed id $ + indented $ printGLAst $ toGLAst x +printGLAst (GLAstAtom id ty (GenericUniform label)) = do + printNode id ty ("user-def.: " ++ label) +printGLAst (GLAstAtom id ty (Inp _)) = + printNode id ty "inp" +printGLAst (GLAstAtom id ty (Frag _ x)) = do + printNode id ty "frag" + ifNotTraversed id $ + indented $ printGLAst $ toGLAst x +printGLAst (GLAstAtom id ty (IOFloat _)) = + printNode id ty "ioFloat" +printGLAst (GLAstAtom id ty (IODouble _)) = + printNode id ty "ioDouble" +printGLAst (GLAstAtom id ty (IOInt _)) = + printNode id ty "ioInt" +printGLAst (GLAstAtom id ty (IOUInt _)) = + printNode id ty "ioUInt" +printGLAst (GLAstAtom id ty (IOBool _)) = + printNode id ty "ioBool" +printGLAst (GLAstAtom id ty (IOPrec x0 x)) = do + printNode id ty "ioPrec" + ifNotTraversed id $ do + indented $ printGLAst $ toGLAst x0 + indented $ printGLAst $ toGLAst x +printGLAst (GLAstAtom id ty _) = + printNode id ty "glLift" +printGLAst (GLAstFunc id ty r params) = do + printNode id ty "glFunc" + ifNotTraversed id $ do + indented $ printGLAst r + indented $ mapM_ printGLAst params +printGLAst (GLAstFuncApp id ty fn args) = do + printNode id ty "glFunc app" + ifNotTraversed id $ do + indented $ printGLAst fn + indented $ mapM_ printGLAst args +printGLAst (GLAstExpr id ty op xs) = do + printNode id ty op + ifNotTraversed id $ + indented $ mapM_ printGLAst xs + +printNode :: ExprID -> GLTypeInfo -> String -> Printer +printNode id ty str = do + printLine $ str ++ " " ++ idLabel id ++ " : " ++ + show (shaderType ty) ++ " " ++ exprType ty + +printStr :: String -> Printer +printStr s = do + depth <- gets depth + modify (\ps -> ps { buf = buf ps ++ replicate (2 * depth) ' ' ++ s }) + +printLine :: String -> Printer +printLine = printStr . (++ "\n") + +indented :: Printer -> Printer +indented printer = do + d <- gets depth + if maxDepth > 0 && d > maxDepth then printLine " ..." else do + modify (\ps -> ps { depth = depth ps + 1 }) + printer + modify (\ps -> ps { depth = depth ps - 1 }) + +ifNotTraversed :: ExprID -> Printer -> Printer +ifNotTraversed id printAction = do + ids <- gets traversedIds + if id `elem` ids then + printLine " ..." + else do + modify (\ps -> ps { traversedIds = Set.insert id (traversedIds ps) }) + printAction diff --git a/src/Graphics/HaGL/Shader.hs b/src/Graphics/HaGL/Shader.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Shader.hs @@ -0,0 +1,135 @@ +module Graphics.HaGL.Shader ( + Shader(..), + ShaderFn(..), + ShaderParam(..), + ShaderDecl(..), + ShaderStmt(..), + ShaderExpr(..), + VarName, + addFn, + addDecl, + addStmt +) where + +import Data.Char (isAlpha) +import Data.List (intercalate) + +import Graphics.HaGL.GLType + + +data Shader = Shader [ShaderFn] [ShaderDecl] [ShaderStmt] + +data ShaderFn = + ShaderFn FnName ExprType [ShaderParam] + [ShaderStmt] ShaderExpr | + ShaderLoopFn FnName ExprType [ShaderParam] + ShaderExpr ShaderExpr [ShaderStmt] [ShaderStmt] [ShaderStmt] + +data ShaderParam = + ShaderParam VarName ExprType + +data ShaderDecl = + UniformDecl VarName ExprType | + InpDecl TypeQual VarName ExprType | + OutDecl TypeQual VarName ExprType + +data ShaderStmt = + VarAsmt VarName ShaderExpr | + VarDecl VarName ExprType | + VarDeclAsmt VarName ExprType ShaderExpr | + DiscardStmt ShaderExpr + +data ShaderExpr where + ShaderConst :: GLType t => t -> ShaderExpr + ShaderVarRef :: VarName -> ShaderExpr + ShaderExpr :: String -> [ShaderExpr] -> ShaderExpr + +type TypeQual = String +type ExprType = String +type FnName = String +type VarName = String + +instance Show Shader where + show (Shader fns decls stmts) = + "#version 430 core\n\n" ++ + endWith "\n" (concatMap (\s -> show s ++ "\n") decls) ++ + concatMap (\s -> show s ++ "\n\n") fns ++ + "void main() {\n" ++ + concatMap (\s -> " " ++ show s ++ "\n") stmts ++ + "}\n" + +instance Show ShaderFn where + show (ShaderFn name retType params stmts ret) = + retType ++ " " ++ name ++ "(" ++ + intercalate ", " (map show params) ++ ") {\n" ++ + concatMap (\s -> " " ++ show s ++ "\n") stmts ++ + " return " ++ show ret ++ ";" ++ + "\n}" + show (ShaderLoopFn name retType params cond ret condStmts retStmts updateStmts) = + retType ++ " " ++ name ++ "(" ++ + intercalate ", " (map show params) ++ ") {\n" ++ + " while (true) {\n" ++ + concatMap (\s -> " " ++ show s ++ "\n") condStmts ++ + " if (" ++ show cond ++ ") {\n" ++ + concatMap (\s -> " " ++ show s ++ "\n") retStmts ++ + " return " ++ show ret ++ ";\n" ++ + " }\n" ++ + concatMap (\s -> " " ++ show s ++ "\n") updateStmts ++ + " }\n}" + +instance Show ShaderParam where + show (ShaderParam name exprType) = + exprType ++ " " ++ name + +instance Show ShaderDecl where + show (UniformDecl varName exprType) = + "uniform " ++ exprType ++ " " ++ varName ++ ";" + show (InpDecl qual varName exprType) = + endWith " " qual ++ "in " ++ exprType ++ " " ++ varName ++ ";" + show (OutDecl qual varName exprType) = + endWith " " qual ++ "out " ++ exprType ++ " " ++ varName ++ ";" + +instance Show ShaderStmt where + show (VarAsmt varName expr) = + varName ++ " = " ++ show expr ++ ";" + show (VarDecl varName exprType) = + exprType ++ " " ++ varName ++ ";" + show (VarDeclAsmt varName exprType expr) = + exprType ++ " " ++ varName ++ " = " ++ show expr ++ ";" + show (DiscardStmt cond) = + "if (" ++ show cond ++ ") discard;" + +instance Show ShaderExpr where + show (ShaderConst c) = showGlslVal c + show (ShaderVarRef varName) = varName + show (ShaderExpr funcName xs) + | isAlpha (head funcName) = + funcName ++ "(" ++ intercalate ", " (map show xs) ++ ")" + | head funcName == '.' = showCompSel funcName xs + | funcName == "[]" = showSubscript xs + | head funcName == '[' = showMatCol xs funcName + | funcName == "?:" = showTernCond xs + | otherwise = showInfix funcName xs + where + showCompSel comp [x] = show x ++ comp + showSubscript [arr, i] = show arr ++ "[" ++ show i ++ "]" + showMatCol [x] col = show x ++ col + showTernCond [x, y, z] = show x ++ " ? " ++ show y ++ " : " ++ show z + showInfix op [x] = op ++ show x + showInfix op xs = intercalate (" " ++ op ++ " ") (map show xs) + +endWith :: String -> String -> String +endWith _ "" = "" +endWith sep s = s ++ sep + +addFn :: ShaderFn -> Shader -> Shader +addFn fn (Shader fns decls stmts) = + Shader (fns ++ [fn]) decls stmts + +addDecl :: ShaderDecl -> Shader -> Shader +addDecl decl (Shader fns decls stmts) = + Shader fns (decls ++ [decl]) stmts + +addStmt :: ShaderStmt -> Shader -> Shader +addStmt stmt (Shader fns decls stmts) = + Shader fns decls (stmts ++ [stmt]) diff --git a/src/Graphics/HaGL/TH/HaGL.hs b/src/Graphics/HaGL/TH/HaGL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/TH/HaGL.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.HaGL.TH.HaGL ( + gen2DCoordDecls, + gen3DCoordDecls +) where + +import Language.Haskell.TH +import Data.List (delete) + + +choose :: Eq a => Int -> [a] -> [[a]] +choose 0 _ = [[]] +choose n xs = do + x <- xs + ys <- choose (n-1) (delete x xs) + return $ x:ys + +coordCon "x" = "CoordX" +coordCon "y" = "CoordY" +coordCon "z" = "CoordZ" +coordCon "w" = "CoordW" + +-- e.g.: xy_ v = mkExpr GLGenExpr (OpCoordMulti (CoordX `CoordCons` (CoordY `CoordCons` CoordNil)) v) +gen2DCoordDecls :: Q [Dec] +gen2DCoordDecls = return $ fmap gen $ choose 2 ["x", "y", "z", "w"] where + gen coords@[x, y] = + FunD + (mkName $ concat coords ++ "_") + [Clause + [VarP $ mkName "v"] + (NormalB + (AppE + (AppE + (VarE $ mkName "mkExpr") + (ConE $ mkName "GLGenExpr")) + (AppE + (AppE + (ConE $ mkName "OpCoordMulti") + (InfixE + (Just (ConE $ mkName $ coordCon x)) + (ConE $ mkName "CoordCons") + (Just + (InfixE + (Just (ConE $ mkName $ coordCon y)) + (ConE $ mkName "CoordCons") + (Just (ConE $ mkName "CoordNil")))))) + (VarE $ mkName "v")))) + []] + +-- e.g.: xyz_ v = mkExpr GLGenExpr (OpCoordMulti (CoordX `CoordCons` (CoordY `CoordCons` (CoordZ `CoordCons` CoordNil))) v) +gen3DCoordDecls :: Q [Dec] +gen3DCoordDecls = return $ fmap gen $ choose 3 ["x", "y", "z", "w"] where + gen coords@[x, y, z] = + FunD + (mkName $ concat coords ++ "_") + [Clause + [VarP $ mkName "v"] + (NormalB + (AppE + (AppE + (VarE $ mkName "mkExpr") + (ConE $ mkName "GLGenExpr")) + (AppE + (AppE + (ConE $ mkName "OpCoordMulti") + (InfixE + (Just (ConE $ mkName $ coordCon x)) + (ConE $ mkName "CoordCons") + (Just + (InfixE + (Just (ConE $ mkName $ coordCon y)) + (ConE $ mkName "CoordCons") + (Just + (InfixE + (Just (ConE $ mkName $ coordCon z)) + (ConE $ mkName "CoordCons") + (Just (ConE $ mkName "CoordNil")))))))) + (VarE $ mkName "v")))) + []] diff --git a/src/Graphics/HaGL/Util.hs b/src/Graphics/HaGL/Util.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Util.hs @@ -0,0 +1,10 @@ +module Graphics.HaGL.Util ( + warn +) where + +import System.IO.Unsafe (unsafePerformIO) + +warn :: String -> a -> a +warn msg res = unsafePerformIO $ do + putStrLn msg + return res diff --git a/src/Graphics/HaGL/Util/DepMap.hs b/src/Graphics/HaGL/Util/DepMap.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Util/DepMap.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE RankNTypes #-} + +module Graphics.HaGL.Util.DepMap ( + GenHashable(..), + DepMap, + Graphics.HaGL.Util.DepMap.empty, + Graphics.HaGL.Util.DepMap.insert, + Graphics.HaGL.Util.DepMap.lookup, + Graphics.HaGL.Util.DepMap.mapWithKey, + Graphics.HaGL.Util.DepMap.traverseWithKey) +where + +import Data.Word (Word64) +import Data.Hashable (Hashable(..)) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.HashMap.Strict as HashMap + + +type Hash = Word64 + +class GenHashable k where + genHash :: k t -> Hash + + +data DepMap :: (* -> *) -> (* -> *) -> * where + DepMap :: GenHashable k => HashMap.HashMap (DMK k) (DMV v) -> DepMap k v + +data DMK k where + DMK :: GenHashable k => k t -> DMK k + +instance Eq (DMK k) where + (DMK key1) == (DMK key2) = genHash key1 == genHash key2 + +instance Hashable (DMK k) where + hashWithSalt salt (DMK key) = hashWithSalt salt $ genHash key + +data DMV v where + DMV :: v t -> DMV v + + +empty :: GenHashable k => DepMap k v +empty = DepMap (HashMap.empty :: HashMap.HashMap (DMK k) (DMV v)) + +insert :: GenHashable k => k t -> v t -> DepMap k v -> DepMap k v +insert key val (DepMap hm) = DepMap $ HashMap.insert (DMK key) (DMV val) hm + +lookup :: GenHashable k => k t -> DepMap k v -> Maybe (v t) +lookup key (DepMap hm) = HashMap.lookup (DMK key) hm >>= + \(DMV val) -> return $ unsafeCoerce val + +mapWithKey :: (forall t. k t -> v1 t -> v2 t) -> DepMap k v1 -> DepMap k v2 +mapWithKey f (DepMap hm) = DepMap hm' where + hm' = HashMap.mapWithKey (\(DMK k) (DMV v) -> DMV (f k $ unsafeCoerce v)) hm + +traverseWithKey :: Applicative a => (forall t. k t -> v1 t -> a (v2 t)) -> DepMap k v1 -> a (DepMap k v2) +traverseWithKey f (DepMap hm) = DepMap <$> hm' where + hm' = HashMap.traverseWithKey (\(DMK k) (DMV v) -> DMV <$> f k (unsafeCoerce v)) hm + +{-data Expr t where + IntExpr :: Int -> Expr Int + BoolExpr :: Bool -> Expr Bool + +instance GenHashable Expr where + genHash (IntExpr x) = x + genHash (BoolExpr False) = 0 + genHash (BoolExpr True) = 1 + +myMap :: DepMap Expr Identity +myMap = insert (IntExpr 0) 0 $ insert (BoolExpr True) (Identity True) $ empty-} diff --git a/src/Graphics/HaGL/Util/Types.hs b/src/Graphics/HaGL/Util/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/HaGL/Util/Types.hs @@ -0,0 +1,27 @@ +module Graphics.HaGL.Util.Types ( + Max, + Min, + FinList(..), + flToList +) where + +import GHC.TypeNats + +-- pilfered from base-4.16.0.0 (Data.Type.Ord) + +type family OrdCond (o :: Ordering) (lt :: Nat) (eq :: Nat) (gt :: Nat) where + OrdCond 'LT lt eq gt = lt + OrdCond 'EQ lt eq gt = eq + OrdCond 'GT lt eq gt = gt + +type Max (m :: Nat) (n :: Nat) = OrdCond (CmpNat m n) n n m + +type Min (m :: Nat) (n :: Nat) = OrdCond (CmpNat m n) m m n + +data FinList (n :: Nat) t where + FLNil :: FinList 0 t + FLCons :: t -> FinList n t -> FinList (n + 1) t + +flToList :: FinList n t -> [t] +flToList FLNil = [] +flToList (FLCons x xs) = x : flToList xs diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,1213 @@ +{-# LANGUAGE NumericUnderscores #-} + +import Prelude hiding (all, min, max, length, floor) +import Test.HUnit +import Control.Monad (when) +import Control.Exception (Exception, try) +import System.Exit +import System.Directory (removeFile, createDirectoryIfMissing) +import qualified Data.ByteString as BS +import qualified Data.List as List +import qualified Graphics.UI.GLUT as GLUT + +import Graphics.HaGL hiding (not, abs, sin, cos, sqrt) +import Graphics.HaGL.Internal + + +-- Test setup + +data ExprTest d where + ExprTest :: String -> GLExpr d Bool -> ExprTest d + +data ExprExceptionTest = + ExprExceptionTest String GLExprException (GLExpr FragmentDomain Bool) + +data ObjTest = + ObjTest String [GLObj] + +data ObjExceptionTest where + ObjExceptionTest :: (Exception e, Eq e) => String -> e -> [GLObj] -> ObjExceptionTest + +-- verify that 'expr' evaluates to True +mkHostTest :: ExprTest HostDomain -> Test +mkHostTest (ExprTest label expr) = + TestLabel (label ++ "_host") $ TestCase $ do + let ioev = error "Host tests do not support evaluation of I/O GLExprs" + res <- hostEval ioev expr + assertBool ("Failed to evaluate to true on host: " ++ label) res + +-- verify that setting color to 'expr' produces a white image +mkShaderTest :: ExprTest FragmentDomain -> Test +mkShaderTest (ExprTest label expr) = + mkObjTest $ ObjTest label $ return $ fromImage $ \_ -> cast expr .# 1 + +-- verify that trying to set color to 'expr' throws the expected exception +mkShaderExceptionTest :: ExprExceptionTest -> Test +mkShaderExceptionTest (ExprExceptionTest label ex expr) = + mkObjExceptionTest $ ObjExceptionTest label ex $ return $ fromImage $ \_ -> cast expr .# 1 + +-- verify that drawing the given objects produces a white image +mkObjTest :: ObjTest -> Test +mkObjTest (ObjTest label objs) = + TestLabel (label ++ "_shader") $ TestCase $ + runObjs False label objs >>= + assertBool ("Failed to obtain a true value in shader: " ++ label) + +-- verify that drawing the given objects throws the expected exception +mkObjExceptionTest :: ObjExceptionTest -> Test +mkObjExceptionTest (ObjExceptionTest label ex objs) = + TestLabel label $ TestCase $ do + res <- try $ runObjs False label objs + case res of + Left ex' | ex' == ex -> return () + _ -> assertFailure $ "Expected exception: " ++ show ex + +fromImage :: (FragExpr (Vec 2 Float) -> FragExpr (Vec 4 Float)) -> GLObj +fromImage im = triangleStrip { position = pos $- vec2 0 1, color = color } where + pos = vert + [vec2 (-1) (-1), + vec2 (-1) 1, + vec2 1 (-1), + vec2 1 1] + color = im (frag pos) + +runObjs :: Bool -> String -> [GLObj] -> IO Bool +runObjs alwaysSave label objs = do + mapM_ (dumpObj label) (zip [0..] objs) + let captureDst = "output/test/test_" ++ label + -- TODO: use the same GLUT window instead of creating a new one every time + GLUT.exit -- make sure GLUT has cleaned up, if a previous test errored + -- TODO: calling drawGlut directly is inefficient + -- as it generates shader code a second time + drawGlutCustom (defaultGlutOptions { + runMode = GlutCaptureAndExit captureDst }) objs + dat <- BS.readFile (captureDst ++ ".ppm") + let success = BS.all (== 0xff) . BS.drop 16 $ dat + when (not alwaysSave && success) $ removeFile (captureDst ++ ".ppm") + return success + +dumpObj label (i, obj) = do + let astDump = printGLExpr (position obj) ++ "\n" ++ printGLExpr (color obj) + glsl = dumpGlsl obj + objLabel = label ++ if i == 0 then "" else show i + writeFile ("output/test/test_" ++ objLabel ++ ".dump") astDump + writeFile ("output/test/test_" ++ objLabel ++ ".glsl") glsl + +-- TODO: make these definitions part of GLType & use a smarter error estimate +almostEqual x y = abs (x - y) .<= 1e-5 +almostVecEqual x y = all $ lessThanEqual (abs (x - y)) 1e-5 +almostMatPx2Equal m1 m2 = + almostVecEqual (col0 m1) (col0 m2) .&& + almostVecEqual (col1 m1) (col1 m2) +almostMatPx3Equal m1 m2 = + almostVecEqual (col0 m1) (col0 m2) .&& + almostVecEqual (col1 m1) (col1 m2) .&& + almostVecEqual (col2 m1) (col2 m2) +almostMatPx4Equal m1 m2 = + almostVecEqual (col0 m1) (col0 m2) .&& + almostVecEqual (col1 m1) (col1 m2) .&& + almostVecEqual (col2 m1) (col2 m2) .&& + almostVecEqual (col3 m1) (col3 m2) + + +-- Tests + +genericTests :: [ExprTest d] +genericTests = [ + trivialTest, + vec2Test, + vec3Test, + vec4Test, + mat2Test, + mat3Test, + mat4Test, + mat2x3Test, + mat2x3Test, + mat3x2Test, + mat3x4Test, + mat4x2Test, + mat4x3Test, + arrayTest, + rawConstrTest, + glLiftTest, + castTest, + matCastTest, + numFloatTest, + numIntTest, + numUIntTest, + numVecTest, + numIntVecTest, + numUIntVecTest, + fractionalFloatTest, + fractionalVecTest, + floatingFloatTest, + floatingVecTest, + numOpsIntTest, + numOpsUIntTest, + numOpsVecTest, + numOpsIntVecTest, + modulusTest, + scalarMultTest, + matMultTest, + booleanExprsTest, + bitwiseExprsTest, + lengthTest, + distanceTest, + dotTest, + crossTest, + normalizeTest, + faceforwardTest, + reflectTest, + refractTest, + vecArithmeticTest, + glFuncTrivialTest, + glFuncMultipleTest, + glFuncNestedTest, + glFuncFactTest, + glFuncFibTest, + glFuncCollatzTest, + glFuncMandelbrotTest, + glFuncNestedCondTest, + uniformFloatTest, + uniformIntTest, + uniformUIntTest, + uniformBoolTest, + uniformVec2FloatTest, + uniformVec3FloatTest, + uniformVec4FloatTest, + uniformVec2IntTest, + uniformVec3IntTest, + uniformVec4IntTest, + uniformVec2UIntTest, + uniformVec3UIntTest, + uniformVec4UIntTest, + uniformVec2BoolTest, + uniformVec3BoolTest, + uniformVec4BoolTest, + uniformMat2Test, + uniformMat3Test, + uniformMat4Test, + uniformMat2x3Test, + uniformMat2x4Test, + uniformMat3x2Test, + uniformMat3x4Test, + uniformMat4x2Test, + uniformMat4x3Test, + uniformFloatArrayTest, + uniformVec2ArrayTest, + uniformVec3ArrayTest, + uniformVec4ArrayTest, + uniformIntArrayTest, + uniformIntVec2ArrayTest, + uniformIntVec3ArrayTest, + uniformIntVec4ArrayTest, + uniformUIntArrayTest, + uniformUIntVec2ArrayTest, + uniformUIntVec3ArrayTest, + uniformUIntVec4ArrayTest, + uniformBoolArrayTest, + uniformBoolVec2ArrayTest, + uniformBoolVec3ArrayTest, + uniformBoolVec4ArrayTest, + exponentialExprTreeTest, + iteratedGlFuncTest + ] + +hostTests :: [ExprTest HostDomain] +hostTests = [ + + ] + +shaderTests :: [ExprTest FragmentDomain] +shaderTests = [ + inputFloatTest, + inputIntTest, + inputUIntTest, + inputVec2Test, + inputVec3Test, + inputVec4Test, + inputIntVec2Test, + inputIntVec3Test, + inputIntVec4Test, + inputUIntVec2Test, + inputUIntVec3Test, + inputUIntVec4Test, + interpTest, + precTrivialTest, + precNestedTest, + precIntegrateTest, + --precTimeTest, + precSequenceTest, + precFiboTest + ] + +shaderExceptionTests :: [ExprExceptionTest] +shaderExceptionTests = [ + glLiftIllegalTest, + glFuncFactIllegalTest, + glFuncCollatzIllegalTest, + glFuncNestedCondIllegalTest, + glFuncNameCaptureIllegalTest, + glFuncRecIllegalTest, + glFuncMutRecIllegalTest + ] + +objTests :: [ObjTest] +objTests = [ + trivialImageTest, + passAroundTest, + multiObjOverlapTest, + multiObjComplementTest, + multiObjDiscardTest, + multiObjSharedExprsTest + --multiObjSharedHostExprsTest, + --multiObjSharedPrecsTest + ] + +objExceptionTests :: [ObjExceptionTest] +objExceptionTests = [ + noInputVarsTest, + emptyInputVarTest, + mismatchedInputVarsTest + ] + + +trivialTest = ExprTest "trivial" true + + +-- Vector and matrix (de-)construction and indexing + +vec2Test = ExprTest "vec2" $ + let v = vec2 1 2 :: GLExpr d (Vec 2 Int) + (decon -> (x, y)) = v + in v .== 1 + vec2 0 1 .&& + v .== 0 + 1 .# v + 0 .&& + v .== vec2 1 0 + 2 .# vec2 0 1 .&& + v .== vec2 (x_ v) (y_ v) .&& + v .== vec2 x y .&& + v .== (yx_ . yx_) v .&& + v ./= (yx_ . xy_) v + +vec3Test = ExprTest "vec3" $ + let v = vec3 1 2 3 :: GLExpr d (Vec 3 Int) + (decon -> (x, y, z)) = v + in v .== pre 1 (vec2 2 3) .&& + v .== app (vec2 1 2) 3 .&& + v .== 1 + vec3 0 1 2 .&& + v .== 0 + 1.# v + 0 .&& + v .== vec3 1 0 0 + 2 .# vec3 0 1 0 + 3 .# vec3 0 0 1 .&& + v .== vec3 (x_ v) (y_ v) (z_ v) .&& + v .== vec3 x y z .&& + v .== pre x (vec2 y z) .&& + v .== app (vec2 x y) z .&& + v .== (zyx_ . zyx_) v .&& + v ./= (zyx_ . xyz_) v + +vec4Test = ExprTest "vec4" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Int) + (decon -> (x, y, z, w)) = v + in v .== vec2 1 2 $- vec2 3 4 .&& + v .== pre 1 (vec3 2 3 4) .&& + v .== app (vec3 1 2 3) 4 .&& + v .== 1 + vec4 0 1 2 3 .&& + v .== 0 + 1 .# v + 0 .&& + v .== vec4 1 0 0 0 + 2 .# vec4 0 1 0 0 + + 3 .# vec4 0 0 1 0 + 4 .# vec4 0 0 0 1 .&& + v .== vec4 (x_ v) (y_ v) (z_ v) (w_ v) .&& + v .== vec4 x y z w .&& + v .== pre x (vec3 y z w) .&& + v .== app (vec3 x y z) w .&& + v .== pre x ((zyx_ . wzy_) v) .&& + v .== app ((xyz_ . xyz_) v) w + +mat2Test = ExprTest "mat2" $ + let m = mat2 (vec2 1 2) (vec2 3 4) :: GLExpr d (Mat 2 2 Float) + (decon -> (c0, c1)) = m + in almostMatPx2Equal m (mat2 (col0 m) (col1 m)) .&& + almostMatPx2Equal m (mat2 c0 c1) + +mat3Test = ExprTest "mat3" $ + let m = mat3 (vec3 1 2 3) (vec3 4 5 6) (vec3 7 8 9) :: GLExpr d (Mat 3 3 Float) + (decon -> (c0, c1, c2)) = m + in almostMatPx3Equal m (mat3 (col0 m) (col1 m) (col2 m)) .&& + almostMatPx3Equal m (mat3 c0 c1 c2) {-.&& + almostMatPx3Equal m ((mat3x2 c0 c1) $| c2) .&& + almostMatPx3Equal m (c0 $| (mat3x2 c1 c2))-} + +mat4Test = ExprTest "mat4" $ + let m = mat4 (vec4 1 2 3 4) (vec4 5 6 7 8) + (vec4 9 10 11 12) (vec4 13 14 15 16) :: GLExpr d (Mat 4 4 Float) + (decon -> (c0, c1, c2, c3)) = m + in almostMatPx4Equal m (mat4 (col0 m) (col1 m) (col2 m) (col3 m)) .&& + almostMatPx4Equal m (mat4 c0 c1 c2 c3) {-.&& + almostMatPx4Equal m ((mat4x3 c0 c1 c2) $| c3) .&& + almostMatPx4Equal m ((mat4x2 c0 c1) $| (mat4x2 c2 c3)) .&& + almostMatPx4Equal m (c0 $| (mat4x3 c1 c2 c3))-} + +mat2x3Test = ExprTest "mat2x3" $ + let m = mat2x3 (vec2 1 2) (vec2 3 4) (vec2 5 6) :: GLExpr d (Mat 2 3 Float) + (decon -> (c0, c1, c2)) = m + in almostMatPx3Equal m (mat2x3 (col0 m) (col1 m) (col2 m)) .&& + almostMatPx3Equal m (mat2x3 c0 c1 c2) + +mat2x4Test = ExprTest "mat2x4" $ + let m = mat2x4 (vec2 1 2) (vec2 3 4) (vec2 5 6) (vec2 7 8) :: GLExpr d (Mat 2 4 Float) + (decon -> (c0, c1, c2, c3)) = m + in almostMatPx4Equal m (mat2x4 (col0 m) (col1 m) (col2 m) (col3 m)) .&& + almostMatPx4Equal m (mat2x4 c0 c1 c2 c3) + +mat3x2Test = ExprTest "mat3x2" $ + let m = mat3x2 (vec3 1 2 3) (vec3 4 5 6) :: GLExpr d (Mat 3 2 Float) + (decon -> (c0, c1)) = m + in almostMatPx2Equal m (mat3x2 (col0 m) (col1 m)) .&& + almostMatPx2Equal m (mat3x2 c0 c1) + +mat3x4Test = ExprTest "mat3x4" $ + let m = mat3x4 (vec3 1 2 3) (vec3 4 5 6) (vec3 7 8 9) (vec3 10 11 12) :: GLExpr d (Mat 3 4 Float) + (decon -> (c0, c1, c2, c3)) = m + in almostMatPx4Equal m (mat3x4 (col0 m) (col1 m) (col2 m) (col3 m)) .&& + almostMatPx4Equal m (mat3x4 c0 c1 c2 c3) + +mat4x2Test = ExprTest "mat4x2" $ + let m = mat4x2 (vec4 1 2 3 4) (vec4 5 6 7 9) :: GLExpr d (Mat 4 2 Float) + (decon -> (c0, c1)) = m + in almostMatPx2Equal m (mat4x2 (col0 m) (col1 m)) .&& + almostMatPx2Equal m (mat4x2 c0 c1) + +mat4x3Test = ExprTest "mat4x3" $ + let m = mat4x3 (vec4 1 2 3 4) (vec4 5 6 7 8) (vec4 9 10 11 12) :: GLExpr d (Mat 4 3 Float) + (decon -> (c0, c1, c2)) = m + in almostMatPx3Equal m (mat4x3 (col0 m) (col1 m) (col2 m)) .&& + almostMatPx3Equal m (mat4x3 c0 c1 c2) + +-- Arrays + +arrayTest = ExprTest "array" $ + let a1 = uniform $ array [cnst (2 * i) | i <- [0..999]] :: GLExpr d [Int] + a2 = uniform $ array [vec2 1 1, vec2 2 2] :: GLExpr d [Vec 2 Int] + in a1 .! 0 .== 0 .&& a1 .! 10 .== 2 * 10 .&& + a1 .! 999 .== 2 * 999 .&& + a1 .! (uniform 1) .== 2 .&& + a2 .! 0 + a2 .! 0 .== a2 .! 1 + + +-- Lifts from raw types + +rawConstrTest = ExprTest "raw_constr" $ + let m0 = mat3 (vec3 1 4 7) (vec3 2 5 8) (vec3 3 6 9) + m1 = uniform $ glLift0 $ fromList [1, 2, 3, 4, 5, 6, 7, 8, 9] :: GLExpr d (Mat 3 3 Float) + m2 = uniform $ glLift0 $ fromMapping (\(i, j) -> fromIntegral $ 3 * i + j + 1) :: GLExpr d (Mat 3 3 Float) + a0 = uniform $ array [1,2,3,4] :: GLExpr d [Int] + a1 = uniform $ glLift0 [1,2,3,4] :: GLExpr d [Int] + a2 = uniform $ glLift0 [4,3,2,1] :: GLExpr d [Int] + in almostMatPx3Equal m0 m1 .&& almostMatPx3Equal m0 m2 .&& almostMatPx3Equal m1 m2 .&& + a0 .== a1 .&& a0 ./= a2 + +glLiftTest = ExprTest "glLift" $ + let f1 = glLift1 $ \x -> x + 1 + x1 = 1 :: GLExpr HostDomain Int + y1 = 2 :: GLExpr HostDomain Int + f2 = glLift1 $ \x -> [x, x] + x2 = 1 :: GLExpr HostDomain (Vec 2 Int) + a2 = uniform $ array [x2, x2] + f3 = glLift2 $ \x y -> [x, y, x + y] + x3 = 1 :: GLExpr HostDomain Int + y3 = 2 :: GLExpr HostDomain Int + a3 = uniform $ array [1,2,3] :: GLExpr d [Int] + in uniform (f1 x1) .== 2 .&& uniform (f1 y1) .== 3 .&& + uniform (f2 x2) .== a2 .&& uniform (f3 x3 y3) .== a3 + +glLiftIllegalTest = ExprExceptionTest "glLift_illegal" UnknownArraySize $ + let f = glLift1 $ \n -> replicate n 0 + a = uniform $ array [0, 0, 0] :: GLExpr d [Int] + in uniform (f 3) .== a + + +-- Type conversion + +castTest = ExprTest "cast" $ + cast (2 :: GLExpr d Int) .== true .&& + cast ((-1) :: GLExpr d Int) .== true .&& + cast (0 :: GLExpr d Int) .== false .&& + cast (2 :: GLExpr d UInt) .== true .&& + cast (0 :: GLExpr d UInt) .== false .&& + cast (1.7 :: GLExpr d Float) .== true .&& + cast (0.7 :: GLExpr d Float) .== true .&& + cast true .== (1 :: GLExpr d Int) .&& + cast false .== (0 :: GLExpr d Int) .&& + cast (1 :: GLExpr d UInt) .== (1 :: GLExpr d Int) .&& + cast (1.7 :: GLExpr d Float) .== (1 :: GLExpr d Int) .&& + cast ((-1.7) :: GLExpr d Float) .== ((-1) :: GLExpr d Int) .&& + almostEqual (cast true) (1 :: GLExpr d Float) .&& + almostEqual (cast false) (0 :: GLExpr d Float) .&& + almostEqual (cast (1 :: GLExpr d Int)) (1 :: GLExpr d Float) .&& + almostEqual (cast (1 :: GLExpr d UInt)) (1 :: GLExpr d Float) + +matCastTest = ExprTest "matCast" $ + matCast (vec3 2 (-1) 0 :: GLExpr d (Vec 3 Int)) .== vec3 true true false .&& + almostVecEqual (matCast $ vec2 true false) (vec2 1 0 :: GLExpr d (Vec 2 Float)) + + +-- Num, Fractional, Floating + +-- TODO: use QuickCheck to verify properties like these, wherever possible +checkNumProperties eq x y z = + ((x + y) + z) `eq` (x + (y + z)) .&& + (x + y) `eq` (y + x) .&& + (x + fromInteger 0) `eq` x .&& + (x + negate x) `eq` (fromInteger 0) .&& + ((x * y) * z) `eq` (x * (y * z)) .&& + (x * fromInteger 1) `eq` x .&& + (fromInteger 1 * x) `eq` x .&& + (x * (y + z)) `eq` ((x * y) + (x * z)) .&& + ((y + z) * x) `eq` ((y * x) + (z * x)) .&& + (abs x * signum x) `eq` x + +numFloatTest = ExprTest "num_float" $ + checkNumProperties almostEqual (-1.234567 :: GLExpr d Float) 1.789012 (-1.567890) + +numIntTest = ExprTest "num_int" $ + checkNumProperties (.==) (-1 :: GLExpr d Int) 7 (-5) + +numUIntTest = ExprTest "num_uint" $ + checkNumProperties (.==) (1 :: GLExpr d UInt) 7 5 + +numVecTest = ExprTest "num_vec" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in checkNumProperties almostVecEqual + (-1.234567 + v) (1.789012 + v) (-1.567890 + v) + +numIntVecTest = ExprTest "num_ivec" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Int) + in checkNumProperties (.==) v (7 + v) (-5 + v) + +numUIntVecTest = ExprTest "num_uvec" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Int) + in checkNumProperties (.==) v (7 + v) (5 + v) + +checkFractionalProperties eq x y z = + (x * recip x) `eq` (recip x * x) .&& + (x * recip x) `eq` (fromInteger 1) .&& + (x * recip x) `eq` (fromRational (toRational 1)) .&& + (x / y) `eq` (recip (y / x)) + +fractionalFloatTest = ExprTest "fractional_float" $ + checkFractionalProperties almostEqual (-1.234567 :: GLExpr d Float) 1.789012 (-1.567890) + +fractionalVecTest = ExprTest "fractional_vec" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in checkFractionalProperties almostVecEqual + (-1.234567 + v) (1.789012 + v) (-1.567890 + v) + +checkFloatingProperties eq x y z = + (Prelude.exp (x + y)) `eq` (Prelude.exp x * Prelude.exp y) .&& + (Prelude.exp (fromInteger 0)) `eq` (fromInteger 1) .&& + (Prelude.log (abs $ x * y)) `eq` (Prelude.log (abs x) + Prelude.log (abs y)) .&& + (Prelude.log (abs $ x / y)) `eq` (Prelude.log (abs x) - Prelude.log (abs y)) .&& + (Prelude.sqrt (x ** 2)) `eq` (Prelude.abs x) .&& + (x ** (-2)) `eq` recip (x ** 2) .&& + ((Prelude.sin x ** 2) + (Prelude.cos x ** 2)) `eq` (fromInteger 1) + +floatingFloatTest = ExprTest "floating_float" $ + checkFloatingProperties almostEqual (-1.234567 :: GLExpr d Float) 1.789012 (-1.567890) + +floatingVecTest = ExprTest "floating_vec" $ + let v = vec4 0.1 0.2 0.3 0.4 :: GLExpr d (Vec 4 Float) + in checkFloatingProperties almostVecEqual + (-1.234567 + v) (1.789012 + v) (-1.567890 + v) + + +-- Numeric operators + +checkNumericOps eq zero one x y z = + ((x + y) + z) `eq` (x + (y + z)) .&& + (x + y) `eq` (y + x) .&& + (x + zero) `eq` x .&& + (x + neg x) `eq` zero .&& + ((x * y) * z) `eq` (x * (y * z)) .&& + (x * one) `eq` x .&& + (one * x) `eq` x .&& + (x * (y + z)) `eq` ((x * y) + (x * z)) .&& + ((y + z) * x) `eq` ((y * x) + (z * x)) .&& + (x ./ x) `eq` one .&& + (x * y ./ x) `eq` y .&& + (x * y ./ y) `eq` x + +numOpsFloatTest = ExprTest "num_ops_float" $ + checkNumericOps almostEqual (0 :: GLExpr d Float) 1 (-1.234567) 1.789012 (-1.567890) + +numOpsIntTest = ExprTest "num_ops_int" $ + checkNumericOps (.==) (0 :: GLExpr d Int) 1 (-1) 7 (-5) + +numOpsUIntTest = ExprTest "num_ops_uint" $ + checkNumericOps (.==) (0 :: GLExpr d UInt) 1 1 7 5 + +numOpsVecTest = ExprTest "num_ops_vec" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in checkNumericOps almostVecEqual 0 1 + (-1.234567 + v) (1.789012 + v) (-1.567890 + v) + +numOpsIntVecTest = ExprTest "num_ops_ivec" $ + let v = vec4 1 2 3 4 :: GLExpr d (Vec 4 Int) + in checkNumericOps (.==) 0 1 + v (7 + v) (-5 + v) + +modulusTest = ExprTest "modulus" $ + vec4 10 100 101 200 .% (100 :: GLExpr d (Vec 4 Int)) .== vec4 10 0 1 0 .&& + (101 :: GLExpr d UInt) .% 100 .== 1 + +scalarMultTest = ExprTest "scalar_mult" $ + (2 :: GLExpr d Int) .# vec2 1 2 .== vec2 2 4 .&& + (2 :: GLExpr d Int) .# vec3 1 2 3 .== vec3 2 4 6 .&& + (2 :: GLExpr d Int) .# vec4 1 2 3 4.== vec4 2 4 6 8 .&& + ((2 :: GLExpr d Float) .# vec2 1 2) `almostVecEqual` vec2 2 4 .&& + ((2 :: GLExpr d Float) .# vec3 1 2 3) `almostVecEqual` vec3 2 4 6 .&& + ((2 :: GLExpr d Float) .# vec4 1 2 3 4) `almostVecEqual` vec4 2 4 6 8 .&& + ((2 :: GLExpr d Float) .# mat2x2 (vec2 0 1) (vec2 2 3)) `almostMatPx2Equal` + mat2x2 (vec2 0 2) (vec2 4 6) .&& + ((2 :: GLExpr d Float) .# mat2x3 (vec2 0 1) (vec2 2 3) (vec2 4 5)) `almostMatPx3Equal` + mat2x3 (vec2 0 2) (vec2 4 6) (vec2 8 10) .&& + ((2 :: GLExpr d Float) .# mat2x4 (vec2 0 1) (vec2 2 3) (vec2 4 5) (vec2 6 7)) `almostMatPx4Equal` + mat2x4 (vec2 0 2) (vec2 4 6) (vec2 8 10) (vec2 12 14) .&& + ((2 :: GLExpr d Float) .# mat3x2 (vec3 0 1 2) (vec3 3 4 5)) `almostMatPx2Equal` + mat3x2 (vec3 0 2 4) (vec3 6 8 10) .&& + ((2 :: GLExpr d Float) .# mat3x3 (vec3 0 1 2) (vec3 3 4 5) (vec3 6 7 8)) `almostMatPx3Equal` + mat3x3 (vec3 0 2 4) (vec3 6 8 10) (vec3 12 14 16) .&& + ((2 :: GLExpr d Float) .# mat3x4 (vec3 0 1 2) (vec3 3 4 5) (vec3 6 7 8) (vec3 9 10 11)) `almostMatPx4Equal` + mat3x4 (vec3 0 2 4) (vec3 6 8 10) (vec3 12 14 16) (vec3 18 20 22) .&& + ((2 :: GLExpr d Float) .# mat4x2 (vec4 0 1 2 3) (vec4 4 5 6 7)) `almostMatPx2Equal` + mat4x2 (vec4 0 2 4 6) (vec4 8 10 12 14) .&& + ((2 :: GLExpr d Float) .# mat4x3 (vec4 0 1 2 3) (vec4 4 5 6 7) (vec4 8 9 10 11)) `almostMatPx3Equal` + mat4x3 (vec4 0 2 4 6) (vec4 8 10 12 14) (vec4 16 18 20 22) .&& + ((2 :: GLExpr d Float) .# mat4x4 (vec4 0 1 2 3) (vec4 4 5 6 7) (vec4 8 9 10 11) (vec4 12 13 14 15)) `almostMatPx4Equal` + mat4x4 (vec4 0 2 4 6) (vec4 8 10 12 14) (vec4 16 18 20 22) (vec4 24 26 28 30) + +matMultTest = ExprTest "mat_mult" $ + let m2x2 = mat2x2 (vec2 0 1) (vec2 2 3) :: GLExpr d (Mat 2 2 Float) + m2x3 = mat2x3 (vec2 0 1) (vec2 2 3) (vec2 4 5) :: GLExpr d (Mat 2 3 Float) + m2x4 = mat2x4 (vec2 0 1) (vec2 2 3) (vec2 4 5) (vec2 6 7) :: GLExpr d (Mat 2 4 Float) + m3x2 = mat3x2 (vec3 0 1 2) (vec3 3 4 5) :: GLExpr d (Mat 3 2 Float) + m3x3 = mat3x3 (vec3 0 1 2) (vec3 3 4 5) (vec3 6 7 8) :: GLExpr d (Mat 3 3 Float) + m3x4 = mat3x4 (vec3 0 1 2) (vec3 3 4 5) (vec3 6 7 8) (vec3 9 10 11) :: GLExpr d (Mat 3 4 Float) + m4x2 = mat4x2 (vec4 0 1 2 3) (vec4 4 5 6 7) :: GLExpr d (Mat 4 2 Float) + m4x3 = mat4x3 (vec4 0 1 2 3) (vec4 4 5 6 7) (vec4 8 9 10 11) :: GLExpr d (Mat 4 3 Float) + m4x4 = mat4x4 (vec4 0 1 2 3) (vec4 4 5 6 7) (vec4 8 9 10 11) (vec4 12 13 14 15) :: GLExpr d (Mat 4 4 Float) + in (m2x2 .@ m2x2) `almostMatPx2Equal` mat2x2 (vec2 2 3) (vec2 6 11) .&& + (m2x4 .@ m4x3) `almostMatPx3Equal` mat2x3 (vec2 28 34) (vec2 76 98) (vec2 124 162) .&& + (m2x3 .@ m3x4) `almostMatPx4Equal` mat2x4 (vec2 10 13) (vec2 28 40) (vec2 46 67) (vec2 64 94) .&& + (m3x3 .@ m3x2) `almostMatPx2Equal` mat3x2 (vec3 15 18 21) (vec3 42 54 66) .&& + (m3x2 .@ m2x3) `almostMatPx3Equal` mat3x3 (vec3 3 4 5) (vec3 9 14 19) (vec3 15 24 33) .&& + (m3x4 .@ m4x4) `almostMatPx4Equal` mat3x4 (vec3 42 48 54) (vec3 114 136 158) (vec3 186 224 262) (vec3 258 312 366) .&& + (m4x4 .@ m4x2) `almostMatPx2Equal` mat4x2 (vec4 56 62 68 74) (vec4 152 174 196 218) .&& + (m4x3 .@ m3x3) `almostMatPx3Equal` mat4x3 (vec4 20 23 26 29) (vec4 56 68 80 92) (vec4 92 113 134 155) .&& + (m4x2 .@ m2x4) `almostMatPx4Equal` mat4x4 (vec4 4 5 6 7) (vec4 12 17 22 27) (vec4 20 29 38 47) (vec4 28 41 54 67) + + +-- Boolean and bitwise expressions + +booleanExprsTest = ExprTest "boolean_expressions" $ + (-1 :: GLExpr d Int) .< 0 .&& + (-1 :: GLExpr d Int) .<= 0 .&& + (-1 :: GLExpr d Int) .<= -1 .&& + (1 :: GLExpr d Int) .> 0 .&& + (1 :: GLExpr d Int) .>= 0 .&& + (1 :: GLExpr d Int) .>= 1 .&& + (1 :: GLExpr d Int) .== 1 .&& + (0 :: GLExpr d Int) ./= 1 .&& + (true .&& true) .== true .&& + (true .&& false) .== false .&& + (false .&& true) .== false .&& + (false .&& false) .== false .&& + (true .|| true) .== true .&& + (true .|| false) .== true .&& + (false .|| true) .== true .&& + (false .|| false) .== false .&& + (true .^^ true) .== false .&& + (true .^^ false) .== true .&& + (false .^^ true) .== true .&& + (false .^^ false) .== false .&& + nt true .== false .&& + nt false .== true .&& + cond true (2 :: GLExpr d Int) 1 .== 2 .&& + cond false (2 :: GLExpr d Int) 1 .== 1 + +bitwiseExprsTest = ExprTest "bitwise_expressions" $ + (((7 :: GLExpr d Int) .<< 3) .>> 3) .== 7 .&& + ((7 :: GLExpr d Int) .>> 3) .== 0 .&& + ((12 :: GLExpr d Int) .& 10) .== 8 .&& + ((12 :: GLExpr d Int) .| 10) .== 14 .&& + ((12 :: GLExpr d Int) .^ 10) .== 6 .&& + (compl . compl) (12345678 :: GLExpr d Int) .== 12345678 + + +-- Common math functions + + + +-- Geometric functions + +lengthTest = ExprTest "length" $ + almostEqual (length (vec3 2 (-3) 6 :: GLExpr d (Vec 3 Float))) 7 .&& + let v@(decon -> (x, y, z, w)) = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in almostEqual (length v) (sqrt (x * x + y * y + z * z + w * w)) + +distanceTest = ExprTest "distance" $ + let x = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + y = vec4 5 6 7 8 :: GLExpr d (Vec 4 Float) + in almostEqual (distance x y) (length (x - y)) + +dotTest = ExprTest "dot" $ + let theta = 0.1234 :: GLExpr d Float + x = vec2 (cos theta) (sin theta) :: GLExpr d (Vec 2 Float) + y = vec2 (cos $ theta + (pi / 2)) (sin $ theta + (pi / 2)) + z = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in almostEqual (dot x y) 0 .&& + almostEqual (dot z z) (length z * length z) + +crossTest = ExprTest "cross" $ + true + +normalizeTest = ExprTest "normalize" $ + let x = vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in almostVecEqual (normalize x) ((1 / length x) .# x) + +faceforwardTest = ExprTest "faceforward" $ + true + +reflectTest = ExprTest "reflect" $ + true + +refractTest = ExprTest "refract" $ + true + + +-- Matrix functions + + + +-- Vector relational functions + + + +-- General numerical tests + +vecArithmeticTest = ExprTest "vector_arithmetic" $ + 2 .# vec4 1 2 3 4 - 3 * vec4 1 2 3 4 .== - (vec4 1 2 3 4 :: GLExpr d (Vec 4 Int)) .&& + 1 .# abs (vec4 1 1 1 1) - abs (-1) .== (vec4 0 0 0 0 :: GLExpr d (Vec 4 Int)) + + +-- Custom function support via glFunc + +glFuncTrivialTest = ExprTest "glFunc_trivial" $ + let f = glFunc2 $ \x y -> x + y + x0 = 1 :: GLExpr d Int + x1 = 2 :: GLExpr d Int + in f x0 x1 .== 3 + +glFuncMultipleTest = ExprTest "glFunc_multiple" $ + let f1 :: GLExpr d Int -> GLExpr d Int + f1 = glFunc1 (3 *) + g1 :: GLExpr d Int -> GLExpr d Int + g1 = glFunc1 (2 *) + f2 :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + f2 = glFunc2 $ \x y -> 2 * x * y + g2 :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + g2 = glFunc2 $ \x y -> 3 * x * y + -- in the shader case, this should generate four non-main functions + in f1 1 .> g1 1 .&& f1 1 .< g1 2 .&& f2 2 1 .> g2 1 1 + +glFuncNestedTest = ExprTest "glFunc_nested" $ + let f = glFunc2 $ \x y -> 2 * x + y + g = glFunc3 $ \x y z -> z * f x y * (- f x y) * f y x + x0 = 1 :: GLExpr d Int + y0 = 2 :: GLExpr d Int + z0 = 2 :: GLExpr d Int + in g x0 y0 z0 .== -160 + +-- unsupported; flip arguments to cond as below +glFuncFactIllegalTest = ExprExceptionTest "glFunc_factorial_illegal" UnsupportedRecCall $ + let fact = glFunc1 $ \n -> fact' n 1 + fact' :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + fact' = glFunc2 $ \n a -> cond (n ./= 0) (fact' (n - 1) (a * n)) a + in fact 5 .== 120 + +glFuncFactTest = ExprTest "glFunc_factorial" $ + let fact = glFunc1 $ \n -> fact' n 1 + fact' :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + fact' = glFunc2 $ \n a -> cond (n .== 0) a (fact' (n - 1) (a * n)) + in fact' 5 1 .== 120 + +glFuncFibTest = ExprTest "glFunc_fibonacci" $ + let fib = glFunc1 $ \n -> fib' n (vec2 0 1) + fib' :: GLExpr d Int -> GLExpr d (Vec 2 Int) -> GLExpr d Int + fib' = glFunc2 $ \n (decon -> (a, b)) -> cond (n .== 0) a (fib' (n - 1) (vec2 b (a + b))) + in fib 6 .== 8 + +glFuncMandelbrotTest = ExprTest "glFunc_mandelbrot" $ + let mand :: GLExpr d (Vec 2 Float) -> GLExpr d (Vec 2 Float) -> GLExpr d Int -> GLExpr d Int + mand = glFunc3 $ \pos0@(decon -> (x0, y0)) (decon -> (x, y)) i -> + cond (i .>= 50 .|| ((x * x + y * y) .> 4)) i $ + mand pos0 (vec2 (x * x - y * y + x0) (2 * x * y + y0)) (i + 1) + in mand (vec2 3 0) (vec2 0 0) 0 .== 1 .&& + mand (vec2 0 0) (vec2 0 0) 0 .== 50 + +-- unsupported; canonicalize as in test below +glFuncCollatzIllegalTest = ExprExceptionTest "glFunc_collatz_illegal" UnsupportedRecCall $ + let f :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + f = glFunc2 $ \n i -> cond (n .== 1) i $ + cond (n .% 2 .== 0) (f (n ./ 2) (i + 1)) (f (3 * n + 1) (i + 1)) + in f 27 0 .== 111 + +glFuncCollatzTest = ExprTest "glFunc_collatz" $ + let f :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + f = glFunc2 $ \n i -> cond (n .== 1) i $ + f (cond (n .% 2 .== 0) (n ./ 2) (3 * n + 1)) (i + 1) + in f 7 1 .== 17 + +-- unsupported; canonicalize as in test below +glFuncNestedCondIllegalTest = ExprExceptionTest "glFunc_nested_cond_illegal" UnsupportedRecCall $ + let f :: GLExpr d Int -> GLExpr d Int + f = glFunc1 $ \n -> (1 +) $ + cond (n .== 1) 1 $ + cond (n .== 2) 2 $ + cond (n .== 3) (f (n - 1)) $ + cond (n .== 4) (f (n - 3)) (f (n - 1)) + in f 1 .== 2 .&& f 2 .== 3 .&& f 3 .== 4 .&& f 4 .== 3 .&& f 10 .== 9 + +glFuncNestedCondTest = ExprTest "glFunc_nested_cond" $ + let f = glFunc1 $ \n -> f' n 0 + f' :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + f' = glFunc2 $ \n a -> + cond (n .<= 4) ( + cond (n .== 1) (2 + a) $ + cond (n .== 2) (3 + a) $ + cond (n .== 3) (4 + a) (3 + a) + ) $ f' (n - 1) (a + 1) + in f 1 .== 2 .&& f 2 .== 3 .&& f 3 .== 4 .&& f 4 .== 3 .&& f 10 .== 9 + +-- currently unsupported +glFuncNameCaptureIllegalTest = ExprExceptionTest "glFunc_name_capture_illegal" UnsupportedNameCapture $ + let f :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + f = glFunc2 $ \x u -> + let g = glFunc2 $ \y v -> x + y + u + v + in g 2 0 + in f 1 0 .== 3 + +glFuncRecIllegalTest = ExprExceptionTest "glFunc_rec_call_illegal" UnsupportedRecCall $ + let f :: GLExpr d Int -> GLExpr d Int -> GLExpr d Int + f = glFunc2 $ \x y -> f x (y + 1) + 1 + in f 0 0 .== 0 + +glFuncMutRecIllegalTest = ExprExceptionTest "glFunc_mut_rec_call_illegal" UnsupportedRecCall $ + let f :: GLExpr d Int -> GLExpr d Int + f = glFunc1 $ \x -> g x + 1 + g = glFunc1 $ \x -> f x + 1 + in f 0 .== 0 + + +-- uniform, prec, & built-in I/O variables + +-- TODO: test double-precision once supported + +uniformFloatTest = ExprTest "uniform_float" $ + almostEqual (uniform (1.2345 :: GLExpr d Float)) 1.2345 + +uniformIntTest = ExprTest "uniform_int" $ + let x = 2_000_000_000 :: GLExpr d Int + in uniform x .== x + +uniformUIntTest = ExprTest "uniform_uint" $ + let x = 4_000_000_000 :: GLExpr d UInt + in uniform x .== x + +uniformBoolTest = ExprTest "uniform_bool" $ + uniform true .== true .&& uniform false .== false + +uniformVec2FloatTest = ExprTest "uniform_vec2" $ + let x = 1.234567 + vec2 1 2 :: GLExpr d (Vec 2 Float) + in almostVecEqual (uniform x) x + +uniformVec3FloatTest = ExprTest "uniform_vec3" $ + let x = 1.234567 + vec3 1 2 3 :: GLExpr d (Vec 3 Float) + in almostVecEqual (uniform x) x + +uniformVec4FloatTest = ExprTest "uniform_vec4" $ + let x = 1.234567 + vec4 1 2 3 4 :: GLExpr d (Vec 4 Float) + in almostVecEqual (uniform x) x + +uniformVec2IntTest = ExprTest "uniform_ivec2" $ + let x = 2_000_000_000 + vec2 1 2 :: GLExpr d (Vec 2 Int) + in uniform x .== x + +uniformVec3IntTest = ExprTest "uniform_ivec3" $ + let x = 2_000_000_000 + vec3 1 2 3 :: GLExpr d (Vec 3 Int) + in uniform x .== x + +uniformVec4IntTest = ExprTest "uniform_ivec4" $ + let x = 2_000_000_000 + vec4 1 2 3 4 :: GLExpr d (Vec 4 Int) + in uniform x .== x + +uniformVec2UIntTest = ExprTest "uniform_uvec2" $ + let x = vec2 4_000_000_000 4_000_000_001 :: GLExpr d (Vec 2 UInt) + in uniform x .== x + +uniformVec3UIntTest = ExprTest "uniform_uvec3" $ + let x = vec3 4_000_000_001 4_000_000_002 4_000_000_003 :: GLExpr d (Vec 3 UInt) + in uniform x .== x + +uniformVec4UIntTest = ExprTest "uniform_uvec4" $ + let x = vec4 4_000_000_001 4_000_000_002 4_000_000_003 4_000_000_004 :: GLExpr d (Vec 4 UInt) + in uniform x .== x + +uniformVec2BoolTest = ExprTest "uniform_bvec2" $ + let x = vec2 true false :: GLExpr d (Vec 2 Bool) + in uniform x .== x + +uniformVec3BoolTest = ExprTest "uniform_bvec3" $ + let x = vec3 false true false :: GLExpr d (Vec 3 Bool) + in uniform x .== x + +uniformVec4BoolTest = ExprTest "uniform_bvec4" $ + let x = vec4 true false true false :: GLExpr d (Vec 4 Bool) + in uniform x .== x + +uniformMat2Test = ExprTest "uniform_mat2" $ + let m = mat2 (vec2 1 2) (vec2 3 4) :: GLExpr d (Mat 2 2 Float) + in almostMatPx2Equal (uniform m) m + +uniformMat3Test = ExprTest "uniform_mat3" $ + let m = mat3 (vec3 1 2 3) (vec3 4 5 6) (vec3 7 8 9) :: GLExpr d (Mat 3 3 Float) + in almostMatPx3Equal (uniform m) m + +uniformMat4Test = ExprTest "uniform_mat4" $ + let m = mat4 (vec4 1 2 3 4) (vec4 5 6 7 8) (vec4 9 10 11 12) (vec4 13 14 15 16) :: GLExpr d (Mat 4 4 Float) + in almostMatPx4Equal (uniform m) m + +uniformMat2x3Test = ExprTest "uniform_mat2x3" $ + let m = mat2x3 (vec2 1 2) (vec2 3 4) (vec2 5 6) :: GLExpr d (Mat 2 3 Float) + in almostMatPx3Equal (uniform m) m + +uniformMat2x4Test = ExprTest "uniform_mat2x4" $ + let m = mat2x4 (vec2 1 2) (vec2 3 4) (vec2 5 6) (vec2 7 8) :: GLExpr d (Mat 2 4 Float) + in almostMatPx4Equal (uniform m) m + +uniformMat3x2Test = ExprTest "uniform_mat3x2" $ + let m = mat3x2 (vec3 1 2 3) (vec3 4 5 6) :: GLExpr d (Mat 3 2 Float) + in almostMatPx2Equal (uniform m) m + +uniformMat3x4Test = ExprTest "uniform_mat3x4" $ + let m = mat3x4 (vec3 1 2 3) (vec3 4 5 6) (vec3 7 8 9) (vec3 10 11 12) :: GLExpr d (Mat 3 4 Float) + in almostMatPx4Equal (uniform m) m + +uniformMat4x2Test = ExprTest "uniform_mat4x2" $ + let m = mat4x2 (vec4 1 2 3 4) (vec4 5 6 7 8) :: GLExpr d (Mat 4 2 Float) + in almostMatPx2Equal (uniform m) m + +uniformMat4x3Test = ExprTest "uniform_mat4x3" $ + let m = mat4x3 (vec4 1 2 3 4) (vec4 5 6 7 8) (vec4 9 10 11 12) :: GLExpr d (Mat 4 3 Float) + in almostMatPx3Equal (uniform m) (mat4x3 (vec4 1 2 3 4) (vec4 5 6 7 8) (vec4 9 10 11 12)) + +uniformFloatArrayTest = ExprTest "uniform_float[]" $ + let a = map (+ 0.2345) [1, 2, 3, 4] :: [GLExpr d Float] + in foldr (\i e -> e .&& almostEqual (uniform (array a) .! cnst i) (a !! (fromEnum i))) true [0..3] + +uniformVec2ArrayTest = ExprTest "uniform_vec2[]" $ + let a = map (+ 0.2345) [vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8] :: [GLExpr d (Vec 2 Float)] + in foldr (\i e -> e .&& almostVecEqual (uniform (array a) .! cnst i) (a !! (fromEnum i))) true [0..3] + +uniformVec3ArrayTest = ExprTest "uniform_vec3[]" $ + let a = map (+ 0.2345) [vec3 1 2 3, vec3 4 5 6, vec3 7 8 9, vec3 10 11 12] :: [GLExpr d (Vec 3 Float)] + in foldr (\i e -> e .&& almostVecEqual (uniform (array a) .! cnst i) (a !! (fromEnum i))) true [0..3] + +uniformVec4ArrayTest = ExprTest "uniform_vec4[]" $ + let a = map (+ 0.2345) [vec4 1 2 3 4, vec4 5 6 7 8, vec4 9 10 11 12, vec4 13 14 15 16] :: [GLExpr d (Vec 4 Float)] + in foldr (\i e -> e .&& almostVecEqual (uniform (array a) .! cnst i) (a !! (fromEnum i))) true [0..3] + +uniformIntArrayTest = ExprTest "uniform_int[]" $ + let a = map (+ 2_000_000_000) [1, 2, 3, 4] :: [GLExpr d Int] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformIntVec2ArrayTest = ExprTest "uniform_ivec2[]" $ + let a = map (+ 2_000_000_000) [vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8] :: [GLExpr d (Vec 2 Int)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformIntVec3ArrayTest = ExprTest "uniform_ivec3[]" $ + let a = map (+ 2_000_000_000) [vec3 1 2 3, vec3 4 5 6, vec3 7 8 9, vec3 10 11 12] :: [GLExpr d (Vec 3 Int)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformIntVec4ArrayTest = ExprTest "uniform_ivec4[]" $ + let a = map (+ 2_000_000_000) [vec4 1 2 3 4, vec4 5 6 7 8, vec4 9 10 11 12, vec4 13 14 15 16] :: [GLExpr d (Vec 4 Int)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformUIntArrayTest = ExprTest "uniform_uint[]" $ + let a = map (+ 4_000_000_000) [1, 2, 3, 4] :: [GLExpr d UInt] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformUIntVec2ArrayTest = ExprTest "uniform_uvec2[]" $ + let a = map (+ 4_000_000_000) [vec2 1 2, vec2 5 6, vec2 9 10, vec2 13 14] :: [GLExpr d (Vec 2 UInt)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformUIntVec3ArrayTest = ExprTest "uniform_uvec3[]" $ + let a = map (+ 4_000_000_000) [vec3 1 2 3, vec3 5 6 7, vec3 9 10 11, vec3 13 14 15] :: [GLExpr d (Vec 3 UInt)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformUIntVec4ArrayTest = ExprTest "uniform_uvec4[]" $ + let a = map (+ 4_000_000_000) [vec4 1 2 3 4, vec4 5 6 7 8, vec4 9 10 11 12, vec4 13 14 15 16] :: [GLExpr d (Vec 4 UInt)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformBoolArrayTest = ExprTest "uniform_bool[]" $ + let a = [true, false, true, false] :: [GLExpr d Bool] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformBoolVec2ArrayTest = ExprTest "uniform_bvec2[]" $ + let a = [vec2 true true, vec2 true false, vec2 false true, vec2 false false] :: [GLExpr d (Vec 2 Bool)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformBoolVec3ArrayTest = ExprTest "uniform_bvec3[]" $ + let a = [vec3 true true true, vec3 true true false, vec3 true false true, vec3 true false false] :: [GLExpr d (Vec 3 Bool)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +uniformBoolVec4ArrayTest = ExprTest "uniform_bvec4[]" $ + let a = [vec4 true true true true, vec4 true true true false, vec4 true true false true, vec4 true true false false] :: [GLExpr d (Vec 4 Bool)] + in foldr (\i e -> e .&& uniform (array a) .! cnst i .== a !! (fromEnum i)) true [0..3] + +precTrivialTest = ExprTest "prec_trivial" $ + let x = prec (0 :: GLExpr d Int) x + x1 = prec (0 :: GLExpr d Int) (x1 + 1) + y1 = prec (0 :: GLExpr d Int) (y1 + 1) + in uniform x .== 0 .&& uniform x1 .> 0 .&& uniform x1 .== uniform y1 + +precNestedTest = ExprTest "prec_nested" $ + let x = prec (0 :: GLExpr d Int) (x + 1) + y = prec (-1 :: GLExpr d Int) x + in uniform y .> 0 + +precIntegrateTest = ExprTest "prec_integrate" $ + let t = prec (0 :: GLExpr d Int) (t + 1) + x = prec (0 :: GLExpr d Int) (x + t) + in uniform t .> 0 .&& + 2 * uniform x .== uniform t * (uniform t - 1) + +precTimeTest = ExprTest "prec_time" $ + let dt = prec 0 (time - prec 0 time) + dt_sum = prec 0 (dt_sum + dt) + in almostEqual (uniform $ prec 0 time) (uniform dt_sum) + +precSequenceTest = ExprTest "prec_sequence" $ + let t = prec (0 :: GLExpr d Int) (t + 1) + tp = uniform $ array $ take 20 $ iterate (\t -> prec 0 t) t + in foldr (\i e -> e .&& tp .! i .== uniform t - i) true (map cnst [0..19]) + +precFiboTest = ExprTest "prec_fibonacci" $ + let fibSeq = prec (0 :: GLExpr d Int) (fibSeq + prec 1 fibSeq) + fibSeq' = prec 0 fibSeq' + prec 0 (prec 1 fibSeq') + in uniform fibSeq .== uniform fibSeq' + +-- Shader-specific tests + +-- TODO: test double-precision once supported + +inputFloatTest = ExprTest "input_float" $ + let x = map (+ 0.2345) [1, 2, 3, 4] :: [GLExpr d Float] + in almostEqual (frag (vert x)) (frag (1 + vert (map (\x -> x - 1) x))) + +inputIntTest = ExprTest "input_int" $ + let x = map (+ 2_000_000_000) [1, 2, 3, 4] :: [GLExpr d Int] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputUIntTest = ExprTest "input_uint" $ + let x = map (+ 4_000_000_000) [1, 2, 3, 4] :: [GLExpr d UInt] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputVec2Test = ExprTest "input_vec2" $ + let x = map (+ 0.2345) [vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8] :: [GLExpr d (Vec 2 Float)] + in almostVecEqual (frag (vert x)) (frag (1 + vert (map (\x -> x - 1) x))) + +inputVec3Test = ExprTest "input_vec3" $ + let x = map (+ 0.2345) [vec3 1 2 3, vec3 4 5 6, vec3 7 8 9, vec3 10 11 12] :: [GLExpr d (Vec 3 Float)] + in almostVecEqual (frag (vert x)) (frag (1 + vert (map (\x -> x - 1) x))) + +inputVec4Test = ExprTest "input_vec4" $ + let x = map (+ 0.2345) [vec4 1 2 3 4, vec4 5 6 7 8, vec4 9 10 11 12, vec4 13 14 15 16] :: [GLExpr d (Vec 4 Float)] + in almostVecEqual (frag (vert x)) (frag (1 + vert (map (\x -> x - 1) x))) + +inputIntVec2Test = ExprTest "input_ivec2" $ + let x = map (+ 2_000_000_000) [vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8] :: [GLExpr d (Vec 2 Float)] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputIntVec3Test = ExprTest "input_ivec3" $ + let x = map (+ 2_000_000_000) [vec3 1 2 3, vec3 4 5 6, vec3 7 8 9, vec3 10 11 12] :: [GLExpr d (Vec 3 Float)] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputIntVec4Test = ExprTest "input_ivec4" $ + let x = map (+ 2_000_000_000) [vec4 1 2 3 4, vec4 5 6 7 8, vec4 9 10 11 12, vec4 13 14 15 16] :: [GLExpr d (Vec 4 Float)] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputUIntVec2Test = ExprTest "input_uvec2" $ + let x = map (+ 4_000_000_000) [vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8] :: [GLExpr d (Vec 2 Float)] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputUIntVec3Test = ExprTest "input_uvec3" $ + let x = map (+ 4_000_000_000) [vec3 1 2 3, vec3 4 5 6, vec3 7 8 9, vec3 10 11 12] :: [GLExpr d (Vec 3 Float)] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +inputUIntVec4Test = ExprTest "input_uvec4" $ + let x = map (+ 4_000_000_000) [vec4 1 2 3 4, vec4 5 6 7 8, vec4 9 10 11 12, vec4 13 14 15 16] :: [GLExpr d (Vec 4 Float)] + in flatFrag (vert x) .== flatFrag (1 + vert (map (\x -> x - 1) x)) + +interpTest = ExprTest "basic_interpolation_properties" $ + let x = vert [1, 2, 3, 4] :: VertExpr Float + x' = vert $ map (\x -> 2 * x + 1) [1, 2, 3, 4] + y = frag x + z = 2 * noperspFrag x + 1 + z' = noperspFrag x' + w = flatFrag x + in y .>=1 .&& y .<= 4 .&& + almostEqual z z' .&& + (w .== 1 .|| w .== 2 .|| w .== 3 .|| w .== 4) + + +-- Object-level tests + +trivialImageTest = ObjTest "trivial_image" $ return $ fromImage $ \pos -> + vec4 1 1 1 1 + +quad = + [vec2 (-1) (-1), + vec2 (-1) 1, + vec2 1 (-1), + vec2 1 1] + +passAroundTest = ObjTest "pass_around" [obj] where + ppos = vert quad + npos = vert $ map negate quad + + pos = ppos $- vec2 0 1 + fppos = frag ppos + fppos' = frag (-npos) + fppos'' = -(frag npos) + fnpos = frag npos + fnpos' = frag (-ppos) + fnpos'' = -(frag ppos) + color = (cast $ + fppos + fnpos .== 0 .&& + fppos + fnpos' .== 0 .&& + fppos + fnpos'' .== 0 .&& + fppos' + fnpos .== 0 .&& + fppos' + fnpos' .== 0 .&& + fppos' + fnpos'' .== 0 .&& + fppos'' + fnpos .== 0 .&& + fppos'' + fnpos' .== 0 .&& + fppos'' + fnpos'' .== 0) .# 1 + obj = triangleStrip { position = pos, color = color } + +multiObjOverlapTest = ObjTest "multi_obj_overlap" [obj1, obj2] where + pos = vert quad + obj1 = triangleStrip { position = pos $- vec2 0 1, color = 0 } + obj2 = triangleStrip { position = pos $- vec2 0 1, color = 1 } + +multiObjComplementTest = ObjTest "multi_obj_complement" [obj1, obj2] where + pos1 = vert + [vec2 (-1) 0, + vec2 (-1) 1, + vec2 1 0, + vec2 1 1] + pos2 = vert + [vec2 (-1) (-1), + vec2 (-1) 0, + vec2 1 (-1), + vec2 1 0] + c1 = cast (y_ (frag pos1) .>= 0) .# 1 + c2 = cast (y_ (frag pos2) .< 0) .# 1 + obj1 = triangleStrip { position = pos1 $- vec2 0 1, color = c1 } + obj2 = triangleStrip { position = pos2 $- vec2 0 1, color = c2 } + +multiObjDiscardTest = ObjTest "multi_obj_discard" [obj1, obj2] where + pos = vert quad + c1 = cast (y_ (frag pos) .>= 0) .# 1 + d1 = y_ (frag pos) .< 0 + c2 = cast (y_ (frag pos) .< 0) .# 1 + d2 = y_ (frag pos) .>= 0 + obj1 = triangleStrip { position = pos $- vec2 0 1, color = c1, discardWhen = d1 } + obj2 = triangleStrip { position = pos $- vec2 0 1, color = c2, discardWhen = d2 } + +multiObjSharedExprsTest = ObjTest "multi_obj_shared_exprs" [obj1, obj2] where + pos = vert quad + c = 0.5 .# 1 + 0.5 .# 1 + d1 = y_ (frag pos) .< 0 + d2 = y_ (frag pos) .>= 0 + obj1 = triangleStrip { position = pos $- vec2 0 1, color = c, discardWhen = d1 } + obj2 = triangleStrip { position = pos $- vec2 0 1, color = c, discardWhen = d2 } + +-- TODO: the next two tests should be re-eningeered properly +-- the first is expected to fail and the second should pass +multiObjSharedHostExprsTest = ObjTest "multi_obj_shared_host_exprs" [obj1, obj2] where + pos = vert quad + a = array [(cast . floor $ time * 100000000) + .% cnst (i + 1) | i <- [0..99]] :: HostExpr [Int] + x = (uniform a .! ((cast $ 1000 * x_ (frag pos)) .% 100)) .% 2 .== 0 + -- if obj1 and obj2 compute x separately then it is unlikely that + -- c1 and c2 will agree + c1 = cast x .# 1 + c2 = cast (nt x) .# 1 + d2 = x + obj1 = triangleStrip { position = pos $- vec2 0 1, color = c1 } + obj2 = triangleStrip { position = pos $- vec2 0 1, color = c2, discardWhen = d2 } + +multiObjSharedPrecsTest = ObjTest "multi_obj_shared_precs" [obj1, obj2] where + pos = vert quad + a = array [(cast . floor $ time * 100000000) + .% cnst (i + 1) | i <- [0..99]] :: HostExpr [Int] + x = (uniform a .! ((cast $ 1000 * x_ (frag pos)) .% 100)) .% 2 .== 0 + c1 = cast x .# 1 + c2 = cast (nt x) .# 1 + d2 = x + obj1 = triangleStrip { position = pos $- vec2 0 1, color = c1 } + obj2 = triangleStrip { position = pos $- vec2 0 1, color = c2, discardWhen = d2 } + +noInputVarsTest = ObjExceptionTest "no_input_vars" NoInputVars $ + [triangleStrip] + +emptyInputVarTest = ObjExceptionTest "empty_input_var" EmptyInputVar $ + [triangleStrip { position = vert [] }] + +mismatchedInputVarsTest = ObjExceptionTest "mismatched_input_vars" MismatchedInputVars $ + [triangleStrip { position = vert [1, 1], color = frag (vert [1, 1, 1]) }] + + +-- Caching tests + +exponentialExprTreeTest = ExprTest "exponential_expr_tree" $ + let f x = x + x + h = 40 + -- this is infeasible without caching as the entire + -- expression tree of size 2^h will have to be traversed + in iterate f (1 :: GLExpr d Int) !! h .== 2^h + +iteratedGlFuncTest = ExprTest "iterated_glFunc" $ + let f = glFunc1 $ \x -> x + x + h = 40 + in iterate f (1 :: GLExpr d Int) !! h .== 2^h + + +-- Examples (verify output manually) + +mkTestExample (label, objs) = TestLabel label $ TestCase $ + runObjs True label objs >>= (const $ assert True) + + +runTests :: Test -> IO () +runTests tests = do + count <- runTestTT tests + if errors count > 0 || failures count > 0 then exitFailure else return () + +main :: IO () +main = do + createDirectoryIfMissing True "output/test" + runTests $ TestList $ map mkHostTest genericTests + runTests $ TestList $ map mkHostTest hostTests + runTests $ TestList $ map mkShaderTest genericTests + runTests $ TestList $ map mkShaderTest shaderTests + runTests $ TestList $ map mkShaderExceptionTest shaderExceptionTests + runTests $ TestList $ map mkObjTest objTests + runTests $ TestList $ map mkObjExceptionTest objExceptionTests