gore-and-ash-lambdacube (empty) → 0.2.0.0
raw patch · 19 files changed
+1909/−0 lines, 19 filesdep +GLFW-bdep +JuicyPixelsdep +basesetup-changed
Dependencies added: GLFW-b, JuicyPixels, base, containers, deepseq, exceptions, gore-and-ash, gore-and-ash-glfw, gore-and-ash-lambdacube, hashable, lambdacube-compiler, lambdacube-gl, lambdacube-ir, linear, mtl, text, transformers, unordered-containers, vector
Files
- CHANGELOG.md +4/−0
- LICENSE +30/−0
- README.md +33/−0
- Setup.hs +2/−0
- examples/01/Main.hs +159/−0
- examples/02/Main.hs +175/−0
- examples/02/Matrix.hs +60/−0
- examples/03/Main.hs +200/−0
- examples/03/Matrix.hs +61/−0
- examples/04/Main.hs +244/−0
- examples/04/Matrix.hs +102/−0
- examples/shared/Core.hs +39/−0
- examples/shared/FPS.hs +27/−0
- gore-and-ash-lambdacube.cabal +230/−0
- src/Game/GoreAndAsh/LambdaCube.hs +60/−0
- src/Game/GoreAndAsh/LambdaCube/API.hs +134/−0
- src/Game/GoreAndAsh/LambdaCube/Module.hs +75/−0
- src/Game/GoreAndAsh/LambdaCube/State.hs +227/−0
- stack.yaml +47/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.2.0.0+=======++* Adapted to `lamdacube-compiler-0.6.0.0` and GHC 8.0.1
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Gushcha (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Anton Gushcha nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,33 @@+gore-and-ash-lambdacube+==================++The module provides API for something for [Gore&Ash](https://github.com/Teaspot-Studio/gore-and-ash) engine.++Installing+==========++Add following to your `stack.yml` to `packages` section:+```yaml+- location:+ git: https://github.com/TeaspotStudio/gore-and-ash-lambdacube.git+ commit: <PLACE HERE FULL HASH OF LAST COMMIT> +```++When defining you application stack, add `LambdaCubeT`:+``` haskell+type AppStack = ModuleStack [LambdaCubeT, ... other modules ... ] IO+```++And derive `MonadLambdaCube` for your resulting `AppMonad`:+``` haskell+newtype AppMonad a = AppMonad (AppStack a)+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadLambdaCube)+```++Building examples+=================++The package has several examples, to build them pass `examples` flag:+```+stack install --flag gore-and-ash-lambdacube:examples+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/01/Main.hs view
@@ -0,0 +1,159 @@+module Main where++import Control.DeepSeq+import GHC.Generics++import Control.Monad (join)+import Control.Monad.Catch (catch)+import Control.Monad.IO.Class+import Data.Maybe (fromMaybe)+import Data.Proxy++import Control.Wire+import Prelude hiding ((.), id)++import Game.GoreAndAsh+import Game.GoreAndAsh.LambdaCube+import Game.GoreAndAsh.GLFW++import Core+import FPS++import qualified Graphics.UI.GLFW as GLFW+import qualified Data.Map as Map+import qualified Data.Vector as V++import Codec.Picture as Juicy+import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL++mainPipeline :: PipelineId+mainPipeline = "mainPipeline"++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+ gs <- newGameState initStorage+ fps <- makeFPSBounder 180+ firstLoop fps gs `catch` errorExit+ where+ firstLoop fps gs = do+ (_, gs') <- stepGame gs $ do+ win <- liftIO $ initWindow "Gore&Ash LambdaCube Example 01" 640 640+ setCurrentWindowM $ Just win+ lambdacubeAddPipeline [".", "../shared"] "example01.lc" mainPipeline $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V2F+ "uv" @: Attribute_V2F+ defUniforms $ do+ "time" @: Float+ "diffuseTexture" @: FTexture2D+ return ()+ gameLoop fps gs'++ errorExit e = do+ liftIO $ case e of+ PipeLineCompileFailed _ _ msg -> putStrLn msg+ PipeLineAlreadyRegistered i -> putStrLn $ "Pipeline already registered: " ++ show i+ PipeLineNotFound i -> putStrLn $ "Pipeline is not found: " ++ show i+ StorageNotFound i -> putStrLn $ "Storage is not found: " ++ show i+ PipeLineIncompatible _ msg -> putStrLn $ "Pipeline incompatible: " ++ msg+ fail "terminate: fatal error"++ gameLoop fps gs = do+ waitFPSBound fps+ (mg, gs') <- stepGame gs (return ())+ mg `deepseq` if fromMaybe False $ gameExit <$> join mg+ then cleanupGameState gs'+ else gameLoop fps gs'++initWindow :: String -> Int -> Int -> IO GLFW.Window+initWindow title width height = do+ _ <- GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ GLFW.WindowHint'ContextVersionMajor 3+ , GLFW.WindowHint'ContextVersionMinor 3+ , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core+ , GLFW.WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win++data Game = Game {+ gameExit :: Bool+ }+ deriving (Generic)++instance NFData Game++-- | Initalizes storage and then switches to rendering state+initStorage :: AppWire a (Maybe Game)+initStorage = mkGen $ \_ _ -> do+ (sid, storage) <- lambdacubeCreateStorage mainPipeline+ textureData <- liftIO $ do+ -- upload geometry to GPU and add to pipeline input+ _ <- LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []+ _ <- LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []++ -- load image and upload texture+ Right img <- Juicy.readImage "../shared/logo.png"+ LambdaCubeGL.uploadTexture2DToGPU img++ lambdacubeRenderStorageFirst sid+ return (Right Nothing, renderWire storage textureData)++-- | Infinitely render given storage+renderWire :: GLStorage -> TextureData -> AppWire a (Maybe Game)+renderWire storage textureData = (<|> pure Nothing) $ proc _ -> do+ w <- nothingInhibit . liftGameMonad getCurrentWindowM -< ()+ closed <- isWindowClosed -< ()+ updateWinSize -< w+ renderStorage -< ()+ glfwFinishFrame -< w+ returnA -< Just $ Game closed+ where+ -- | Outputs True if user hits close button+ isWindowClosed :: AppWire a Bool+ isWindowClosed = hold . mapE (const True) . windowClosing <|> pure False++ -- | Updates LambdaCube window size+ updateWinSize :: AppWire GLFW.Window ()+ updateWinSize = liftGameMonad1 $ \win -> do+ (w, h) <- liftIO $ GLFW.getWindowSize win+ lambdacubeUpdateSize (fromIntegral w) (fromIntegral h)++ -- | Updates storage uniforms+ renderStorage :: AppWire a ()+ renderStorage = proc _ -> do+ t <- timeF -< ()+ fillUniforms -< t+ where+ fillUniforms :: AppWire Float ()+ fillUniforms = liftGameMonad1 $ \t -> liftIO $+ LambdaCubeGL.updateUniforms storage $ do+ "diffuseTexture" @= return textureData+ "time" @= return t++ -- | Swaps frame+ glfwFinishFrame :: AppWire GLFW.Window ()+ glfwFinishFrame = liftGameMonad1 $ liftIO . GLFW.swapBuffers++-- geometry data: triangles+triangleA :: LambdaCubeGL.Mesh+triangleA = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])+ , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])+ ]+ , mPrimitive = P_Triangles+ }++triangleB :: LambdaCubeGL.Mesh+triangleB = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])+ , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])+ ]+ , mPrimitive = P_Triangles+ }
+ examples/02/Main.hs view
@@ -0,0 +1,175 @@+module Main where++import Control.DeepSeq+import GHC.Generics++import Control.Monad (join)+import Control.Monad.Catch (catch)+import Control.Monad.IO.Class+import Data.Maybe (fromMaybe)+import Data.Proxy++import Control.Wire+import Prelude hiding ((.), id)++import Game.GoreAndAsh+import Game.GoreAndAsh.LambdaCube+import Game.GoreAndAsh.GLFW++import Core+import FPS+import Matrix++import qualified Graphics.UI.GLFW as GLFW+import qualified Data.Map as Map+import qualified Data.Vector as V++import Codec.Picture as Juicy+import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL++mainPipeline :: PipelineId+mainPipeline = "mainPipeline"++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+ gs <- newGameState initStorage+ fps <- makeFPSBounder 180+ firstLoop fps gs `catch` errorExit+ where+ firstLoop fps gs = do+ (_, gs') <- stepGame gs $ do+ win <- liftIO $ initWindow "Gore&Ash LambdaCube Example 02" 640 640+ setCurrentWindowM $ Just win+ lambdacubeAddPipeline [".", "../shared"] "example02.lc" mainPipeline $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V3F+ "uv" @: Attribute_V2F+ defUniforms $ do+ "projmat" @: M44F+ "diffuseTexture" @: FTexture2D+ return ()+ gameLoop fps gs'++ errorExit e = do+ liftIO $ case e of+ PipeLineCompileFailed _ _ msg -> putStrLn msg+ PipeLineAlreadyRegistered i -> putStrLn $ "Pipeline already registered: " ++ show i+ PipeLineNotFound i -> putStrLn $ "Pipeline is not found: " ++ show i+ StorageNotFound i -> putStrLn $ "Storage is not found: " ++ show i+ PipeLineIncompatible _ msg -> putStrLn $ "Pipeline incompatible: " ++ msg+ fail "terminate: fatal error"++ gameLoop fps gs = do+ waitFPSBound fps+ (mg, gs') <- stepGame gs (return ())+ mg `deepseq` if fromMaybe False $ gameExit <$> join mg+ then cleanupGameState gs'+ else gameLoop fps gs'++initWindow :: String -> Int -> Int -> IO GLFW.Window+initWindow title width height = do+ _ <- GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ GLFW.WindowHint'ContextVersionMajor 3+ , GLFW.WindowHint'ContextVersionMinor 3+ , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core+ , GLFW.WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win++data Game = Game {+ gameExit :: Bool+ }+ deriving (Generic)++instance NFData Game++-- | Initalizes storage and then switches to rendering state+initStorage :: AppWire a (Maybe Game)+initStorage = mkGen $ \_ _ -> do+ (sid, storage) <- lambdacubeCreateStorage mainPipeline+ textureData <- liftIO $ do+ -- upload geometry to GPU and add to pipeline input+ _ <- LambdaCubeGL.uploadMeshToGPU cubeMesh >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []++ -- load image and upload texture+ Right img <- Juicy.readImage "../shared/logo.png"+ LambdaCubeGL.uploadTexture2DToGPU img++ lambdacubeRenderStorageFirst sid+ return (Right Nothing, renderWire storage textureData)++-- | Infinitely render given storage+renderWire :: GLStorage -> TextureData -> AppWire a (Maybe Game)+renderWire storage textureData = (<|> pure Nothing) $ proc _ -> do+ w <- nothingInhibit . liftGameMonad getCurrentWindowM -< ()+ closed <- isWindowClosed -< ()+ aspect <- updateWinSize -< w+ renderStorage -< aspect+ glfwFinishFrame -< w+ returnA -< Just $ Game closed+ where+ -- | Outputs True if user hits close button+ isWindowClosed :: AppWire a Bool+ isWindowClosed = hold . mapE (const True) . windowClosing <|> pure False++ -- | Updates LambdaCube window size+ updateWinSize :: AppWire GLFW.Window Float+ updateWinSize = liftGameMonad1 $ \win -> do+ (w, h) <- liftIO $ GLFW.getWindowSize win+ lambdacubeUpdateSize (fromIntegral w) (fromIntegral h)+ return $ fromIntegral w / fromIntegral h++ -- | Updates storage uniforms+ renderStorage :: AppWire Float ()+ renderStorage = proc aspect -> do+ t <- timeF -< ()+ fillUniforms -< (aspect, t)+ where+ fillUniforms :: AppWire (Float, Float) ()+ fillUniforms = liftGameMonad1 $ \(aspect, t) -> liftIO $+ LambdaCubeGL.updateUniforms storage $ do+ "diffuseTexture" @= return textureData+ "projmat" @= return (mvp aspect t)++ -- | Swaps frame+ glfwFinishFrame :: AppWire GLFW.Window ()+ glfwFinishFrame = liftGameMonad1 $ liftIO . GLFW.swapBuffers++-- geometry data: triangles+cubeMesh :: LambdaCubeGL.Mesh+cubeMesh = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V3F $ V.fromList vertecies)+ , ("uv", A_V2F $ V.fromList uvs)+ ]+ , mPrimitive = P_Triangles+ }+ where+ vertecies = [+ v3, v2, v1, v3, v1, v0+ , v4, v7, v6, v4, v6, v5+ , v0, v1, v7, v0, v7, v4+ , v5, v6, v2, v5, v2, v3+ , v2, v6, v7, v2, v7, v1+ , v5, v3, v0, v5, v0, v4+ ]+ uvs = concat $ replicate 6 [u1, u2, u3, u1, u3, u0]++ v0 = V3 (-1) (-1) (-1)+ v1 = V3 (-1) 1 (-1)+ v2 = V3 1 1 (-1)+ v3 = V3 1 (-1) (-1)+ v4 = V3 (-1) (-1) 1+ v5 = V3 1 (-1) 1+ v6 = V3 1 1 1+ v7 = V3 (-1) 1 1++ u0 = V2 0 0+ u1 = V2 1 0+ u2 = V2 1 1+ u3 = V2 0 1
+ examples/02/Matrix.hs view
@@ -0,0 +1,60 @@+module Matrix(+ mvp+ ) where++import Linear+import qualified LambdaCube.Linear as LC ++-- | Calculating Model-View-Projection matrix, matrix in LambdaCube format+mvp :: Float -> Float -> LC.M44F+mvp !aspect !t = convLC $ mvp' aspect t++convLC :: M44 Float -> LC.M44F +convLC (V4 !a !b !c !d) = LC.V4 (cv a) (cv b) (cv c) (cv d)+ where+ cv (V4 !x !y !z !w) = LC.V4 x y z w++-- | Calculating Model-View-Projection matrix+mvp' :: Float -> Float -> M44 Float+mvp' !aspect !t = transpose $ projMatrix !*! cameraMatrix !*! modelMatrix+ where+ modelMatrix = quatMatrix $ axisAngle (V3 1 0 1) t ++ cameraMatrix = lookAt eye (V3 0 0 0) (V3 0 1 0)+ eye = rotate (axisAngle (V3 0 1 0) t) (V3 0 0 (-5))++ projMatrix = perspective (pi/3) aspect 0.1 100++-- | Transform quaternion to rotation matrix+quatMatrix :: Quaternion Float -> M44 Float +quatMatrix q@(Quaternion !w (V3 !x !y !z)) = V4+ (V4 m00 m01 m02 0)+ (V4 m10 m11 m12 0) + (V4 m20 m21 m22 0) + (V4 0 0 0 1) + where+ s = 2 / norm q+ x2 = x * s+ y2 = y * s+ z2 = z * s+ xx = x * x2+ xy = x * y2+ xz = x * z2+ yy = y * y2+ yz = y * z2+ zz = z * z2+ wx = w * x2+ wy = w * y2+ wz = w * z2+ + m00 = 1 - (yy + zz)+ m10 = xy - wz+ m20 = xz + wy+ + m01 = xy + wz+ m11 = 1 - (xx + zz)+ m21 = yz - wx+ + m02 = xz - wy+ m12 = yz + wx+ m22 = 1 - (xx + yy)
+ examples/03/Main.hs view
@@ -0,0 +1,200 @@+module Main where++import Control.DeepSeq+import GHC.Generics++import Control.Monad (join)+import Control.Monad.Catch (catch)+import Control.Monad.IO.Class+import Data.Maybe (fromMaybe)+import Data.Proxy++import Control.Wire+import Prelude hiding ((.), id)++import Game.GoreAndAsh+import Game.GoreAndAsh.LambdaCube+import Game.GoreAndAsh.GLFW++import Core+import FPS+import Matrix++import qualified Graphics.UI.GLFW as GLFW+import qualified Data.Map as Map+import qualified Data.Vector as V++import Codec.Picture as Juicy+import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL+import LambdaCube.Linear++mainPipeline :: PipelineId+mainPipeline = "mainPipeline"++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+ gs <- newGameState initStorage+ fps <- makeFPSBounder 180+ firstLoop fps gs `catch` errorExit+ where+ firstLoop fps gs = do+ (_, gs') <- stepGame gs $ do+ win <- liftIO $ initWindow "Gore&Ash LambdaCube Example 03" 640 640+ setCurrentWindowM $ Just win+ lambdacubeAddPipeline [".", "../shared"] "example03.lc" mainPipeline $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V3F+ "normal" @: Attribute_V3F+ "uv" @: Attribute_V2F+ defUniforms $ do+ "modelMat" @: M44F+ "viewMat" @: M44F+ "projMat" @: M44F+ "diffuseTexture" @: FTexture2D+ "lightPos" @: V3F++ return ()+ gameLoop fps gs'++ errorExit e = do+ liftIO $ case e of+ PipeLineCompileFailed _ _ msg -> putStrLn msg+ PipeLineAlreadyRegistered i -> putStrLn $ "Pipeline already registered: " ++ show i+ PipeLineNotFound i -> putStrLn $ "Pipeline is not found: " ++ show i+ StorageNotFound i -> putStrLn $ "Storage is not found: " ++ show i+ PipeLineIncompatible _ msg -> putStrLn $ "Pipeline incompatible: " ++ msg+ fail "terminate: fatal error"++ gameLoop fps gs = do+ waitFPSBound fps+ (mg, gs') <- stepGame gs (return ())+ mg `deepseq` if fromMaybe False $ gameExit <$> join mg+ then cleanupGameState gs'+ else gameLoop fps gs'++initWindow :: String -> Int -> Int -> IO GLFW.Window+initWindow title width height = do+ _ <- GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ GLFW.WindowHint'ContextVersionMajor 3+ , GLFW.WindowHint'ContextVersionMinor 3+ , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core+ , GLFW.WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win++data Game = Game {+ gameExit :: Bool+ }+ deriving (Generic)++instance NFData Game++-- | Initalizes storage and then switches to rendering state+initStorage :: AppWire a (Maybe Game)+initStorage = mkGen $ \_ _ -> do+ (sid, storage) <- lambdacubeCreateStorage mainPipeline+ textureData <- liftIO $ do+ -- upload geometry to GPU and add to pipeline input+ _ <- LambdaCubeGL.uploadMeshToGPU cubeMesh >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []++ -- load image and upload texture+ Right img <- Juicy.readImage "../shared/logo.png"+ LambdaCubeGL.uploadTexture2DToGPU img++ lambdacubeRenderStorageFirst sid+ return (Right Nothing, renderWire storage textureData)++-- | Infinitely render given storage+renderWire :: GLStorage -> TextureData -> AppWire a (Maybe Game)+renderWire storage textureData = (<|> pure Nothing) $ proc _ -> do+ w <- nothingInhibit . liftGameMonad getCurrentWindowM -< ()+ closed <- isWindowClosed -< ()+ aspect <- updateWinSize -< w+ renderStorage -< aspect+ glfwFinishFrame -< w+ returnA -< Just $ Game closed+ where+ -- | Outputs True if user hits close button+ isWindowClosed :: AppWire a Bool+ isWindowClosed = hold . mapE (const True) . windowClosing <|> pure False++ -- | Updates LambdaCube window size+ updateWinSize :: AppWire GLFW.Window Float+ updateWinSize = liftGameMonad1 $ \win -> do+ (w, h) <- liftIO $ GLFW.getWindowSize win+ lambdacubeUpdateSize (fromIntegral w) (fromIntegral h)+ return $ fromIntegral w / fromIntegral h++ -- | Updates storage uniforms+ renderStorage :: AppWire Float ()+ renderStorage = proc aspect -> do+ t <- timeF -< ()+ fillUniforms -< (aspect, t)+ where+ fillUniforms :: AppWire (Float, Float) ()+ fillUniforms = liftGameMonad1 $ \(aspect, t) -> liftIO $+ LambdaCubeGL.updateUniforms storage $ do+ "diffuseTexture" @= return textureData+ "modelMat" @= return (modelMatrix t)+ "viewMat" @= return (cameraMatrix t)+ "projMat" @= return (projMatrix aspect)+ "lightPos" @= return (V3 3 3 3 :: V3F)++ -- | Swaps frame+ glfwFinishFrame :: AppWire GLFW.Window ()+ glfwFinishFrame = liftGameMonad1 $ liftIO . GLFW.swapBuffers++-- geometry data: triangles+cubeMesh :: LambdaCubeGL.Mesh+cubeMesh = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V3F $ V.fromList vertecies)+ , ("normal", A_V3F $ V.fromList normals)+ , ("uv", A_V2F $ V.fromList uvs)+ ]+ , mPrimitive = P_Triangles+ }+ where+ vertecies = [+ v3, v2, v1, v3, v1, v0+ , v4, v7, v6, v4, v6, v5+ , v0, v1, v7, v0, v7, v4+ , v5, v6, v2, v5, v2, v3+ , v2, v6, v7, v2, v7, v1+ , v5, v3, v0, v5, v0, v4+ ]+ normals = concat [+ replicate 6 n0+ , replicate 6 n1+ , replicate 6 n2+ , replicate 6 n3+ , replicate 6 n4+ , replicate 6 n5+ ]+ uvs = concat $ replicate 6 [u1, u2, u3, u1, u3, u0]++ v0 = V3 (-1) (-1) (-1)+ v1 = V3 (-1) 1 (-1)+ v2 = V3 1 1 (-1)+ v3 = V3 1 (-1) (-1)+ v4 = V3 (-1) (-1) 1+ v5 = V3 1 (-1) 1+ v6 = V3 1 1 1+ v7 = V3 (-1) 1 1++ n0 = V3 0 0 (-1)+ n1 = V3 0 0 1+ n2 = V3 (-1) 0 0+ n3 = V3 1 0 0+ n4 = V3 0 1 0+ n5 = V3 0 (-1) 0++ u0 = V2 0 0+ u1 = V2 1 0+ u2 = V2 1 1+ u3 = V2 0 1
+ examples/03/Matrix.hs view
@@ -0,0 +1,61 @@+module Matrix(+ modelMatrix+ , cameraMatrix+ , projMatrix+ ) where++import Linear+import qualified LambdaCube.Linear as LC ++-- | Convert from linear matrix format to LambdaCube format+convLC :: M44 Float -> LC.M44F +convLC (V4 !a !b !c !d) = LC.V4 (cv a) (cv b) (cv c) (cv d)+ where+ cv (V4 !x !y !z !w) = LC.V4 x y z w++-- | Model matrix, maps from local model coords to world coords+modelMatrix :: Float -> LC.M44F +modelMatrix t = convLC . quatMatrix $ axisAngle (normalize $ V3 1 1 3) t ++-- | Camera matrix, maps from world coords to camera coords+cameraMatrix :: Float -> LC.M44F +cameraMatrix _ = convLC $ lookAt eye (V3 0 0 0) (V3 0 1 0)+ where eye = V3 5 2 5 -- rotate (axisAngle (V3 0 1 0) t) (V3 5 2 5)++-- | Projection matrix, maps from camera coords to device normalized coords+projMatrix :: Float -> LC.M44F +projMatrix !aspect = convLC $ perspective (pi/3) aspect 0.1 100++-- | Transform quaternion to rotation matrix+quatMatrix :: Quaternion Float -> M44 Float +quatMatrix q@(Quaternion !w (V3 !x !y !z)) = V4+ (V4 m00 m01 m02 0)+ (V4 m10 m11 m12 0) + (V4 m20 m21 m22 0) + (V4 0 0 0 1) + where+ s = 2 / norm q+ x2 = x * s+ y2 = y * s+ z2 = z * s+ xx = x * x2+ xy = x * y2+ xz = x * z2+ yy = y * y2+ yz = y * z2+ zz = z * z2+ wx = w * x2+ wy = w * y2+ wz = w * z2+ + m00 = 1 - (yy + zz)+ m10 = xy - wz+ m20 = xz + wy+ + m01 = xy + wz+ m11 = 1 - (xx + zz)+ m21 = yz - wx+ + m02 = xz - wy+ m12 = yz + wx+ m22 = 1 - (xx + yy)
+ examples/04/Main.hs view
@@ -0,0 +1,244 @@+module Main where++import Control.DeepSeq+import GHC.Generics++import Control.Monad (join)+import Control.Monad.Catch (catch)+import Control.Monad.IO.Class+import Data.Int+import Data.Maybe (fromMaybe)+import Data.Proxy++import Control.Wire+import Prelude hiding ((.), id)++import Game.GoreAndAsh+import Game.GoreAndAsh.LambdaCube+import Game.GoreAndAsh.GLFW++import Core+import Matrix++import qualified Graphics.UI.GLFW as GLFW+import qualified Data.Map as Map+import qualified Data.Vector as V++import Codec.Picture as Juicy+import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL++mainPipeline :: PipelineId+mainPipeline = "mainPipeline"++main :: IO ()+main = withModule (Proxy :: Proxy AppMonad) $ do+ gs <- newGameState mainWire+ firstLoop gs `catch` errorExit+ where+ firstLoop gs = do+ (_, gs') <- stepGame gs $ do+ win <- liftIO $ initWindow "Gore&Ash LambdaCube Example 04" 640 640+ setCurrentWindowM $ Just win+ lambdacubeAddPipeline [".", "../shared"] "example04.lc" mainPipeline $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V3F+ "normal" @: Attribute_V3F+ "uv" @: Attribute_V2F+ defUniforms $ do+ "modelMat" @: M44F+ "viewMat" @: M44F+ "projMat" @: M44F+ "depthMVP" @: M44F+ "diffuseTexture" @: FTexture2D+ "lightDir" @: V3F+ "windowWidth" @: Int+ "windowHeight" @: Int++ return ()+ gameLoop gs'++ errorExit e = do+ liftIO $ case e of+ PipeLineCompileFailed _ _ msg -> putStrLn msg+ PipeLineAlreadyRegistered i -> putStrLn $ "Pipeline already registered: " ++ show i+ PipeLineNotFound i -> putStrLn $ "Pipeline is not found: " ++ show i+ StorageNotFound i -> putStrLn $ "Storage is not found: " ++ show i+ PipeLineIncompatible _ msg -> putStrLn $ "Pipeline incompatible: " ++ msg+ fail "terminate: fatal error"++ gameLoop gs = do+ (mg, gs') <- stepGame gs (return ())+ mg `deepseq` if fromMaybe False $ gameExit <$> join mg+ then cleanupGameState gs'+ else gameLoop gs'++initWindow :: String -> Int -> Int -> IO GLFW.Window+initWindow title width height = do+ _ <- GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ GLFW.WindowHint'ContextVersionMajor 3+ , GLFW.WindowHint'ContextVersionMinor 3+ , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core+ , GLFW.WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win++data Game = Game {+ gameExit :: Bool+ }+ deriving (Generic)++instance NFData Game++mainWire :: AppWire a (Maybe Game)+mainWire = withInit (const initStorage) (uncurry renderWire)++-- | Initalizes storage and then switches to rendering state+initStorage :: GameMonadT AppMonad (GLStorage, GPUMesh)+initStorage = do+ (sid, storage) <- lambdacubeCreateStorage mainPipeline+ gpuMesh <- liftIO $ LambdaCubeGL.uploadMeshToGPU cubeMesh+ lambdacubeRenderStorageFirst sid+ return (storage, gpuMesh)++-- | Infinitely render given storage+renderWire :: GLStorage -> GPUMesh -> AppWire a (Maybe Game)+renderWire storage gpuMesh = (<|> pure Nothing) $ proc _ -> do+ w <- nothingInhibit . liftGameMonad getCurrentWindowM -< ()+ closed <- isWindowClosed -< ()+ (aspect, width, height) <- updateWinSize -< w+ t <- timeF -< ()+ globalUniforms -< (aspect, t, width, height)+ cube storage gpuMesh -< ()+ wall storage gpuMesh -< ()+ glfwFinishFrame -< w+ returnA -< Just $ Game closed+ where+ -- | Outputs True if user hits close button+ isWindowClosed :: AppWire a Bool+ isWindowClosed = hold . mapE (const True) . windowClosing <|> pure False++ -- | Updates LambdaCube window size+ updateWinSize :: AppWire GLFW.Window (Float, Int32, Int32)+ updateWinSize = liftGameMonad1 $ \win -> do+ (w, h) <- liftIO $ GLFW.getWindowSize win+ lambdacubeUpdateSize (fromIntegral w) (fromIntegral h)+ return (fromIntegral w / fromIntegral h, fromIntegral w, fromIntegral h)++ -- | Updates storage uniforms+ globalUniforms :: AppWire (Float, Float, Int32, Int32) ()+ globalUniforms = liftGameMonad1 $ \(aspect, t, w, h) -> liftIO $+ LambdaCubeGL.updateUniforms storage $ do+ "viewMat" @= return (cameraMatrix t)+ "projMat" @= return (projMatrix aspect)+ "lightDir" @= return lightDirection+ "windowWidth" @= return w+ "windowHeight" @= return h++ -- | Swaps frame+ glfwFinishFrame :: AppWire GLFW.Window ()+ glfwFinishFrame = liftGameMonad1 $ liftIO . GLFW.swapBuffers++-- | Intializes and renders cube+cube :: GLStorage -> GPUMesh -> AppWire a ()+cube storage gpuMesh = withInit (const initCube) (uncurry renderCube)+ where+ initCube :: GameMonadT AppMonad (Object, TextureData)+ initCube = do+ -- upload geometry to GPU and add to pipeline input+ obj <- liftIO $+ LambdaCubeGL.addMeshToObjectArray storage "objects" ["modelMat", "diffuseTexture", "depthMVP"] gpuMesh++ -- load image and upload texture+ texLogoData <- liftIO $ do+ Right img <- Juicy.readImage "../shared/logo.png"+ LambdaCubeGL.uploadTexture2DToGPU img++ return (obj, texLogoData)++ -- | Update object specific uniforms+ renderCube :: Object -> TextureData -> AppWire a ()+ renderCube obj textureData = (timeF >>>) $ liftGameMonad1 $ \t -> liftIO $ do+ let setter = LambdaCubeGL.objectUniformSetter obj+ uniformM44F "modelMat" setter $ modelMatrixCube t+ uniformM44F "depthMVP" setter $ depthMVPCube t+ uniformFTexture2D "diffuseTexture" setter textureData++-- | Initializes and renders wall+wall :: GLStorage -> GPUMesh -> AppWire a ()+wall storage gpuMesh = withInit (const initWall) (uncurry renderWall)+ where+ initWall :: GameMonadT AppMonad (Object, TextureData)+ initWall = do+ -- upload geometry to GPU and add to pipeline input+ obj <- liftIO $+ LambdaCubeGL.addMeshToObjectArray storage "objects" ["modelMat", "diffuseTexture", "depthMVP"] gpuMesh++ -- load image and upload texture+ texLogoData <- liftIO $ do+ Right img <- Juicy.readImage "../shared/brick.jpg"+ LambdaCubeGL.uploadTexture2DToGPU img++ return (obj, texLogoData)++ -- | Update object specific uniforms+ renderWall :: Object -> TextureData -> AppWire a ()+ renderWall obj textureData = liftGameMonad . liftIO $ do+ let setter = LambdaCubeGL.objectUniformSetter obj+ uniformM44F "modelMat" setter modelMatrixWall+ uniformM44F "depthMVP" setter depthMVPWall+ uniformFTexture2D "diffuseTexture" setter textureData++-- geometry data: triangles+cubeMesh :: LambdaCubeGL.Mesh+cubeMesh = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V3F $ V.fromList vertecies)+ , ("normal", A_V3F $ V.fromList normals)+ , ("uv", A_V2F $ V.fromList uvs)+ ]+ , mPrimitive = P_Triangles+ }+ where+ vertecies = [+ v3, v2, v1, v3, v1, v0+ , v4, v7, v6, v4, v6, v5+ , v0, v1, v7, v0, v7, v4+ , v5, v6, v2, v5, v2, v3+ , v2, v6, v7, v2, v7, v1+ , v5, v3, v0, v5, v0, v4+ ]+ normals = concat [+ replicate 6 n0+ , replicate 6 n1+ , replicate 6 n2+ , replicate 6 n3+ , replicate 6 n4+ , replicate 6 n5+ ]+ uvs = concat $ replicate 6 [u1, u2, u3, u1, u3, u0]++ v0 = V3 (-1) (-1) (-1)+ v1 = V3 (-1) 1 (-1)+ v2 = V3 1 1 (-1)+ v3 = V3 1 (-1) (-1)+ v4 = V3 (-1) (-1) 1+ v5 = V3 1 (-1) 1+ v6 = V3 1 1 1+ v7 = V3 (-1) 1 1++ n0 = V3 0 0 (-1)+ n1 = V3 0 0 1+ n2 = V3 (-1) 0 0+ n3 = V3 1 0 0+ n4 = V3 0 1 0+ n5 = V3 0 (-1) 0++ u0 = V2 0 0+ u1 = V2 1 0+ u2 = V2 1 1+ u3 = V2 0 1
+ examples/04/Matrix.hs view
@@ -0,0 +1,102 @@+module Matrix(+ modelMatrixCube+ , modelMatrixWall+ , cameraMatrix+ , projMatrix+ , lightDirection+ , depthMVPCube+ , depthMVPWall+ ) where++import Linear+import qualified LambdaCube.Linear as LC +import Game.GoreAndAsh.Math ++-- | Convert from linear matrix format to LambdaCube format+convLC :: M44 Float -> LC.M44F +convLC (V4 !a !b !c !d) = LC.V4 (cv a) (cv b) (cv c) (cv d)+ where+ cv (V4 !x !y !z !w) = LC.V4 x y z w++-- | Convert from linear vector format to LambdaCube format+convLCV :: V3 Float -> LC.V3F+convLCV (V3 !x !y !z) = LC.V3 x y z ++-- | Model matrix for rotating cube, maps from local model coords to world coords+modelMatrixCube :: Float -> LC.M44F +modelMatrixCube = convLC . modelMatrixCube'++modelMatrixCube' :: Float -> M44 Float +modelMatrixCube' t = quatMatrix $ axisAngle (normalize $ V3 1 1 3) t ++-- | Model matrix for static wall, maps from local model coords to world coords+modelMatrixWall :: LC.M44F +modelMatrixWall = convLC modelMatrixWall'++modelMatrixWall' :: M44 Float +modelMatrixWall' = scale (V3 1 7 7) !*! translate (V3 (-3) 0 0)++-- | Camera matrix, maps from world coords to camera coords+cameraMatrix :: Float -> LC.M44F +cameraMatrix t = convLC $ lookAt eye (V3 0 0 0) (V3 0 1 0)+ where eye = rotate (axisAngle (V3 0 1 0) t) (V3 15 2 15)++-- | Projection matrix, maps from camera coords to device normalized coords+projMatrix :: Float -> LC.M44F +projMatrix !aspect = convLC $ perspective (pi/3) aspect 0.1 100++-- | Direction of light+lightDirection :: LC.V3F+lightDirection = convLCV lightDir ++-- | Direction of light in Linear vector+lightDir :: V3 Float +lightDir = normalize $ V3 (-3) 0.5 0 ++-- | Matrix to view from directed light source+depthMVPCube :: Float -> LC.M44F +depthMVPCube t = depthMVP $ modelMatrixCube' t++-- | Matrix to view from directed light source+depthMVPWall :: LC.M44F +depthMVPWall = depthMVP modelMatrixWall'++depthMVP :: M44 Float -> LC.M44F +depthMVP modelMtx = convLC . transpose $ proj !*! view !*! modelMtx+ where + view = lookAt (negate lightDir) (V3 0 0 0) (V3 0 1 0)+ proj = ortho (-10) 10 (-10) 10 (-10) (10)++-- | Transform quaternion to rotation matrix+quatMatrix :: Quaternion Float -> M44 Float +quatMatrix q@(Quaternion !w (V3 !x !y !z)) = V4+ (V4 m00 m01 m02 0)+ (V4 m10 m11 m12 0) + (V4 m20 m21 m22 0) + (V4 0 0 0 1) + where+ s = 2 / norm q+ x2 = x * s+ y2 = y * s+ z2 = z * s+ xx = x * x2+ xy = x * y2+ xz = x * z2+ yy = y * y2+ yz = y * z2+ zz = z * z2+ wx = w * x2+ wy = w * y2+ wz = w * z2+ + m00 = 1 - (yy + zz)+ m10 = xy - wz+ m20 = xz + wy+ + m01 = xy + wz+ m11 = 1 - (xx + zz)+ m21 = yz - wx+ + m02 = xz - wy+ m12 = yz + wx+ m22 = 1 - (xx + yy)
@@ -0,0 +1,39 @@+module Core where++import Control.DeepSeq+import GHC.Generics ++import Control.Monad.Catch +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Proxy ++import Control.Wire +import Prelude hiding ((.), id)++import Game.GoreAndAsh+import Game.GoreAndAsh.GLFW +import Game.GoreAndAsh.LambdaCube ++-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [GLFWT, LambdaCubeT] IO+newtype AppState = AppState (ModuleState AppStack)+ deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadLambdaCube, MonadGLFW)++instance GameModule AppMonad AppState where + type ModuleState AppMonad = AppState+ runModule (AppMonad m) (AppState s) = do + (a, s') <- runModule m s + return (a, AppState s')+ newModuleState = AppState <$> newModuleState+ withModule _ = withModule (Proxy :: Proxy AppStack)+ cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b
@@ -0,0 +1,27 @@+module FPS(+ makeFPSBounder+ , waitFPSBound+ ) where++import GHC.Event+import Control.Concurrent+import Control.Monad ++type FPSBound = MVar ()++-- | Creates mvar that fills periodically with given fps+makeFPSBounder :: Int -> IO FPSBound+makeFPSBounder fps = do+ v <- newEmptyMVar + tm <- getSystemTimerManager+ let t = ceiling ((1000000 :: Double) / fromIntegral fps)+ callback v tm t+ return v+ where+ callback v tm t = do + putMVar v ()+ void $ registerTimeout tm t $ callback v tm t++-- | Wait until next FPS value is reached when the function unblocks+waitFPSBound :: FPSBound -> IO ()+waitFPSBound = takeMVar
+ gore-and-ash-lambdacube.cabal view
@@ -0,0 +1,230 @@+name: gore-and-ash-lambdacube+version: 0.2.0.0+synopsis: Core module for Gore&Ash engine that do something.+description: Please see README.md+homepage: https://github.com/TeaspotStudio/gore-and-ash-lambdacube#readme+license: BSD3+license-file: LICENSE+author: Anton Gushcha+maintainer: ncrashed@gmail.com+copyright: 2016 Anton Gushcha+category: Game+build-type: Simple+cabal-version: >=1.10+extra-source-files:+ README.md+ CHANGELOG.md+ stack.yaml++library+ hs-source-dirs: src+ exposed-modules:+ Game.GoreAndAsh.LambdaCube+ Game.GoreAndAsh.LambdaCube.API+ Game.GoreAndAsh.LambdaCube.Module+ Game.GoreAndAsh.LambdaCube.State++ default-language: Haskell2010+ build-depends: base >= 4.7 && < 5+ , containers >= 0.5.6.2+ , deepseq >= 1.4.1.1+ , exceptions >= 0.8.2.1+ , gore-and-ash >= 1.2.1.0+ , hashable >= 1.2.4.0+ , lambdacube-compiler >= 0.5.0.1+ , lambdacube-gl >= 0.5.0.5+ , mtl >= 2.2.1+ , text >= 1.2.2.0+ , unordered-containers >= 0.2.5.1++ default-extensions:+ BangPatterns+ DeriveGeneric+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ RecordWildCards+ ScopedTypeVariables+ TypeFamilies+ UndecidableInstances++Flag examples+ Description: Enable building of examples+ Default: False++executable gore-and-ash-lambdacube-example01+ if flag(examples)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: examples/01, examples/shared+ main-is: Main.hs+ default-language: Haskell2010+ other-modules: Core+ FPS+ build-depends: base >= 4.7 && < 5+ , containers >= 0.5.6.2+ , deepseq >= 1.4.1.1+ , exceptions >= 0.8.2.1+ , GLFW-b >= 1.4.7.3+ , gore-and-ash >= 1.2.1.0+ , gore-and-ash-glfw >= 1.1.0.0+ , gore-and-ash-lambdacube+ , JuicyPixels >= 3.2.7+ , lambdacube-compiler >= 0.5.0.1+ , lambdacube-gl >= 0.5.0.5+ , mtl >= 2.2.1+ , text >= 1.2.2.0+ , transformers >= 0.4.2.0+ , vector >= 0.11.0.0++ default-extensions:+ Arrows+ BangPatterns+ DataKinds+ DeriveGeneric+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ OverloadedStrings+ RecordWildCards+ TypeFamilies+ UndecidableInstances++ ghc-options: -threaded++executable gore-and-ash-lambdacube-example02+ if flag(examples)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: examples/02, examples/shared+ main-is: Main.hs+ default-language: Haskell2010+ other-modules: Core+ FPS+ Matrix+ build-depends: base >= 4.7 && < 5+ , containers >= 0.5.6.2+ , deepseq >= 1.4.1.1+ , exceptions >= 0.8.2.1+ , GLFW-b >= 1.4.7.3+ , gore-and-ash >= 1.2.1.0+ , gore-and-ash-glfw >= 1.1.0.0+ , gore-and-ash-lambdacube+ , JuicyPixels >= 3.2.7+ , lambdacube-compiler >= 0.5.0.1+ , lambdacube-gl >= 0.5.0.5+ , lambdacube-ir >= 0.3.0.0+ , mtl >= 2.2.1+ , text >= 1.2.2.0+ , transformers >= 0.4.2.0+ , vector >= 0.11.0.0+ , linear >= 1.20.4++ default-extensions:+ Arrows+ BangPatterns+ DataKinds+ DeriveGeneric+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ OverloadedStrings+ RecordWildCards+ TypeFamilies+ UndecidableInstances++ ghc-options: -threaded++executable gore-and-ash-lambdacube-example03+ if flag(examples)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: examples/03, examples/shared+ main-is: Main.hs+ default-language: Haskell2010+ other-modules: Core+ FPS+ Matrix+ build-depends: base >= 4.7 && < 5+ , containers >= 0.5.6.2+ , deepseq >= 1.4.1.1+ , exceptions >= 0.8.2.1+ , GLFW-b >= 1.4.7.3+ , gore-and-ash >= 1.2.1.0+ , gore-and-ash-glfw >= 1.1.0.0+ , gore-and-ash-lambdacube+ , JuicyPixels >= 3.2.7+ , lambdacube-compiler >= 0.5.0.1+ , lambdacube-gl >= 0.5.0.5+ , lambdacube-ir >= 0.3.0.0+ , mtl >= 2.2.1+ , text >= 1.2.2.0+ , transformers >= 0.4.2.0+ , vector >= 0.11.0.0+ , linear >= 1.20.4++ default-extensions:+ Arrows+ BangPatterns+ DataKinds+ DeriveGeneric+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ OverloadedStrings+ RecordWildCards+ TypeFamilies+ UndecidableInstances++ ghc-options: -threaded++executable gore-and-ash-lambdacube-example04+ if flag(examples)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: examples/04, examples/shared+ main-is: Main.hs+ default-language: Haskell2010+ other-modules: Core+ FPS+ Matrix+ build-depends: base >= 4.7 && < 5+ , containers >= 0.5.6.2+ , deepseq >= 1.4.1.1+ , exceptions >= 0.8.2.1+ , GLFW-b >= 1.4.7.3+ , gore-and-ash >= 1.2.1.0+ , gore-and-ash-glfw >= 1.1.0.0+ , gore-and-ash-lambdacube+ , JuicyPixels >= 3.2.7+ , lambdacube-compiler >= 0.5.0.1+ , lambdacube-gl >= 0.5.0.5+ , lambdacube-ir >= 0.3.0.0+ , mtl >= 2.2.1+ , text >= 1.2.2.0+ , transformers >= 0.4.2.0+ , vector >= 0.11.0.0+ , linear >= 1.20.4++ default-extensions:+ Arrows+ BangPatterns+ DataKinds+ DeriveGeneric+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ OverloadedStrings+ RecordWildCards+ TypeFamilies+ UndecidableInstances++ ghc-options: -threaded
+ src/Game/GoreAndAsh/LambdaCube.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-|+Module : Game.GoreAndAsh.LambdaCube+Description : Core module for embedding concurrent IO actions into main loop.+Copyright : (c) Anton Gushcha, 2016+License : BSD3+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : POSIX++The core module contains API for something into main game loop for Gore&Ash.++The module does not depend on any other core modules, so 'LambdaCubeT' could be placed at any place in monad stack.++The module is not pure within first phase (see 'ModuleStack' docs), therefore only 'IO' can be used as end monad.++Example of embedding:++@+-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [LambdaCubeT ... other modules ... ] IO+newtype AppState = AppState (ModuleState AppStack)+ deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadLambdaCube ... other modules monads ... )++instance GameModule AppMonad AppState where + type ModuleState AppMonad = AppState+ runModule (AppMonad m) (AppState s) = do + (a, s') <- runModule m s + return (a, AppState s')+ newModuleState = AppState <$> newModuleState+ withModule _ = withModule (Proxy :: Proxy AppStack)+ cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+@++-}+module Game.GoreAndAsh.LambdaCube(+ -- * Low-level+ LambdaCubeState+ , LambdaCubeT + , MonadLambdaCube(..)+ , LambdaCubeException(..)+ , PipelineId+ , StorageId+ ) where++-- for docs+import Game.GoreAndAsh++import Game.GoreAndAsh.LambdaCube.API as X +import Game.GoreAndAsh.LambdaCube.Module as X +import Game.GoreAndAsh.LambdaCube.State as X
+ src/Game/GoreAndAsh/LambdaCube/API.hs view
@@ -0,0 +1,134 @@+{-|+Module : Game.GoreAndAsh.LambdaCube.API+Description : Monadic and arrow API for module+Copyright : (c) Anton Gushcha, 2016+License : BSD3+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.LambdaCube.API(+ MonadLambdaCube(..)+ , LambdaCubeException(..)+ ) where++import Control.Monad.Catch (throwM, MonadThrow)+import Control.Monad.State.Strict+import Control.Monad.Writer (Writer)++import LambdaCube.Compiler as LambdaCube+import LambdaCube.GL as LambdaCubeGL++import Game.GoreAndAsh.LambdaCube.Module+import Game.GoreAndAsh.LambdaCube.State++-- | Low level monadic API for module.+class (MonadIO m, MonadThrow m) => MonadLambdaCube m where+ -- | Update viewport size for rendering engine+ -- Should be called when window size is changed (or every frame)+ lambdacubeUpdateSize :: Word -- ^ Width of screen in pixels+ -> Word -- ^ Height of screen in pixels+ -> m ()++ -- | Compile and register new pipeline.+ --+ -- Throws: 'PipeLineCompileFailed' or 'PipeLineAlreadyRegistered' when failed.+ lambdacubeAddPipeline ::+ [FilePath] -- ^ Where to find LC modules+ -> String -- ^ Name of main module (without .lc)+ -> PipelineId -- ^ Name of pipeline to register+ -> Writer PipelineSchema a -- ^ Pipeline inputs description+ -> m ()++ -- | Removes pipeline from engine, deallocates all storages for rendering storages+ --+ -- Note: if pipeline with the name doesn't exists, do nothing.+ lambdacubeDeletePipeline :: PipelineId -> m ()++ -- | Creates new storage (corresponding to one game object)+ --+ -- Note: if pipeline not found, throws 'PipeLineNotFound'+ lambdacubeCreateStorage :: PipelineId -> m (StorageId, GLStorage)++ -- | Removes storage for pipeline, deallocates it+ --+ -- Note: if storage with the id doesn't exists, do nothing+ lambdacubeDeleteStorage :: StorageId -> m ()++ -- | Getting storage by ID+ --+ -- Throws 'StorageNotFound' if no storage found+ lambdacubeGetStorage :: StorageId -> m GLStorage++ -- | Adds storage to rendering queue+ lambdacubeRenderStorageLast :: StorageId -> m ()++ -- | Adds storage to rendering queue+ lambdacubeRenderStorageFirst :: StorageId -> m ()++ -- | Removes storage from rendering queue+ lambdacubeStopRendering :: StorageId -> m ()++instance {-# OVERLAPPING #-} (MonadIO m, MonadThrow m) => MonadLambdaCube (LambdaCubeT s m) where+ lambdacubeUpdateSize !w !h = do+ s <- get+ liftIO $ updateStateViewportSize w h s++ lambdacubeAddPipeline !ps !mn !pid !pwr = do+ s <- get+ when (isPipelineRegisteredInternal pid s) . throwM . PipeLineAlreadyRegistered $! pid+ mpd <- liftIO $ LambdaCube.compileMain ps OpenGL33 mn+ case mpd of+ Left err -> throwM . PipeLineCompileFailed mn pid $! "compile error:\n" ++ show err+ Right pd -> do+ let sch = makeSchema pwr+ r <- liftIO $ LambdaCubeGL.allocRenderer pd+ put $! registerPipelineInternal pid pd sch r s++ lambdacubeDeletePipeline !i = do+ s <- get+ s' <- liftIO $ unregisterPipelineInternal i s+ put s'++ lambdacubeCreateStorage !i = do+ s <- get+ case getPipelineSchemeInternal i s of+ Nothing -> throwM . PipeLineNotFound $! i+ Just sch -> do+ storage <- liftIO $ LambdaCubeGL.allocStorage sch+ si <- state $ registerStorageInternal i storage+ return (si, storage)++ lambdacubeDeleteStorage !i = do+ s <- get+ s' <- liftIO $ unregisterStorageInternal i s+ put s'++ lambdacubeGetStorage !si = do+ s <- get+ case getStorageInternal si s of+ Nothing -> throwM . StorageNotFound $! si+ Just storage -> return storage++ lambdacubeRenderStorageLast !si = do+ s <- get+ put $! renderStorageLastInternal si s++ lambdacubeRenderStorageFirst !si = do+ s <- get+ put $! renderStorageFirstInternal si s++ lambdacubeStopRendering !si = do+ s <- get+ put $! stopRenderingInternal si s++instance {-# OVERLAPPABLE #-} (MonadIO (mt m), MonadThrow (mt m), MonadLambdaCube m, MonadTrans mt) => MonadLambdaCube (mt m) where+ lambdacubeUpdateSize a b = lift $ lambdacubeUpdateSize a b+ lambdacubeAddPipeline a b c d = lift $ lambdacubeAddPipeline a b c d+ lambdacubeDeletePipeline a = lift $ lambdacubeDeletePipeline a+ lambdacubeCreateStorage a = lift $ lambdacubeCreateStorage a+ lambdacubeDeleteStorage a = lift $ lambdacubeDeleteStorage a+ lambdacubeGetStorage a = lift $ lambdacubeGetStorage a+ lambdacubeRenderStorageLast a = lift $ lambdacubeRenderStorageLast a+ lambdacubeRenderStorageFirst a = lift $ lambdacubeRenderStorageFirst a+ lambdacubeStopRendering a = lift $ lambdacubeStopRendering a
+ src/Game/GoreAndAsh/LambdaCube/Module.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module : Game.GoreAndAsh.LambdaCube.Module+Description : Monad transformer and instance for core module+Copyright : (c) Anton Gushcha, 2016+License : BSD3+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.LambdaCube.Module(+ LambdaCubeT(..)+ ) where++import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.State.Strict+import Data.Proxy ++import Game.GoreAndAsh+import Game.GoreAndAsh.LambdaCube.State++import LambdaCube.GL as LambdaCubeGL++-- | Monad transformer of the core module.+--+-- [@s@] - State of next core module in modules chain;+--+-- [@m@] - Next monad in modules monad stack;+--+-- [@a@] - Type of result value;+--+-- How to embed module:+-- +-- @+-- type AppStack = ModuleStack [LambdaCubeT, ... other modules ... ] IO+--+-- newtype AppMonad a = AppMonad (AppStack a)+-- deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadLambdaCube)+-- @+--+-- The module is not pure within first phase (see 'ModuleStack' docs), therefore only 'IO' can be used as end monad.+newtype LambdaCubeT s m a = LambdaCubeT { runLambdaCubeT :: StateT (LambdaCubeState s) m a }+ deriving (Functor, Applicative, Monad, MonadState (LambdaCubeState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)++instance (MonadIO m, MonadThrow m, GameModule m s) => GameModule (LambdaCubeT s m) (LambdaCubeState s) where + type ModuleState (LambdaCubeT s m) = LambdaCubeState s+ runModule (LambdaCubeT m) s = do+ ((a, s'), nextState) <- runModule runModuleState (lambdacubeNextState s)+ return (a, s' {+ lambdacubeNextState = nextState + }) + where+ runModuleState = flip runStateT s $ do + a <- m + renderStorages =<< get+ return a++ newModuleState = emptyLambdaCubeState <$> newModuleState+ withModule _ io = withModule (Proxy :: Proxy m) io+ cleanupModule = freeLambdaCubeState++-- | Render all queued storages+renderStorages :: (MonadIO m, MonadThrow m) => LambdaCubeState s -> m ()+renderStorages s@LambdaCubeState{..} = mapM_ renderStorage lambdacubeRenderOrder+ where+ renderStorage si = case getStorageInternal si s of + Nothing -> return ()+ Just storage -> case getRendererInternal (storageScheme si) s of + Nothing -> return ()+ Just renderer -> do + mres <- liftIO $ LambdaCubeGL.setStorage renderer storage+ case mres of + Just er -> throwM $! PipeLineIncompatible si er+ Nothing -> liftIO $ LambdaCubeGL.renderFrame renderer
+ src/Game/GoreAndAsh/LambdaCube/State.hs view
@@ -0,0 +1,227 @@+{-|+Module : Game.GoreAndAsh.LambdaCube.State+Description : Internal state of core module+Copyright : (c) Anton Gushcha, 2016+License : BSD3+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Game.GoreAndAsh.LambdaCube.State(+ LambdaCubeState(..)+ , PipelineId+ , StorageId(..)+ , LambdaCubeException(..)+ , emptyLambdaCubeState+ , freeLambdaCubeState+ -- | Internal API+ , updateStateViewportSize+ , isPipelineRegisteredInternal+ , registerPipelineInternal+ , unregisterPipelineInternal+ , getPipelineSchemeInternal+ , registerStorageInternal+ , unregisterStorageInternal+ , getStorageInternal+ , getRendererInternal+ , renderStorageLastInternal+ , renderStorageFirstInternal+ , stopRenderingInternal+ ) where++import Control.DeepSeq+import Control.Exception.Base (Exception)+import Data.Hashable+import Data.Text +import GHC.Generics (Generic)++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H ++import Data.Sequence (Seq)+import qualified Data.Sequence as S ++import LambdaCube.Compiler as LambdaCube+import LambdaCube.GL as LambdaCubeGL++-- | Exception type that could be thrown by the module+data LambdaCubeException =+ -- | Thrown when a pipeline compilation failed, first is pipeline main module, last is error message+ PipeLineCompileFailed String PipelineId String+ -- | Thrown when tries to register the same pipeline twice+ | PipeLineAlreadyRegistered PipelineId+ -- | Trhown when tries to create storage for unregistered pipeline+ | PipeLineNotFound PipelineId + -- | Thrown when tries to get unregistered storage + | StorageNotFound StorageId + -- | Thrown when failed to bind pipeline to context, contains pipeline name and error message+ | PipeLineIncompatible StorageId String+ deriving (Generic, Show)++instance Exception LambdaCubeException++-- | ID to uniquely identify LambdaCube rednering pipeline+type PipelineId = Text ++-- | ID to uniquely identify LambdaCube storage+data StorageId = StorageId { + storageId :: !Int + , storageScheme :: !PipelineId+ }+ deriving (Generic, Eq, Show)++instance NFData StorageId +instance Hashable StorageId++-- | Check is storage binded to specified pipeline+isPipelineStorage :: PipelineId -> StorageId -> Bool +isPipelineStorage pid sid = storageScheme sid == pid++-- | All info ablut pipeline+data PipelineInfo = PipelineInfo {+ pipeInfoRenderer :: !GLRenderer+, pipeInfoSchema :: !PipelineSchema+, pipeInfoPipeline :: !Pipeline +} deriving Generic ++instance NFData PipelineInfo++-- | Internal state of core module+--+-- [@s@] - state of next module, they are chained until bottom, that is usually+-- an empty data type.+data LambdaCubeState s = LambdaCubeState {+ -- | Module storage for LambdaCube pipelines+ lambdacubePipelines :: !(HashMap PipelineId PipelineInfo)+ -- | Module storage for LambdaCube storages+, lambdacubeStorages :: !(HashMap StorageId GLStorage)+ -- | Defines in which order to render each object at next frame+, lambdacubeRenderOrder :: !(Seq StorageId)+ -- | Next storage id to use+, lambdacubeNextStorageId :: !Int+ -- | Next module state in chain of modules+, lambdacubeNextState :: !s+} deriving (Generic)++instance NFData s => NFData (LambdaCubeState s)++instance NFData PipelineSchema where + rnf a = a `seq` () ++instance NFData GLStorage where + rnf a = a `seq` () ++instance NFData GLRenderer where + rnf a = a `seq` () ++instance NFData Pipeline where + rnf a = a `seq` () ++-- | Create inital state of the core module+--+-- [@s@] - state of next module+emptyLambdaCubeState :: s -> LambdaCubeState s +emptyLambdaCubeState s = LambdaCubeState {+ lambdacubePipelines = H.empty + , lambdacubeStorages = H.empty + , lambdacubeRenderOrder = S.empty+ , lambdacubeNextStorageId = 0+ , lambdacubeNextState = s+ }++-- | Release module state resources+freeLambdaCubeState :: LambdaCubeState s -> IO ()+freeLambdaCubeState LambdaCubeState{..} = do + mapM_ LambdaCubeGL.disposeStorage lambdacubeStorages+ mapM_ (LambdaCubeGL.disposeRenderer . pipeInfoRenderer) lambdacubePipelines++-- | Update viewport size of all storages+updateStateViewportSize :: Word -> Word -> LambdaCubeState s -> IO ()+updateStateViewportSize w h LambdaCubeState{..} = + mapM_ (\s -> LambdaCubeGL.setScreenSize s w h) $ H.elems lambdacubeStorages++-- | Returns True if given pipeline is already exists+isPipelineRegisteredInternal :: PipelineId -> LambdaCubeState s -> Bool +isPipelineRegisteredInternal pid LambdaCubeState{..} = case H.lookup pid lambdacubePipelines of + Nothing -> False + Just _ -> True ++-- | Register new pipeline with renderer in module+registerPipelineInternal :: PipelineId -> Pipeline -> PipelineSchema -> GLRenderer -> LambdaCubeState s -> LambdaCubeState s+registerPipelineInternal i ps pl r s = s {+ lambdacubePipelines = H.insert i info . lambdacubePipelines $! s+ }+ where + info = PipelineInfo {+ pipeInfoRenderer = r + , pipeInfoSchema = pl+ , pipeInfoPipeline = ps+ }++-- | Removes pipeline from state and deletes it, also destroys all storages of the pipeline+unregisterPipelineInternal :: PipelineId -> LambdaCubeState s -> IO (LambdaCubeState s)+unregisterPipelineInternal i s =+ case H.lookup i . lambdacubePipelines $! s of + Nothing -> return s+ Just (PipelineInfo{..}) -> do + let storages = H.filterWithKey (\k _ -> isPipelineStorage i k) . lambdacubeStorages $! s+ mapM_ LambdaCubeGL.disposeStorage . H.elems $! storages+ LambdaCubeGL.disposeRenderer pipeInfoRenderer + return $ s {+ lambdacubePipelines = H.delete i . lambdacubePipelines $! s+ , lambdacubeStorages = H.filterWithKey (\k _ -> not $ isPipelineStorage i k) . lambdacubeStorages $! s+ }++-- | Getter of pipeline scheme+getPipelineSchemeInternal :: PipelineId -> LambdaCubeState s -> Maybe PipelineSchema+getPipelineSchemeInternal i LambdaCubeState{..} = fmap pipeInfoSchema . H.lookup i $! lambdacubePipelines++-- | Registering gl storage for given pipeline+registerStorageInternal :: PipelineId -> GLStorage -> LambdaCubeState s -> (StorageId, LambdaCubeState s)+registerStorageInternal pid storage s = (i, s')+ where+ i = StorageId {+ storageId = lambdacubeNextStorageId s + , storageScheme = pid + }++ s' = s { + lambdacubeNextStorageId = lambdacubeNextStorageId s + 1 + , lambdacubeStorages = H.insert i storage . lambdacubeStorages $! s+ }++-- | Remove and deallocate storage+unregisterStorageInternal :: StorageId -> LambdaCubeState s -> IO (LambdaCubeState s)+unregisterStorageInternal i s = case H.lookup i . lambdacubeStorages $! s of + Nothing -> return s+ Just storage -> do + LambdaCubeGL.disposeStorage storage + return $! s {+ lambdacubeStorages = H.delete i . lambdacubeStorages $! s + }++getRendererInternal :: PipelineId -> LambdaCubeState s -> Maybe GLRenderer+getRendererInternal i LambdaCubeState{..} = fmap pipeInfoRenderer $! H.lookup i lambdacubePipelines++-- | Find storage in state+getStorageInternal :: StorageId -> LambdaCubeState s -> Maybe GLStorage+getStorageInternal i LambdaCubeState{..} = H.lookup i lambdacubeStorages++-- | Puts storage at end of rendering queue+renderStorageLastInternal :: StorageId -> LambdaCubeState s -> LambdaCubeState s +renderStorageLastInternal i s = s {+ lambdacubeRenderOrder = S.filter (/= i) (lambdacubeRenderOrder s) S.|> i+ }++-- | Puts storage at begining of rendering queue+renderStorageFirstInternal :: StorageId -> LambdaCubeState s -> LambdaCubeState s+renderStorageFirstInternal i s = s {+ lambdacubeRenderOrder = i S.<| S.filter (/= i) (lambdacubeRenderOrder s) + }++-- | Removes storage from rendering queue+stopRenderingInternal :: StorageId -> LambdaCubeState s -> LambdaCubeState s+stopRenderingInternal i s = s {+ lambdacubeRenderOrder = S.filter (/= i) (lambdacubeRenderOrder s) + }
+ stack.yaml view
@@ -0,0 +1,47 @@+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-7.9++# Local packages, usually specified by relative directory name+packages:+- '.'++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps:+- gore-and-ash-1.2.2.0+- gore-and-ash-glfw-1.1.2.0+- indentation-0.2.1.1+- lambdacube-compiler-0.6.0.0+- lambdacube-gl-0.5.1.2+- lambdacube-ir-0.3.0.1+- pretty-compact-1.0+- QuickCheck-2.8.2+- text-1.2.2.0+- vect-0.4.7+- wavefront-0.7.0.2+- time-1.5.0.1++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 1.0.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]++# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor