diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.2.0.0 +======= + +* Adapted to `lamdacube-compiler-0.6.0.0` and GHC 8.0.1 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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: +``` + +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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/01/Main.hs b/examples/01/Main.hs new file mode 100644 --- /dev/null +++ b/examples/01/Main.hs @@ -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 + } diff --git a/examples/02/Main.hs b/examples/02/Main.hs new file mode 100644 --- /dev/null +++ b/examples/02/Main.hs @@ -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 diff --git a/examples/02/Matrix.hs b/examples/02/Matrix.hs new file mode 100644 --- /dev/null +++ b/examples/02/Matrix.hs @@ -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) diff --git a/examples/03/Main.hs b/examples/03/Main.hs new file mode 100644 --- /dev/null +++ b/examples/03/Main.hs @@ -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 diff --git a/examples/03/Matrix.hs b/examples/03/Matrix.hs new file mode 100644 --- /dev/null +++ b/examples/03/Matrix.hs @@ -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) diff --git a/examples/04/Main.hs b/examples/04/Main.hs new file mode 100644 --- /dev/null +++ b/examples/04/Main.hs @@ -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 diff --git a/examples/04/Matrix.hs b/examples/04/Matrix.hs new file mode 100644 --- /dev/null +++ b/examples/04/Matrix.hs @@ -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) diff --git a/examples/shared/Core.hs b/examples/shared/Core.hs new file mode 100644 --- /dev/null +++ b/examples/shared/Core.hs @@ -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 diff --git a/examples/shared/FPS.hs b/examples/shared/FPS.hs new file mode 100644 --- /dev/null +++ b/examples/shared/FPS.hs @@ -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 diff --git a/gore-and-ash-lambdacube.cabal b/gore-and-ash-lambdacube.cabal new file mode 100644 --- /dev/null +++ b/gore-and-ash-lambdacube.cabal @@ -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 diff --git a/src/Game/GoreAndAsh/LambdaCube.hs b/src/Game/GoreAndAsh/LambdaCube.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/LambdaCube.hs @@ -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 diff --git a/src/Game/GoreAndAsh/LambdaCube/API.hs b/src/Game/GoreAndAsh/LambdaCube/API.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/LambdaCube/API.hs @@ -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 diff --git a/src/Game/GoreAndAsh/LambdaCube/Module.hs b/src/Game/GoreAndAsh/LambdaCube/Module.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/LambdaCube/Module.hs @@ -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 diff --git a/src/Game/GoreAndAsh/LambdaCube/State.hs b/src/Game/GoreAndAsh/LambdaCube/State.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/LambdaCube/State.hs @@ -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) + } diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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