{-# 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