GPipe-GLFW 1.2.2 → 1.2.3
raw patch · 6 files changed
+217/−13 lines, 6 filesdep +GPipe-GLFWdep +exception-transformersdep ~GPipedep ~basedep ~transformersnew-component:exe:gpipe-glfw-smoketestsPVP ok
version bump matches the API change (PVP)
Dependencies added: GPipe-GLFW, exception-transformers
Dependency ranges changed: GPipe, base, transformers
API changes (from Hackage documentation)
Files
- GPipe-GLFW.cabal +26/−13
- test/Spec.hs +12/−0
- test/Test/Basic.hs +17/−0
- test/Test/Common.hs +128/−0
- test/Test/Multi.hs +16/−0
- test/Test/Split.hs +18/−0
GPipe-GLFW.cabal view
@@ -1,5 +1,5 @@ name: GPipe-GLFW-version: 1.2.2+version: 1.2.3 cabal-version: >=1.10 build-type: Simple author: Patrick Redmond@@ -19,28 +19,41 @@ library hs-source-dirs: src- build-depends:- base >=4.7 && <4.9,- transformers >= 0.3 && < 0.5,- GLFW-b >=1.4 && <1.5,- GPipe >=2.1 && <2.2+ build-depends: base >= 4.7 && <4.10+ , transformers >= 0.3 && <0.6+ , GLFW-b >= 1.4 && <1.5+ , GPipe >= 2.1 && <2.2 ghc-options: -Wall default-language: Haskell2010 exposed-modules: Graphics.GPipe.Context.GLFW- , Graphics.GPipe.Context.GLFW.Input- , Graphics.GPipe.Context.GLFW.Unsafe- other-modules:- Graphics.GPipe.Context.GLFW.Resource+ Graphics.GPipe.Context.GLFW.Input+ Graphics.GPipe.Context.GLFW.Unsafe+ other-modules: Graphics.GPipe.Context.GLFW.Resource Graphics.GPipe.Context.GLFW.Util Graphics.GPipe.Context.GLFW.Format +executable gpipe-glfw-smoketests+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , GPipe+ , GPipe-GLFW+ , transformers+ , exception-transformers+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ other-modules: Test.Common+ Test.Basic+ Test.Split+ Test.Multi+ source-repository head type: git- location: git@github.com:plredmond/GPipe-GLFW.git+ location: https://github.com/plredmond/GPipe-GLFW.git subdir: GPipe-GLFW source-repository this type: git- location: git@github.com:plredmond/GPipe-GLFW.git+ location: https://github.com/plredmond/GPipe-GLFW.git subdir: GPipe-GLFW- tag: v1.2.2+ tag: v1.2.3
+ test/Spec.hs view
@@ -0,0 +1,12 @@+import qualified System.Environment as Env+import qualified Test.Basic as Basic+import qualified Test.Split as Split+import qualified Test.Multi as Multi++main :: IO ()+main = do+ putStrLn "\n= Running smoke tests"+ Env.lookupEnv "LIBGL_ALWAYS_SOFTWARE" >>= \val -> putStrLn $ "LIBGL_ALWAYS_SOFTWARE: " ++ show val+ Basic.test (3 * 60)+ Split.test (3 * 60)+ Multi.test (3 * 60)
+ test/Test/Basic.hs view
@@ -0,0 +1,17 @@+module Test.Basic where++import Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common as C++-- Basic Test++test :: Int -> IO ()+test frameCount = do+ putStrLn "== Basic Test"+ putStrLn "\tRender a scene to a window."+ runContextT GLFW.newContext (ContextFormatColorDepth RGB8 Depth16) $ do+ resources <- C.initRenderContext [C.xAxis, C.yAxis, C.zAxis, C.plane]+ C.mainloop (frameCount, 0) resources++-- eof
+ test/Test/Common.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE Rank2Types #-}+module Test.Common where++import Control.Monad.Exception (MonadException)+import Control.Monad.IO.Class (MonadIO)+import Data.Traversable (forM)++import Graphics.GPipe++xAxis :: [(V3 Float, V3 Float)]+xAxis = zip (repeat $ V3 1 0 0) -- red+ [V3 (-1) 0 0, V3 1 0 0, V3 0.8 (-0.1) 0, V3 0.8 0 0, V3 1 (-0.1) 0]++yAxis :: [(V3 Float, V3 Float)]+yAxis = zip (repeat $ V3 0 1 0) -- green+ [V3 0 (-1) 0, V3 0 1 0, V3 0 0.8 (-0.1), V3 0 0.9 (-0.05), V3 0 1 (-0.1)]++zAxis :: [(V3 Float, V3 Float)]+zAxis = zip (repeat $ V3 0 0 1) -- blue+ [V3 0 0 (-1), V3 0 0 1, V3 (-0.1) 0 0.8, V3 (-0.1) 0 1]++plane :: [(V3 Float, V3 Float)]+plane = zip (repeat $ V3 1 1 1) -- white+ [V3 (-2) (-0.1) (-2), V3 (-2) (-0.1) 2, V3 2 (-0.1) 2, V3 2 (-0.1) (-2), V3 (-2) (-0.1) (-2)]++-- TODO: make tests+-- * basic+-- * split-thread load/render+-- * render multiple windows++data ShaderEnv os = ShaderEnv+ { extractProjU :: (Buffer os (Uniform (V4 (B4 Float))), Int)+ , extractLinePA :: PrimitiveArray Lines (B3 Float, B3 Float)+ , extractRastOpts :: (Side, ViewPort, DepthRange)+ }++initBuffers+ :: MonadIO m+ => [[(V3 Float, V3 Float)]]+ -> ContextT w os f m ([Buffer os (B3 Float, B3 Float)], Buffer os (Uniform (V4 (B4 Float))))+initBuffers rawMeshes = do+ -- make mesh buffers+ meshesB <- forM rawMeshes $ \pts -> do+ buf <- newBuffer $ length pts+ writeBuffer buf 0 pts+ return buf+ -- make projection matrix buffer+ projMatB <- newBuffer 1+ return (meshesB, projMatB)++projectLines :: forall os f. Shader os f (ShaderEnv os) (FragmentStream (V3 FFloat, FFloat))+projectLines = do+ projMat <- getUniform extractProjU+ linePS <- toPrimitiveStream extractLinePA+ -- project points+ let projectedLinePS = (\(c, p) -> (projMat !* point p, c)) <$> linePS+ lineFS <- rasterize extractRastOpts projectedLinePS+ -- write fragment depths and return frags+ return $ withRasterizedInfo (\fr inf -> (fr, depth inf)) lineFS+ where+ depth RasterizedInfo {rasterizedFragCoord = (V4 _ _ z _)} = z++-- TODO: just adds the draw call to the end of the shader & glues some init functions together+initRenderContext+ :: (MonadIO m, MonadException m)+ => [[(V3 Float, V3 Float)]]+ -> ContextT w os (ContextFormat RGBFloat Depth) m+ ( [Buffer os (B3 Float, B3 Float)]+ , Buffer os (Uniform (V4 (B4 Float)))+ , CompiledShader os (ContextFormat RGBFloat Depth) (ShaderEnv os)+ )+initRenderContext rawMeshes = do+ projShader <- compileShader (projectLines >>= drawContextColorDepth (const (ContextColorOption NoBlending $ pure True, DepthOption Less True)))+ (meshesB, projMatB) <- initBuffers rawMeshes+ return (meshesB, projMatB, projShader)++computeProjMat :: Float -> V2 Int -> M44 Float+computeProjMat frac (V2 w h) = camera2clip !*! world2camera !*! model2world+ where+ t = frac * 2 * pi+ model2world = identity+ world2camera = lookAt+ -- eye: camera position in world coordinates+ (V3 (3 * sin t) (0.5 + cos (t * 2)) (3 * cos t))+ (V3 0 0.1 0) -- center: camera look-at target position in world coords+ (V3 0 1 0) -- up: camera up-vector+ camera2clip = perspective+ (pi / 3) -- 60deg field of view "in y direction"+ (fromIntegral w / fromIntegral h) -- aspect ratio+ 1 100 -- near and far clipping plane++basicRenderer+ :: V2 Int+ -> ( [Buffer os (B3 Float, B3 Float)]+ , Buffer os (Uniform (V4 (B4 Float)))+ , CompiledShader os (ContextFormat RGBFloat Depth) (ShaderEnv os)+ )+ -> Render os (ContextFormat RGBFloat Depth) ()+basicRenderer size (meshesB, projMatB, projShader) = do+ clearContextColor 0.2 -- grey+ clearContextDepth 1 -- far plane+ meshPAs <- forM meshesB $ \mesh -> do+ meshVA <- newVertexArray mesh+ return $ toPrimitiveArray LineStrip meshVA+ projShader $ ShaderEnv (projMatB, 0) (mconcat meshPAs) (Front, ViewPort 0 size, DepthRange 0 1)++mainloop+ :: (MonadIO m, MonadException m)+ => (Int, Int)+ -> ( [Buffer os (B3 Float, B3 Float)]+ , Buffer os (Uniform (V4 (B4 Float)))+ , CompiledShader os (ContextFormat RGBFloat Depth) (ShaderEnv os)+ )+ -> ContextT w os (ContextFormat RGBFloat Depth) m ()+mainloop frame resources@(_, projMatB, _)+ | done frame = return ()+ | otherwise = do+ -- compute a projection matrix & write it to the buffer+ size <- getContextBuffersSize+ writeBuffer projMatB 0 [computeProjMat (frac frame) size]+ -- render the scene and then loop+ render $ basicRenderer size resources+ swapContextBuffers+ mainloop (next frame) resources+ where+ done (maxFrame, curFrame) = curFrame > maxFrame+ frac (maxFrame, curFrame) = fromIntegral curFrame / fromIntegral maxFrame+ next = fmap (+1)
+ test/Test/Multi.hs view
@@ -0,0 +1,16 @@+module Test.Multi where++import Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common as C++test :: Int -> IO ()+test _ = do+ putStrLn "== Multi window test"+ putStrLn "\tUse shared contexts to load resources and render different subsets to different windows."+ runContextT GLFW.newContext (ContextFormatColorDepth RGB8 Depth16) $ do+ -- TODO: in main thread render the axes++ -- TODO: fork; in other thread render just C.plane+ runSharedContextT (ContextFormatColorDepth RGB32F Depth16) $ do+ return ()
+ test/Test/Split.hs view
@@ -0,0 +1,18 @@+module Test.Split where++import Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+--import qualified Test.Common as C++test :: Int -> IO ()+test _ = do+ putStrLn "== Split thread test"+ putStrLn "\tUse shared contexts to load resources on one thread and render on another."+ runContextT GLFW.newContext (ContextFormatColorDepth RGB8 Depth16) $ do+ -- TODO: in main thread, make buffers but leave them empty++ -- TODO: fork; in other thread change contents of buffers once a second+ runSharedContextT (ContextFormatNone) $ do+ return ()++-- eof