HaGL (empty) → 0.1.0.0
raw patch · 24 files changed
+5827/−0 lines, 24 filesdep +GLUTdep +HUnitdep +HaGLsetup-changed
Dependencies added: GLUT, HUnit, HaGL, OpenGL, OpenGLRaw, array, base, bytestring, containers, cryptohash-md5, directory, gl-capture, hashable, matrix, mtl, template-haskell, time, unordered-containers
Files
- CHANGELOG.md +5/−0
- HaGL.cabal +105/−0
- LICENSE +20/−0
- README.md +111/−0
- Setup.hs +2/−0
- src/Graphics/HaGL.hs +982/−0
- src/Graphics/HaGL/Backend.hs +104/−0
- src/Graphics/HaGL/Backend/GLUT.hs +290/−0
- src/Graphics/HaGL/CodeGen.hs +301/−0
- src/Graphics/HaGL/Eval.hs +368/−0
- src/Graphics/HaGL/ExprID.hs +51/−0
- src/Graphics/HaGL/GLAst.hs +215/−0
- src/Graphics/HaGL/GLExpr.hs +431/−0
- src/Graphics/HaGL/GLObj.hs +55/−0
- src/Graphics/HaGL/GLType.hs +919/−0
- src/Graphics/HaGL/Internal.hs +25/−0
- src/Graphics/HaGL/Numerical.hs +188/−0
- src/Graphics/HaGL/Print.hs +120/−0
- src/Graphics/HaGL/Shader.hs +135/−0
- src/Graphics/HaGL/TH/HaGL.hs +80/−0
- src/Graphics/HaGL/Util.hs +10/−0
- src/Graphics/HaGL/Util/DepMap.hs +70/−0
- src/Graphics/HaGL/Util/Types.hs +27/−0
- tests/Test.hs +1213/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for HaGL++## 0.1.0.0 -- 2023-06-10++* Initial (pre-)release
+ HaGL.cabal view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Graphics/HaGL.hs view
@@ -0,0 +1,982 @@+{-|+Module : HaGL+Copyright : (c) Simeon Krastnikov, 2022-2023+License : MIT+Maintainer : Simeon Krastnikov <skrastnikov@gmail.com>+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 ()+}
+ src/Graphics/HaGL/Backend.hs view
@@ -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
+ src/Graphics/HaGL/Backend/GLUT.hs view
@@ -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+
+ src/Graphics/HaGL/CodeGen.hs view
@@ -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 } })
+ src/Graphics/HaGL/Eval.hs view
@@ -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
+ src/Graphics/HaGL/ExprID.hs view
@@ -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+
+ src/Graphics/HaGL/GLAst.hs view
@@ -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]
+ src/Graphics/HaGL/GLExpr.hs view
@@ -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
+ src/Graphics/HaGL/GLObj.hs view
@@ -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
+ src/Graphics/HaGL/GLType.hs view
@@ -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
+ src/Graphics/HaGL/Internal.hs view
@@ -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
+ src/Graphics/HaGL/Numerical.hs view
@@ -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
+ src/Graphics/HaGL/Print.hs view
@@ -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
+ src/Graphics/HaGL/Shader.hs view
@@ -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])
+ src/Graphics/HaGL/TH/HaGL.hs view
@@ -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"))))+ []]
+ src/Graphics/HaGL/Util.hs view
@@ -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
+ src/Graphics/HaGL/Util/DepMap.hs view
@@ -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-}
+ src/Graphics/HaGL/Util/Types.hs view
@@ -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
+ tests/Test.hs view
@@ -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