├── assets ├── font.png └── examples │ ├── crate.png │ ├── kenpixel.ttf │ ├── stereol.wav │ ├── pong-bloop.wav │ ├── crate1_bump.png │ ├── crate1_normal.png │ ├── crate1_diffuse.png │ └── cube.obj ├── Setup.lhs ├── stack.yaml ├── .gitignore ├── lib ├── Lambency │ ├── Shader │ │ ├── Optimization.hs │ │ ├── Var.hs │ │ ├── Optimization │ │ │ └── RemoveUnused.hs │ │ ├── Base.hs │ │ ├── Program.hs │ │ └── OpenGL.hs │ ├── GameSession.hs │ ├── Loaders │ │ └── Utils.hs │ ├── ResourceLoader.hs │ ├── Utils.hs │ ├── Renderer.hs │ ├── Sound.hs │ ├── Loaders.hs │ ├── Texture.hs │ ├── Bounds.hs │ ├── Light.hs │ ├── Mesh.hs │ ├── Renderer │ │ └── OpenGL │ │ │ └── Texture.hs │ ├── Vertex.hs │ ├── Material.hs │ ├── GameLoop.hs │ ├── Font.hs │ ├── GameObject.hs │ ├── Transform.hs │ ├── UI.hs │ ├── Sprite.hs │ └── Camera.hs └── Lambency.hs ├── LICENSE ├── README.md ├── tools └── OBJViewer.hs ├── examples ├── MovingSquare.hs ├── Shooter.hs ├── CubeDemo.hs └── Pong.hs ├── lambency.cabal └── .travis.yml /assets/font.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/font.png -------------------------------------------------------------------------------- /assets/examples/crate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/crate.png -------------------------------------------------------------------------------- /assets/examples/kenpixel.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/kenpixel.ttf -------------------------------------------------------------------------------- /assets/examples/stereol.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/stereol.wav -------------------------------------------------------------------------------- /assets/examples/pong-bloop.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/pong-bloop.wav -------------------------------------------------------------------------------- /assets/examples/crate1_bump.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/crate1_bump.png -------------------------------------------------------------------------------- /assets/examples/crate1_normal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/crate1_normal.png -------------------------------------------------------------------------------- /assets/examples/crate1_diffuse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Mokosha/Lambency/HEAD/assets/examples/crate1_diffuse.png -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main where 3 | > import Distribution.Simple 4 | > main :: IO () 5 | > main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - . 3 | 4 | flags: 5 | lambency: 6 | examples: true 7 | 8 | # build: 9 | # library-profiling: true 10 | # executable-profiling: true 11 | 12 | resolver: nightly-2024-01-12 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Haskell things 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virthualenv 9 | *cabal.sandbox.config 10 | .stack-work/** 11 | stack.yaml.lock 12 | 13 | # Emacs things 14 | *~ 15 | \#* 16 | *\# 17 | 18 | # OS X things 19 | .DS_Store -------------------------------------------------------------------------------- /lib/Lambency/Shader/Optimization.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Shader.Optimization ( 2 | module Lambency.Shader.Optimization.RemoveUnused 3 | ) where 4 | 5 | -------------------------------------------------------------------------------- 6 | -- !TODO! Eventually create an 'optimize' function that takes a program AST and 7 | -- returns an optimized AST. Things to do with the optimizer: 8 | -- 1. Remove unused variables 9 | -- 2. Collapse const expressions 10 | -- 3. Identify common patterns and reduce their overhead (e.g. if you swizzle 11 | -- a swizzle, no need to swizzle twice) 12 | 13 | import Lambency.Shader.Optimization.RemoveUnused 14 | -------------------------------------------------------------------------------- /lib/Lambency/GameSession.hs: -------------------------------------------------------------------------------- 1 | module Lambency.GameSession ( 2 | TimeStep, GameSession, 3 | physicsDeltaTime, physicsDeltaUTC, mkGameSession 4 | ) where 5 | 6 | -------------------------------------------------------------------------------- 7 | import qualified Control.Wire as W 8 | 9 | import GHC.Float 10 | 11 | import Data.Time 12 | 13 | import Lambency.Types 14 | -------------------------------------------------------------------------------- 15 | 16 | -- The physics framerate in frames per second 17 | physicsDeltaTime :: Double 18 | physicsDeltaTime = 1.0 / 60.0 19 | 20 | physicsDeltaUTC :: NominalDiffTime 21 | physicsDeltaUTC = fromRational . toRational $ physicsDeltaTime 22 | 23 | mkGameSession :: GameSession 24 | mkGameSession = W.countSession (double2Float physicsDeltaTime) W.<*> W.pure () 25 | -------------------------------------------------------------------------------- /assets/examples/cube.obj: -------------------------------------------------------------------------------- 1 | # Unit-volume cube with the same texture coordinates on each face. 2 | # 3 | # Created by Morgan McGuire and released into the Public Domain on 4 | # July 16, 2011. 5 | # 6 | # http://graphics.cs.williams.edu/data 7 | 8 | mtllib default.mtl 9 | 10 | v -0.5 0.5 -0.5 11 | v -0.5 0.5 0.5 12 | v 0.5 0.5 0.5 13 | v 0.5 0.5 -0.5 14 | v -0.5 -0.5 -0.5 15 | v -0.5 -0.5 0.5 16 | v 0.5 -0.5 0.5 17 | v 0.5 -0.5 -0.5 18 | 19 | vt 0 1 20 | vt 0 0 21 | vt 1 0 22 | vt 1 1 23 | 24 | vn 0 1 0 25 | vn -1 0 0 26 | vn 1 0 0 27 | vn 0 0 -1 28 | vn 0 0 1 29 | vn 0 -1 0 30 | 31 | g cube 32 | usemtl default 33 | 34 | f -8/-4/-6 -7/-3/-6 -6/-2/-6 35 | f -8/-4/-6 -6/-2/-6 -5/-1/-6 36 | f -8/-4/-5 -4/-3/-5 -3/-2/-5 37 | f -8/-4/-5 -3/-2/-5 -7/-1/-5 38 | f -6/-4/-4 -2/-3/-4 -1/-2/-4 39 | f -6/-4/-4 -1/-2/-4 -5/-1/-4 40 | f -5/-4/-3 -1/-3/-3 -4/-2/-3 41 | f -5/-4/-3 -4/-2/-3 -8/-1/-3 42 | f -7/-4/-2 -3/-3/-2 -2/-2/-2 43 | f -7/-4/-2 -2/-2/-2 -6/-1/-2 44 | f -3/-4/-1 -4/-3/-1 -1/-2/-1 45 | f -3/-4/-1 -1/-2/-1 -2/-1/-1 46 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 Pavel Krajcevski 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /lib/Lambency/Loaders/Utils.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Loaders.Utils where 2 | 3 | -------------------------------------------------------------------------------- 4 | #if __GLASGOW_HASKELL__ <= 708 5 | import Control.Applicative hiding ((<|>), many) 6 | #endif 7 | 8 | import Text.Parsec 9 | import Text.Parsec.Text (Parser) 10 | 11 | import Linear.V2 12 | import Linear.V3 13 | -------------------------------------------------------------------------------- 14 | 15 | type Vec2f = V2 Float 16 | type Vec3f = V3 Float 17 | 18 | sign :: Parser Float 19 | sign = option 1 $ do s <- oneOf "+-" 20 | return $ if s == '-' then (-1.0) else 1.0 21 | 22 | float :: Parser Float 23 | float = do 24 | spaces 25 | sgn <- sign 26 | t <- option "0" $ many digit 27 | _ <- if t == [] then (char '.') else ((try $ char '.') <|> (return ' ')) 28 | d <- option "0" $ many1 digit 29 | let 30 | denom :: Float 31 | denom = if d == "0" then 1.0 else (fromIntegral $ length d) 32 | e <- option 0 $ do 33 | esign <- char 'e' >> sign 34 | ((*esign) . read) <$> (many1 digit) 35 | 36 | return $ ((read t) + ((read d) / (10 ** denom))) * (10 ** e) * sgn 37 | 38 | vector2 :: Parser Vec2f 39 | vector2 = V2 <$> float <*> float 40 | 41 | vector3 :: Parser Vec3f 42 | vector3 = V3 <$> float <*> float <*> float 43 | 44 | -------------------------------------------------------------------------------- /lib/Lambency/ResourceLoader.hs: -------------------------------------------------------------------------------- 1 | module Lambency.ResourceLoader ( 2 | runResourceLoader 3 | , runLoaderWith 4 | ) where 5 | 6 | -------------------------------------------------------------------------------- 7 | import Control.Monad.Reader 8 | import Control.Monad.Writer 9 | 10 | import Lambency.Types 11 | -------------------------------------------------------------------------------- 12 | 13 | -- Takes a function that uses a value within a context in order to pass that 14 | -- value to a different resource loader. As an example: 15 | -- Vector.unsafeWith dat $ \ptr -> loadTexture ptr 16 | -- :: IO Texture 17 | -- Vector.unsafeWith dat 18 | -- :: (Ptr -> IO Texture) -> IO Texture 19 | -- loadTextureAsResource 20 | -- :: Ptr -> ResourceLoader Texture 21 | -- runLoaderWith (Vector.unsafeWith dat) loadTextureAsResource 22 | -- :: ResourceLoader Texture 23 | runLoaderWith :: ((a -> IO (b, IO ())) -> IO (b, IO ())) -> (a -> ResourceLoader b) 24 | -> ResourceLoader b 25 | runLoaderWith ioPrg rlGen = ResourceLoader . ReaderT $ \rr -> do 26 | (result, unload) <- liftIO $ ioPrg $ \ptr -> do 27 | let (ResourceLoader rlPrg) = rlGen ptr 28 | runWriterT (runReaderT rlPrg rr) 29 | WriterT (return (result, unload)) 30 | 31 | runResourceLoader :: Renderer -> ResourceLoader a -> IO (a, IO ()) 32 | runResourceLoader r (ResourceLoader prg) = runWriterT (runReaderT prg r) 33 | -------------------------------------------------------------------------------- /lib/Lambency/Shader/Var.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Shader.Var where 2 | 3 | -------------------------------------------------------------------------------- 4 | import Lambency.Shader.Base 5 | 6 | import Linear 7 | -------------------------------------------------------------------------------- 8 | 9 | matrix2Ty :: ShaderVarTy (M22 Float) 10 | matrix2Ty = ShaderVarTy Matrix2Ty 11 | 12 | matrix3Ty :: ShaderVarTy (M33 Float) 13 | matrix3Ty = ShaderVarTy Matrix3Ty 14 | 15 | matrix4Ty :: ShaderVarTy (M44 Float) 16 | matrix4Ty = ShaderVarTy Matrix4Ty 17 | 18 | vector2fTy :: ShaderVarTy (V2 Float) 19 | vector2fTy = ShaderVarTy Vector2Ty 20 | 21 | vector3fTy :: ShaderVarTy (V3 Float) 22 | vector3fTy = ShaderVarTy Vector3Ty 23 | 24 | vector4fTy :: ShaderVarTy (V4 Float) 25 | vector4fTy = ShaderVarTy Vector4Ty 26 | 27 | vector2iTy :: ShaderVarTy (V2 Int) 28 | vector2iTy = ShaderVarTy Vector2Ty 29 | 30 | vector3iTy :: ShaderVarTy (V3 Int) 31 | vector3iTy = ShaderVarTy Vector3Ty 32 | 33 | vector4iTy :: ShaderVarTy (V4 Int) 34 | vector4iTy = ShaderVarTy Vector4Ty 35 | 36 | intTy :: ShaderVarTy Int 37 | intTy = ShaderVarTy IntTy 38 | 39 | floatTy :: ShaderVarTy Float 40 | floatTy = ShaderVarTy FloatTy 41 | 42 | sampler1DTy :: ShaderVarTy Sampler1D 43 | sampler1DTy = ShaderVarTy Sampler1DTy 44 | 45 | sampler2DTy :: ShaderVarTy Sampler2D 46 | sampler2DTy = ShaderVarTy Sampler2DTy 47 | 48 | sampler3DTy :: ShaderVarTy Sampler3D 49 | sampler3DTy = ShaderVarTy Sampler3DTy 50 | 51 | shadow2DTy :: ShaderVarTy Shadow2D 52 | shadow2DTy = ShaderVarTy Shadow2DTy 53 | -------------------------------------------------------------------------------- /lib/Lambency/Shader/Optimization/RemoveUnused.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Shader.Optimization.RemoveUnused ( 2 | isShaderVarUsed, 3 | ) where 4 | 5 | -------------------------------------------------------------------------------- 6 | import Lambency.Shader.Base 7 | -------------------------------------------------------------------------------- 8 | 9 | -- !TODO! Eventually optimize by removing unused statements based on what variables 10 | -- apear in the RHS of the statement expressions 11 | 12 | isUsedInExpr :: ShaderVarRep -> ExprRep -> Bool 13 | isUsedInExpr v (VarExpr v') = v == v' 14 | isUsedInExpr _ (ConstExpr _) = False 15 | isUsedInExpr v (SwizzleExpr e _) = isUsedInExpr v e 16 | isUsedInExpr v (Unary _ e) = isUsedInExpr v e 17 | isUsedInExpr v (Binary _ e1 e2) = any (isUsedInExpr v) [e1, e2] 18 | isUsedInExpr v (Ternary _ e1 e2 e3) = any (isUsedInExpr v) [e1, e2, e3] 19 | isUsedInExpr v (NewVec (Vec2Expr e1 e2)) = any (isUsedInExpr v) [e1, e2] 20 | isUsedInExpr v (NewVec (Vec3Expr e1 e2 e3)) = any (isUsedInExpr v) [e1, e2, e3] 21 | isUsedInExpr v (NewVec (Vec4Expr e1 e2 e3 e4)) = any (isUsedInExpr v) [e1, e2, e3, e4] 22 | 23 | isUsedInStmt :: ShaderVarRep -> Statement -> Bool 24 | isUsedInStmt _ (LocalDecl _ Nothing) = False 25 | isUsedInStmt v (LocalDecl _ (Just e)) = isUsedInExpr v e 26 | isUsedInStmt v (Assignment _ e) = isUsedInExpr v e 27 | isUsedInStmt v (SpecialAssignment _ v') = v == v' 28 | isUsedInStmt v (IfThenElse e s1 s2) = 29 | isUsedInExpr v e || isShaderVarUsed v s1 || isShaderVarUsed v s2 30 | 31 | isShaderVarUsed :: ShaderVarRep -> [Statement] -> Bool 32 | isShaderVarUsed v = any (isUsedInStmt v) 33 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Lambency [![Build Status](https://travis-ci.org/Mokosha/Lambency.svg?branch=master)](https://travis-ci.org/Mokosha/Lambency) 2 | ======== 3 | 4 | A Real-Time Rendering framework and game engine 5 | 6 | Major Dependencies 7 | -------- 8 | 9 | To get a sense of the technologies used by this library, the major dependencies are 10 | 11 | - [GLFW-b](http://hackage.haskell.org/package/GLFW-b) -- [github](https://github.com/bsl/GLFW-b) 12 | - [OpenGL](http://hackage.haskell.org/package/OpenGL) -- [github](https://github.com/haskell-opengl/OpenGL) 13 | - [OpenAL](http://hackage.haskell.org/package/OpenAL) -- [github](https://github.com/haskell-openal/OpenAL) 14 | - [JuicyPixels](http://hackage.haskell.org/package/JuicyPixels) -- [github](https://github.com/Twinside/Juicy.Pixels) 15 | - [HCodecs](http://hackage.haskell.org/package/HCodecs) -- [github](https://github.com/giorgidze/HCodecs) 16 | - [Netwire 5](http://hackage.haskell.org/package/netwire) -- [github](https://github.com/esoeylemez/netwire) 17 | - [Linear](http://hackage.haskell.org/package/linear) -- [github](https://github.com/ekmett/linear) 18 | - [FreeType](https://hackage.haskell.org/package/freetype2) -- [github](https://github.com/dagit/freetype2) 19 | 20 | Try the examples: 21 | -------- 22 | 23 | At the moment, the library is undergoing pretty massive an unstable API changes. As such, there isn't really a good "workflow". However, I will try to keep the `stack.yaml` in the root directory up to date such that the project builds from HEAD. If the stack.yaml is not present, then it should be generated via 24 | 25 | stack init . --solver 26 | 27 | If it is present, then you can simply continue with building and executing the examples: 28 | 29 | stack build --flag lambency:examples 30 | stack exec lambcubedemo 31 | -------------------------------------------------------------------------------- /lib/Lambency/Utils.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Utils ( 2 | compareZero, 3 | compareClose, 4 | destructMat4, 5 | clamp, 6 | newRange, 7 | newRangeC, 8 | -- 9 | CyclicList(..), 10 | advance, 11 | cyclicLength, 12 | cyclicFromList, 13 | cyclicToList, 14 | cycleSingleton, 15 | cycles 16 | ) where 17 | 18 | -------------------------------------------------------------------------------- 19 | import Control.Comonad 20 | 21 | import Data.Foldable 22 | 23 | import Linear.Epsilon 24 | import Linear.Metric 25 | 26 | import Prelude hiding (concat) 27 | -------------------------------------------------------------------------------- 28 | 29 | compareZero :: (Epsilon a, Metric v) => v a -> Bool 30 | compareZero x = nearZero $ (abs $ x `dot` x) 31 | 32 | compareClose :: (Ord a, Epsilon a, Metric v) => v a -> v a -> Bool 33 | compareClose x y = nearZero $ max (y `dot` y) (x `dot` x) - (x `dot` y) 34 | 35 | destructMat4 :: (Functor f, Foldable f) => f (f a) -> [a] 36 | destructMat4 = concat . (fmap toList) 37 | 38 | clamp :: Ord a => a -> a -> a -> a 39 | clamp x a b = if x < a then a else if x > b then b else x 40 | 41 | newRange :: Floating a => a -> (a, a) -> (a, a) -> a 42 | newRange x (omin, omax) (nmin, nmax) = 43 | nmin + (nmax - nmin) * ((x - omin) / (omax - omin)) 44 | 45 | newRangeC :: (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a 46 | newRangeC x o n@(nmin, nmax) = clamp (newRange x o n) nmin nmax 47 | 48 | -------------------------------------------------------------------------------- 49 | -- Cyclic lists 50 | 51 | data CyclicList a = CyclicList [a] a [a] 52 | 53 | instance Functor CyclicList where 54 | fmap f (CyclicList p c n) = CyclicList (fmap f p) (f c) (fmap f n) 55 | 56 | instance Foldable CyclicList where 57 | foldr f x (CyclicList p c n) = 58 | foldr f (f c (foldr f x $ reverse p)) n 59 | 60 | instance Traversable CyclicList where 61 | traverse f (CyclicList p c n) = 62 | CyclicList <$> 63 | (reverse <$> (traverse f $ reverse p)) <*> (f c) <*> (traverse f n) 64 | 65 | advance :: CyclicList a -> CyclicList a 66 | advance (CyclicList p c []) = let (r:rs) = reverse (c:p) in CyclicList [] r rs 67 | advance (CyclicList p c (n:ns)) = CyclicList (c:p) n ns 68 | 69 | cyclicLength :: CyclicList a -> Int 70 | cyclicLength (CyclicList x _ z) = length x + length z + 1 71 | 72 | cyclicFromList :: [a] -> CyclicList a 73 | cyclicFromList [] = error "Cannot create empty cyclic list" 74 | cyclicFromList (x:xs) = CyclicList [] x xs 75 | 76 | cyclicToList :: CyclicList a -> [a] 77 | cyclicToList (CyclicList p c n) = concat [reverse p, [c], n] 78 | 79 | cycleSingleton :: a -> CyclicList a 80 | cycleSingleton x = CyclicList [] x [] 81 | 82 | cycles :: CyclicList a -> [CyclicList a] 83 | cycles cl = let 84 | helper 0 _ = [] 85 | helper n cl' = cl' : (helper (n-1) $ advance cl') 86 | in helper (cyclicLength cl) cl 87 | 88 | instance Comonad CyclicList where 89 | extract (CyclicList _ x _) = x 90 | duplicate = cyclicFromList . cycles 91 | -------------------------------------------------------------------------------- /lib/Lambency/Renderer.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Renderer 2 | ( nullRenderer 3 | , openGLRenderer 4 | , createRenderObject 5 | , addClippedRenderAction 6 | , addTransformedRenderAction 7 | , addRenderAction 8 | , addRenderUIAction 9 | ) where 10 | 11 | -------------------------------------------------------------------------------- 12 | import Control.Arrow (second) 13 | import Control.Monad.RWS.Strict 14 | 15 | import qualified Graphics.UI.GLFW as GLFW 16 | 17 | import Lambency.Mesh 18 | import Lambency.Types 19 | import Lambency.Transform 20 | import Lambency.Vertex 21 | 22 | import Linear hiding (identity) 23 | 24 | import qualified Lambency.Renderer.OpenGL.Texture as OpenGL 25 | import qualified Lambency.Renderer.OpenGL.Render as OpenGL 26 | -------------------------------------------------------------------------------- 27 | 28 | -- !FIXME! This would probably be cleaner with lenses 29 | createClippedActions :: RenderActions -> RenderActions -> RenderActions 30 | createClippedActions clip draw = 31 | RenderActions { renderScene = RenderClipped (rs clip) (rs draw), 32 | renderUI = RenderClipped (ru clip) (ru draw) } 33 | where 34 | rs = renderScene 35 | ru = renderUI 36 | 37 | addClippedRenderAction :: GameMonad b -> (b -> GameMonad a) -> GameMonad a 38 | addClippedRenderAction clip drawWithClip = GameMonad . RWST $ \cfg input -> do 39 | -- Get the actions that render the clip 40 | (clipResult, clipInput, (clipActions, clipRenderActions)) <- 41 | runRWST (nextFrame clip) cfg input 42 | 43 | -- Get the actions that render our clipped geometry 44 | (result, finalInput, (finalActions, finalRenderActions)) <- 45 | runRWST (nextFrame $ drawWithClip clipResult) cfg clipInput 46 | 47 | -- Return with clipped actions 48 | return (result, finalInput, 49 | (clipActions ++ finalActions, 50 | createClippedActions clipRenderActions finalRenderActions)) 51 | 52 | createTransformedActions :: Transform -> RenderActions -> RenderActions 53 | createTransformedActions xf new = 54 | RenderActions { renderScene = RenderTransformed xf (renderScene new), 55 | renderUI = RenderTransformed xf (renderUI new) } 56 | 57 | addTransformedRenderAction :: Transform -> GameMonad a -> GameMonad a 58 | addTransformedRenderAction xf = censor $ second $ createTransformedActions xf 59 | 60 | addRenderAction :: Transform -> RenderObject -> GameMonad () 61 | addRenderAction xf ro = GameMonad $ 62 | tell $ ([], RenderActions (RenderTransformed xf $ RenderObjects [ro]) mempty) 63 | 64 | addRenderUIAction :: V2 Float -> RenderObject -> GameMonad () 65 | addRenderUIAction (V2 x y) ro = GameMonad $ 66 | tell $ ([], RenderActions mempty (RenderTransformed xf $ RenderObjects [ro])) 67 | where 68 | xf = translate (V3 x y (-1)) identity 69 | 70 | createRenderObject :: Vertex a => Mesh a -> Material 71 | -> ResourceLoader RenderObject 72 | createRenderObject mesh mat = do 73 | r <- ask 74 | createRO r mesh mat 75 | 76 | nullRenderer :: Renderer 77 | nullRenderer = Renderer 78 | { mkTexture = \ _ _ _ -> return $ error "null texture!" 79 | , updateTexture = \_ _ _ _ -> return () 80 | , mkDepthTexture = \_ -> return $ error "null depth texture!" 81 | , createRO = \_ _ -> return $ error "null render object!" 82 | , render = \_ _ _ -> return () 83 | } 84 | 85 | openGLRenderer :: GLFW.Window -> Renderer 86 | openGLRenderer win = Renderer 87 | { mkTexture = OpenGL.initializeTexture 88 | , updateTexture = OpenGL.updateTexture 89 | , mkDepthTexture = OpenGL.createDepthTexture 90 | , createRO = OpenGL.createRenderObject 91 | , render = OpenGL.render win 92 | } 93 | -------------------------------------------------------------------------------- /lib/Lambency/Sound.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Sound ( 2 | Sound, SoundCommand(..), 3 | initSound, 4 | freeSound, 5 | loadSound, 6 | handleCommand, 7 | startSound, stopSound 8 | ) where 9 | 10 | -------------------------------------------------------------------------------- 11 | import qualified Codec.Wav as Wav 12 | import Control.Monad.RWS.Strict 13 | 14 | import Data.Array.Storable 15 | import Data.Audio 16 | 17 | import GHC.Int 18 | 19 | import qualified Graphics.Rendering.OpenGL as GL 20 | 21 | import Lambency.Types 22 | 23 | import qualified Sound.OpenAL.AL as AL 24 | import qualified Sound.OpenAL.ALC as ALC 25 | -------------------------------------------------------------------------------- 26 | 27 | initSound :: IO () 28 | initSound = do 29 | device <- ALC.openDevice Nothing 30 | case device of 31 | Nothing -> error "Failed to find audio device" 32 | Just d -> do 33 | context <- ALC.createContext d [] 34 | ALC.currentContext GL.$= context 35 | case context of 36 | Nothing -> putStrLn "WARNING: Failed to set current audio context" 37 | Just _ -> putStrLn "Audio context successfully initiated." 38 | 39 | -- Setup source and listener... 40 | AL.listenerPosition GL.$= (GL.Vertex3 0 0 0) 41 | AL.listenerVelocity GL.$= (GL.Vector3 0 0 0) 42 | AL.orientation GL.$= (GL.Vector3 0 0 (-1), GL.Vector3 0 1 0) 43 | 44 | loadSound :: FilePath -> ResourceLoader Sound 45 | loadSound fp = do 46 | -- Generate OpenAL source 47 | (source, buffer) <- liftIO $ do 48 | src <- GL.genObjectName 49 | 50 | AL.pitch src GL.$= 1 51 | AL.sourceGain src GL.$= 1 52 | AL.sourcePosition src GL.$= (GL.Vertex3 0 0 0) 53 | AL.sourceVelocity src GL.$= (GL.Vector3 0 0 0) 54 | AL.loopingMode src GL.$= AL.OneShot 55 | 56 | -- Load wav file 57 | result <- (Wav.importFile :: FilePath -> IO (Either String (Audio Int16))) fp 58 | a <- case result of 59 | Left s -> error s 60 | Right audio -> return audio 61 | samples <- thaw (sampleData a) 62 | 63 | -- Generate OpenAL buffer 64 | buf <- GL.genObjectName 65 | withStorableArray samples $ \ptr -> do 66 | (sidx, eidx) <- getBounds samples 67 | let nSamples = (fromIntegral eidx) - (fromIntegral sidx) + 1 68 | nChannels = fromIntegral (channelNumber a) 69 | -- Stereo means multiple samples per channel 70 | mem = AL.MemoryRegion ptr (nChannels * nSamples) 71 | format = if nChannels > 1 then AL.Stereo16 else AL.Mono16 72 | freq = fromIntegral (sampleRate a) 73 | soundData = AL.BufferData mem format freq 74 | AL.bufferData buf GL.$= soundData 75 | 76 | -- Attach the src to the buffer... 77 | AL.buffer src GL.$= (Just buf) 78 | putStrLn $ "Loaded sound: " ++ (show src) 79 | 80 | return (src, buf) 81 | 82 | tell $ GL.deleteObjectName source 83 | >> GL.deleteObjectName buffer 84 | >> putStrLn ("Unloaded sound: " ++ show source) 85 | 86 | return source 87 | 88 | handleCommand :: Sound -> SoundCommand -> IO () 89 | handleCommand src StartSound = AL.play [src] 90 | handleCommand src StopSound = AL.stop [src] 91 | 92 | freeSound :: IO () 93 | freeSound = do 94 | context <- GL.get ALC.currentContext 95 | case context of 96 | Nothing -> return () 97 | Just c -> do 98 | (Just d) <- GL.get $ ALC.contextsDevice c 99 | ALC.currentContext GL.$= Nothing 100 | ALC.destroyContext c 101 | result <- ALC.closeDevice d 102 | if result then return () else error "Failed to close device!" 103 | 104 | startSound :: Sound -> GameMonad () 105 | startSound sound = GameMonad $ tell $ ([SoundAction sound StartSound], mempty) 106 | 107 | stopSound :: Sound -> GameMonad () 108 | stopSound sound = GameMonad $ tell $ ([SoundAction sound StopSound], mempty) 109 | -------------------------------------------------------------------------------- /tools/OBJViewer.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | -------------------------------------------------------------------------------- 4 | #if __GLASGOW_HASKELL__ <= 708 5 | import Control.Applicative 6 | #endif 7 | import Control.Monad.Trans 8 | import Prelude hiding ((.), id) 9 | import Control.Wire hiding (right) 10 | 11 | #if __GLASGOW_HASKELL__ <= 708 12 | import Data.Traversable (sequenceA) 13 | #endif 14 | import Data.List (intercalate) 15 | 16 | import qualified Graphics.UI.GLFW as GLFW 17 | 18 | import FRP.Netwire.Input 19 | 20 | import qualified Lambency as L 21 | import Linear hiding (trace) 22 | 23 | import System.Environment 24 | --------------------------------------------------------------------------------- 25 | 26 | initialCam :: L.Camera 27 | initialCam = L.mkPerspCamera 28 | -- Pos Dir Up 29 | ((-15) *^ L.localForward) (L.localForward) (L.localUp) 30 | (pi / 4) (4.0 / 3.0) 31 | -- near far 32 | 0.1 10000.0 33 | 34 | cam :: L.ContWire () L.Camera 35 | cam = startCam (makeViewer initialCam) makeViewer makeFree 36 | where 37 | makeViewer c = L.mkViewerCam c zero 38 | makeFree c = L.mkFreeCam c 39 | startCam :: L.ContWire a L.Camera 40 | -> (L.Camera -> L.ContWire a L.Camera) 41 | -> (L.Camera -> L.ContWire a L.Camera) 42 | -> (L.ContWire a L.Camera) 43 | startCam camWire mkThisCam mkThatCam = L.mkContWire $ \dt _ -> do 44 | (nextCam, nextCamWire) <- L.stepContWire camWire dt undefined 45 | toggle <- keyIsPressed GLFW.Key'F 46 | if toggle then 47 | do 48 | setCursorMode CursorMode'Enabled 49 | releaseKey GLFW.Key'F 50 | return (nextCam, startCam (mkThatCam nextCam) mkThatCam mkThisCam) 51 | else return (nextCam, startCam nextCamWire mkThisCam mkThatCam) 52 | 53 | wireframeToggle :: L.GameWire a a 54 | wireframeToggle = (keyDebounced GLFW.Key'W >>> toggle True) <|> mkId 55 | where 56 | toggle :: Bool -> L.GameWire a a 57 | toggle wireframe = mkGenN $ \x -> do 58 | L.toggleWireframe wireframe 59 | return (Right x, toggle $ not wireframe) 60 | 61 | controlWire :: [L.RenderObject] -> L.GameWire a [a] 62 | controlWire ros = sequenceA $ (\ro -> L.mkObject ro (pure L.identity) >>> wireframeToggle) <$> ros 63 | 64 | camLight :: L.ContWire L.Camera L.Light 65 | camLight = arr $ \c -> 66 | let dir = L.getCamDir c 67 | up = L.getCamUp c 68 | right = dir `cross` up 69 | 70 | lightParams = L.mkLightParams (V3 0.5 0.5 0.5) (V3 1.0 1.0 1.0) 1.0 71 | lightDir = negate $ signorm $ right ^+^ up 72 | 73 | in L.dirlight lightParams lightDir 74 | 75 | loadObj :: FilePath -> L.ResourceLoader [L.RenderObject] 76 | loadObj objfile = do 77 | obj <- L.loadOBJWithDefaultMaterial objfile $ 78 | Just (L.shinyColoredMaterial $ V3 0.26 0.5 0.26) 79 | liftIO $ putStrLn $ "OBJ contained " ++ (show $ length obj) ++ " meshes." 80 | return obj 81 | 82 | viewerWire :: FilePath -> L.ContWire (a, Bool) (Maybe ()) 83 | viewerWire file = 84 | L.bracketResource (loadObj file) 85 | $ L.withResource 86 | $ \ros -> pure () . controlWire ros 87 | 88 | viewer :: FilePath -> L.Game () 89 | viewer file = L.Game cam [cam >>> camLight] 90 | $ viewerWire file 91 | . (id &&& 92 | ((pure True . L.quitWire GLFW.Key'Q) `L.withDefault` pure False)) 93 | 94 | handleArgs :: [FilePath] -> Either String FilePath 95 | handleArgs [] = Left "Usage: lobjview OBJFILE" 96 | handleArgs (x : []) = Right x 97 | handleArgs (_ : xs) = Left $ "Unrecognized arguments: " ++ (intercalate " " xs) 98 | 99 | main :: IO () 100 | main = do 101 | objfile <- handleArgs <$> getArgs 102 | case objfile of 103 | Right file -> L.runOpenGL 640 480 "OBJ Viewer" () (viewer file) 104 | Left err -> putStrLn err 105 | -------------------------------------------------------------------------------- /lib/Lambency/Loaders.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Loaders ( 2 | loadOBJ, 3 | loadOBJWithDefaultMaterial, 4 | ) where 5 | 6 | -------------------------------------------------------------------------------- 7 | #if __GLASGOW_HASKELL__ <= 708 8 | import Control.Applicative 9 | #endif 10 | import Control.Monad.Reader 11 | 12 | import qualified Data.Map as Map 13 | 14 | import Lambency.Material 15 | import Lambency.Mesh 16 | import Lambency.Renderer 17 | import Lambency.Types 18 | 19 | import qualified Lambency.Loaders.OBJLoader as OBJ 20 | import qualified Lambency.Loaders.MTLLoader as MTL 21 | 22 | import System.Directory (doesFileExist) 23 | import System.FilePath 24 | -------------------------------------------------------------------------------- 25 | 26 | genMtlMap :: FilePath -> [MTL.MTL] -> ResourceLoader (Map.Map String Material) 27 | genMtlMap baseDir mtls = Map.fromList <$> mapM cvtMtl mtls 28 | where 29 | cvtMtl mtl = do 30 | m <- MTL.mkMaterial baseDir mtl 31 | return (MTL.mtlName mtl, m) 32 | 33 | lookupMtl :: Map.Map String Material -> Maybe Material -> String -> Material 34 | lookupMtl mtlmap defaultMtl str = 35 | case Map.lookup str mtlmap of 36 | Nothing -> 37 | case defaultMtl of 38 | Nothing -> error $ "Lambency.Loaders (lookupMtl): " 39 | <> "No default material and no stored material" 40 | Just m -> m 41 | Just m -> m 42 | 43 | mesh2RenderObj :: (String -> Material) -> (OBJ.OBJInfo, OBJ.OBJGeometry) 44 | -> ResourceLoader RenderObject 45 | mesh2RenderObj mtlFn (OBJ.OBJInfo _ mtl _ 0 0 _, geom) = 46 | let m = mtlFn mtl 47 | mesh = OBJ.obj2V3Mesh geom 48 | in case usesTextures m of 49 | False -> 50 | case isUnlit m of 51 | True -> createRenderObject mesh m 52 | False -> createRenderObject (genNormalsV3 mesh) m 53 | True -> 54 | case isUnlit m of 55 | True -> createRenderObject (genTexCoordsV3 mesh) m 56 | False -> createRenderObject (genTexCoordsOV3 . genNormalsV3 $ mesh) m 57 | 58 | mesh2RenderObj mtlFn (OBJ.OBJInfo _ mtl _ _ 0 _, geom) = 59 | let m = mtlFn mtl 60 | mesh = OBJ.obj2TV3Mesh geom 61 | in case isUnlit m of 62 | False -> createRenderObject (genNormalsTV3 mesh) m 63 | True -> createRenderObject mesh m 64 | 65 | mesh2RenderObj mtlFn (OBJ.OBJInfo _ mtl _ 0 _ _, geom) = 66 | let m = mtlFn mtl 67 | mesh = OBJ.obj2OV3Mesh geom 68 | in case usesTextures m of 69 | False -> createRenderObject mesh m 70 | True -> createRenderObject (genTexCoordsOV3 mesh) m 71 | 72 | mesh2RenderObj mtlFn (OBJ.OBJInfo _ mtl _ _ _ _, geom) = 73 | createRenderObject (OBJ.obj2OTV3Mesh geom) (mtlFn mtl) 74 | 75 | loadOBJWithDefaultMaterial :: FilePath -> (Maybe Material) 76 | -> ResourceLoader [RenderObject] 77 | loadOBJWithDefaultMaterial fp defaultMtl = do 78 | objExists <- liftIO $ doesFileExist fp 79 | if not objExists then error ("OBJ file " ++ fp ++ " not found") else return () 80 | 81 | let baseDir = takeDirectory fp 82 | OBJ.OBJOutput mtllib meshes <- liftIO $ OBJ.loadOBJ fp 83 | 84 | let mtlFile = if null mtllib then "" else baseDir mtllib 85 | mtlExists <- liftIO $ doesFileExist mtlFile 86 | mtls <- if mtlExists 87 | then liftIO $ MTL.loadMTL mtlFile 88 | else 89 | case defaultMtl of 90 | Nothing -> error $ concat 91 | [ "MTL file " 92 | , mtlFile 93 | , " not found and no default specified" 94 | ] 95 | Just _ -> return [] 96 | 97 | mtlmap <- genMtlMap baseDir mtls 98 | mapM (mesh2RenderObj $ lookupMtl mtlmap defaultMtl) meshes 99 | 100 | loadOBJ :: FilePath -> ResourceLoader [RenderObject] 101 | loadOBJ fp = loadOBJWithDefaultMaterial fp Nothing 102 | -------------------------------------------------------------------------------- /examples/MovingSquare.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | module Main (main) where 3 | 4 | -------------------------------------------------------------------------------- 5 | import Prelude hiding (id, (.)) 6 | 7 | import Control.Monad.Reader (ask) 8 | 9 | import Data.Bool (bool) 10 | 11 | import qualified Graphics.UI.GLFW as GLFW 12 | 13 | -- In this example, we qualify everything from Lambency in order to highlight 14 | -- which functions are specific to this library. In general, you shouldn't need 15 | -- to do this once you get more acquainted with the types. 16 | import qualified Lambency as L 17 | 18 | import Linear 19 | 20 | import Control.Wire 21 | 22 | import FRP.Netwire.Move 23 | import FRP.Netwire.Input 24 | --------------------------------------------------------------------------------- 25 | 26 | kWindowWidth :: Int 27 | kWindowWidth = 200 28 | 29 | kWindowHeight :: Int 30 | kWindowHeight = 200 31 | 32 | kWindowTitle :: String 33 | kWindowTitle = "Moving square" 34 | 35 | kMoveSpeed :: Float 36 | kMoveSpeed = 35 -- pixels per second 37 | 38 | kSquareColor :: V4 Float 39 | kSquareColor = V4 1.0 0.0 0.0 1.0 40 | 41 | kSquareSize :: Int 42 | kSquareSize = 30 -- in pixels 43 | 44 | -- This is the main wire for our game. Here we will control a stateful offset 45 | -- vector using the keyboard, and then pass that to our rendering wire 46 | moveSquare :: L.ContWire Bool (Maybe ()) 47 | moveSquare = let 48 | -- The movement is modeled by an offset, represented with a Float for each 49 | -- axis. This offset will be changing over time, so we use a wire. 50 | squareOffset :: L.ContWire a (Float, Float) 51 | squareOffset = flip L.withDefault (pure (0.0, 0.0)) $ 52 | mkOffset GLFW.Key'Left GLFW.Key'Right &&& mkOffset GLFW.Key'Down GLFW.Key'Up 53 | where 54 | mkOffset k1 k2 = integral 0 55 | . ( keyPressed k1 . pure (-kMoveSpeed) 56 | <|> keyPressed k2 . pure kMoveSpeed 57 | <|> pure 0.0 58 | ) 59 | 60 | -- Actual rendering code to send a square to be rendered with the given 61 | -- offset 62 | renderSquare :: L.ContWire (Float, Float) () 63 | renderSquare = L.contWireFrom (L.simpleSprite <$> ask) 64 | $ \s' -> L.everyFrame 65 | $ \(x, y) -> do 66 | let s = L.changeSpriteColor kSquareColor s' 67 | L.renderSprite s (pure kSquareSize) (-1.0) (V2 x y) 68 | return () 69 | in proc quit -> do 70 | () <- renderSquare . squareOffset -< () 71 | arr (bool (Just ()) Nothing) -< quit 72 | 73 | -- The moveSquare wire takes as input a bool for when it should quit. quitWire 74 | -- is the wire that produces that bool. The default value is 'False', meaning 75 | -- "don't quit". From netwire-input, 'keyPressed' will inhibit unless the given 76 | -- key is pressed. If it is inhibiting, then no value is being produced, and 77 | -- hence, we will use the default value (False in this case). If it is not 78 | -- inhibiting, then it acts like the identity wire and produces True. The 79 | -- combination of these wires will produce 'False' unless Q is pressed, in which 80 | -- case it will produce 'True'. 81 | quitWire :: L.ContWire a Bool 82 | quitWire = (keyPressed GLFW.Key'Q . pure True) `L.withDefault` pure False 83 | 84 | -- Our camera is a 2D camera. It is specified to be the size of the window, so 85 | -- the coordinate space of our game world will initially be the same as the 86 | -- coordinate space of our window. mk2DCam has type 'GameWire Vec2f Camera' 87 | -- which means that we can change the position of our camera by passing in a 88 | -- new position of the bottom left-hand corner into our wire. Since we only 89 | -- want a simple static 2D camera in this example, we keep our camera 90 | -- stationary by composing with the wire 'pure (V2 0 0)' 91 | stationaryCamera :: L.ContWire () L.Camera 92 | stationaryCamera = L.mk2DCam kWindowWidth kWindowHeight . pure (V2 0 0) 93 | 94 | -- Since we are not using any dynamic lighting (lights that can change at 95 | -- runtime), we pass the empty list to our game. 96 | dynamicLights :: [L.ContWire () L.Light] 97 | dynamicLights = [] 98 | 99 | game :: L.Game () 100 | game = L.Game stationaryCamera dynamicLights (moveSquare . quitWire) 101 | 102 | main :: IO () 103 | main = L.runOpenGL kWindowWidth kWindowHeight kWindowTitle () game 104 | -------------------------------------------------------------------------------- /lib/Lambency/Texture.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Texture ( 2 | textureSize, 3 | createSolidTexture, 4 | loadTexture, 5 | ) where 6 | 7 | -------------------------------------------------------------------------------- 8 | #if __GLASGOW_HASKELL__ <= 708 9 | import Control.Applicative 10 | #endif 11 | import Control.Monad.Reader 12 | 13 | import Lambency.ResourceLoader 14 | import Lambency.Types 15 | 16 | import qualified Codec.Picture as JP 17 | import qualified Codec.Picture.Types as JP 18 | 19 | import Data.Array.Storable 20 | import Data.Word 21 | import qualified Data.Vector.Storable as Vector 22 | import qualified Data.ByteString as BS 23 | 24 | import Linear.V2 25 | import Linear.V4 26 | 27 | import System.FilePath (takeExtension) 28 | -------------------------------------------------------------------------------- 29 | textureSize :: Texture -> V2 Int 30 | textureSize (Texture (OpenGLTexHandle _ sz) _) = getTextureSize sz 31 | textureSize (RenderTexture (OpenGLTexHandle _ sz) _) = getTextureSize sz 32 | 33 | loadTextureFromPNGorTGA :: JP.DynamicImage -> ResourceLoader Texture 34 | loadTextureFromPNGorTGA (JP.ImageRGBA8 (JP.Image width height dat)) = do 35 | r <- ask 36 | runLoaderWith (Vector.unsafeWith dat) $ \ptr -> 37 | mkTexture r ptr (fromIntegral <$> V2 width height) RGBA8 38 | loadTextureFromPNGorTGA (JP.ImageRGB8 (JP.Image width height dat)) = do 39 | r <- ask 40 | runLoaderWith (Vector.unsafeWith dat) $ \ptr -> 41 | mkTexture r ptr (fromIntegral <$> V2 width height) RGB8 42 | loadTextureFromPNGorTGA _ = error "Unknown PNG or TGA color type" 43 | 44 | loadTextureFromPNG :: FilePath -> ResourceLoader (Maybe Texture) 45 | loadTextureFromPNG filename = do 46 | pngBytes <- liftIO $ BS.readFile filename 47 | case JP.decodePng pngBytes of 48 | Left str -> do 49 | liftIO $ putStrLn $ "Error loading PNG file: " ++ str 50 | return Nothing 51 | Right img -> Just <$> loadTextureFromPNGorTGA img 52 | 53 | loadTextureFromTGA :: FilePath -> ResourceLoader (Maybe Texture) 54 | loadTextureFromTGA filename = do 55 | tgaBytes <- liftIO $ BS.readFile filename 56 | case JP.decodeTga tgaBytes of 57 | Left str -> do 58 | liftIO $ putStrLn $ "Error loading TGA file: " ++ str 59 | return Nothing 60 | Right img -> Just <$> loadTextureFromPNGorTGA img 61 | 62 | flipY :: JP.Pixel a => JP.Image a -> JP.Image a 63 | flipY img = 64 | let w = JP.imageWidth img 65 | h = JP.imageHeight img 66 | genPixel x y = JP.pixelAt img x (h - y - 1) 67 | in JP.generateImage genPixel w h 68 | 69 | loadTextureFromJPG :: FilePath -> ResourceLoader (Maybe Texture) 70 | loadTextureFromJPG filename = do 71 | jpgImg <- liftIO $ do 72 | jpgBytes <- BS.readFile filename 73 | case JP.decodeJpeg jpgBytes of 74 | Left str -> do 75 | putStrLn $ "Error loading JPG file: " ++ str 76 | return Nothing 77 | Right img -> return (Just img) 78 | case jpgImg of 79 | Just (JP.ImageYCbCr8 i) -> do 80 | let (JP.ImageRGB8 (JP.Image width height dat)) = 81 | JP.ImageRGB8 (JP.convertImage $ flipY i) 82 | runLoaderWith (Vector.unsafeWith dat) $ \ptr -> do 83 | r <- ask 84 | Just <$> mkTexture r ptr (fromIntegral <$> V2 width height) RGB8 85 | _ -> return Nothing 86 | 87 | createSolidTexture :: V4 Word8 -> ResourceLoader Texture 88 | createSolidTexture (V4 r g b a) = do 89 | carr <- liftIO $ newListArray (0 :: Integer, 3) [r, g, b, a] 90 | runLoaderWith (withStorableArray carr) $ \ptr -> do 91 | rend <- ask 92 | mkTexture rend ptr (pure 1) RGBA8 93 | 94 | data ImageType 95 | = ImageType'PNG 96 | | ImageType'JPG 97 | | ImageType'TGA 98 | deriving (Show, Eq, Ord, Enum) 99 | 100 | -- !FIXME! might do better to introspect on the bytes and figure out 101 | -- what kind of image it is... does JuicyPixels do this? 102 | determineImageType :: FilePath -> Maybe ImageType 103 | determineImageType = fromExtension . takeExtension 104 | where 105 | fromExtension ".png" = Just ImageType'PNG 106 | fromExtension ".PNG" = Just ImageType'PNG 107 | fromExtension ".jpg" = Just ImageType'JPG 108 | fromExtension ".JPG" = Just ImageType'JPG 109 | fromExtension ".jpeg" = Just ImageType'JPG 110 | fromExtension ".JPEG" = Just ImageType'JPG 111 | fromExtension ".tga" = Just ImageType'TGA 112 | fromExtension ".TGA" = Just ImageType'TGA 113 | fromExtension _ = Nothing 114 | 115 | loadTextureWithType :: FilePath -> Maybe ImageType 116 | -> ResourceLoader (Maybe Texture) 117 | loadTextureWithType fp Nothing = do 118 | liftIO $ putStrLn $ "WARNING: Unsupported image type: " ++ fp 119 | return Nothing 120 | loadTextureWithType filename (Just ImageType'PNG) = loadTextureFromPNG filename 121 | loadTextureWithType filename (Just ImageType'JPG) = loadTextureFromJPG filename 122 | loadTextureWithType filename (Just ImageType'TGA) = loadTextureFromTGA filename 123 | 124 | loadTexture :: FilePath -> ResourceLoader (Maybe Texture) 125 | loadTexture filename = 126 | let imageType = determineImageType filename 127 | in loadTextureWithType filename imageType 128 | -------------------------------------------------------------------------------- /examples/Shooter.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -------------------------------------------------------------------------------- 4 | import Prelude hiding ((.), id) 5 | import Control.Wire 6 | import FRP.Netwire.Input 7 | 8 | import qualified Graphics.UI.GLFW as GLFW 9 | import qualified Lambency as L 10 | 11 | import Linear hiding (trace) 12 | -------------------------------------------------------------------------------- 13 | 14 | -------------------------------------------------- 15 | -- Constants 16 | 17 | screenWidth :: Int 18 | screenWidth = 640 19 | 20 | screenHeight :: Int 21 | screenHeight = 480 22 | 23 | bulletSz :: Float 24 | bulletSz = 5.0 25 | 26 | shipSz :: Float 27 | shipSz = 10.0 28 | 29 | shipSpeed :: Float 30 | shipSpeed = 25.0 31 | 32 | bulletSpeed :: Float 33 | bulletSpeed = 100.0 34 | 35 | bulletDelay :: Float 36 | bulletDelay = 0.2 37 | 38 | -------------------------------------------------- 39 | -- Rendering 40 | 41 | renderQuad :: L.Sprite -> V2 Float -> Float -> L.GameMonad () 42 | renderQuad s (V2 x y) sz = 43 | let hsz = sz * 0.5 44 | pos = V2 (x - hsz) (y - hsz) 45 | sc = round <$> V2 sz sz 46 | in L.renderSprite s sc (-1) pos 47 | 48 | -------------------------------------------------- 49 | -- Logic 50 | 51 | -- A bullet is just a sprite that doesn't interact with anything... 52 | type Bullet = L.GameWire () () 53 | 54 | -- A Ship is something that takes direction and produces bullets 55 | type Ship = L.GameWire (V2 Float) [Bullet] 56 | 57 | inScreen :: V2 Float -> Bool 58 | inScreen (V2 px py) = 59 | let (V2 sx sy) = fmap fromIntegral (V2 screenWidth screenHeight) 60 | in px >= 0 && px <= sx && py >= 0 && py <= sy 61 | 62 | bulletWire :: V2 Float -> V2 Float -> L.Sprite -> Bullet 63 | bulletWire pos vel bullet = mkGen $ \dt _ -> do 64 | let pos' = pos ^+^ (dtime dt * bulletSpeed *^ vel) 65 | renderQuad bullet pos' bulletSz 66 | if (not $ inScreen pos') 67 | then return (Left mempty, bulletWire pos' vel bullet) 68 | else return (Right (), bulletWire pos' vel bullet) 69 | 70 | shipWire :: V2 Float -> L.Sprite -> L.Sprite -> Ship 71 | shipWire pos' ship bullet = loop $ (second $ delay 0) >>> (shipFeedback pos') 72 | where 73 | fireWire :: L.GameWire () Bool 74 | fireWire = (keyDebounced GLFW.Key'Space >>> pure True) <|> pure False 75 | 76 | shipFeedback :: V2 Float -> L.GameWire (V2 Float, Float) ([Bullet], Float) 77 | shipFeedback pos = 78 | mkGen $ \dt (vel, t) -> do 79 | let newPos = pos ^+^ (dtime dt * shipSpeed *^ vel) 80 | nextSW = shipFeedback newPos 81 | b = bulletWire newPos vel bullet 82 | renderQuad ship newPos shipSz 83 | (Right fire, _) <- stepWire fireWire dt $ Right () 84 | if (vel /= zero && fire && t > bulletDelay) 85 | then return $ (Right ([b], 0 :: Float), nextSW) -- Spawn bullet 86 | else return $ (Right ([], t + (dtime dt)), nextSW) 87 | 88 | addVecWire :: L.GameWire () (V2 Float) -> L.GameWire () (V2 Float) -> 89 | L.GameWire () (V2 Float) 90 | addVecWire w1 w2 = w1 &&& w2 >>> (arr $ uncurry (^+^)) 91 | 92 | inputWire :: L.GameWire () (V2 Float) 93 | inputWire = 94 | ((pure (V2 0 1) >>> keyPressed GLFW.Key'Up) <|> (pure zero)) `addVecWire` 95 | ((pure (V2 0 (-1)) >>> keyPressed GLFW.Key'Down) <|> (pure zero)) `addVecWire` 96 | ((pure (V2 1 0) >>> keyPressed GLFW.Key'Right) <|> (pure zero)) `addVecWire` 97 | ((pure (V2 (-1) 0) >>> keyPressed GLFW.Key'Left) <|> (pure zero)) 98 | 99 | loadGameResources :: L.ResourceLoader (L.Sprite, L.Sprite) 100 | loadGameResources = do 101 | let white = pure 255 102 | red = V4 255 0 0 255 103 | ship <- L.createSolidTexture white >>= L.loadStaticSpriteWithTexture 104 | bullet <- L.createSolidTexture red >>= L.loadStaticSpriteWithTexture 105 | return (ship, bullet) 106 | 107 | gameWire :: L.ContWire ((), Bool) (Maybe ()) 108 | gameWire = 109 | L.bracketResource loadGameResources 110 | $ L.withResource $ \(ship, bullet) -> 111 | let shipW = inputWire >>> shipWire (V2 240 320) ship bullet 112 | 113 | runBullet :: L.TimeStep -> Bullet -> L.GameMonad [Bullet] 114 | runBullet dt bw' = do 115 | (result, bw) <- stepWire bw' dt $ Right () 116 | case result of 117 | Right _ -> return [bw] 118 | Left _ -> return [] 119 | 120 | runBullets :: L.TimeStep -> [Bullet] -> L.GameMonad [Bullet] 121 | runBullets dt bs = concat <$> mapM (runBullet dt) bs 122 | 123 | runShip :: L.GameWire () [Bullet] -> [Bullet] -> L.GameWire () () 124 | runShip sw' bullets = mkGen $ \dt _ -> do 125 | (result, sw) <- stepWire sw' dt (Right ()) 126 | case result of 127 | Right newb -> do 128 | bullets' <- runBullets dt (bullets ++ newb) 129 | return (Right (), runShip sw bullets') 130 | Left e -> return (Left e, runShip sw bullets) 131 | in runShip shipW [] 132 | 133 | -------------------------------------------------- 134 | -- Init 135 | 136 | shooterCam :: L.ContWire () L.Camera 137 | shooterCam = pure zero >>> (L.mk2DCam screenWidth screenHeight) 138 | 139 | game :: L.Game () 140 | game = L.Game shooterCam [] $ (id &&& quitWire) >>> gameWire 141 | where 142 | quitWire = 143 | (pure True >>> keyPressed GLFW.Key'Q) `L.withDefault` pure False 144 | 145 | main :: IO () 146 | main = L.runOpenGL screenWidth screenHeight "Space Shooter Demo" () game 147 | -------------------------------------------------------------------------------- /lib/Lambency/Bounds.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Bounds ( 2 | BoundingVolume, 3 | aabb, 4 | boundingSphere, 5 | containsPoint, 6 | colliding 7 | ) where 8 | 9 | -------------------------------------------------------------------------------- 10 | 11 | import Lambency.Types 12 | import Lambency.Transform 13 | 14 | import Linear.Epsilon 15 | import Linear.Matrix 16 | import Linear.Metric 17 | import qualified Linear.Quaternion as Quat 18 | import Linear.Vector 19 | import Linear.V3 20 | 21 | #if __GLASGOW_HASKELL__ <= 708 22 | import Control.Applicative 23 | #endif 24 | -------------------------------------------------------------------------------- 25 | 26 | -- Bounding Volumes 27 | 28 | data BoundingVolume = BoundingBox Float Float Float 29 | | BoundingEllipse Float Float Float 30 | | RotatedVolume Quatf BoundingVolume 31 | | TranslatedVolume Vec3f BoundingVolume 32 | | Union BoundingVolume BoundingVolume 33 | 34 | instance Transformable3D BoundingVolume where 35 | translate t (TranslatedVolume t' bv) = TranslatedVolume (t ^+^ t') bv 36 | translate t (Union bv1 bv2) = Union (translate t bv1) (translate t bv2) 37 | translate t bv = TranslatedVolume t bv 38 | 39 | rotate quat (RotatedVolume uq bv) = RotatedVolume (uq * quat) bv 40 | rotate quat (TranslatedVolume t bv) = TranslatedVolume t (rotate quat bv) 41 | rotate quat bv = RotatedVolume quat bv 42 | 43 | nonuniformScale (V3 sx sy sz) (BoundingBox x y z) = 44 | BoundingBox (x * sx) (y * sy) (z * sz) 45 | nonuniformScale (V3 sx sy sz) (BoundingEllipse x y z) = 46 | BoundingEllipse (x * sx) (y * sy) (z * sz) 47 | 48 | nonuniformScale s (RotatedVolume uq bv) = RotatedVolume uq (nonuniformScale s bv) 49 | nonuniformScale s (TranslatedVolume t bv) = TranslatedVolume t (nonuniformScale s bv) 50 | nonuniformScale s (Union b b') = Union (nonuniformScale s b) (nonuniformScale s b') 51 | 52 | ------------------------------------------------------------------------------- 53 | 54 | aabb :: Vec3f -> Vec3f -> BoundingVolume 55 | aabb v1@(V3 x1 y1 z1) v2@(V3 x2 y2 z2) = let 56 | szx = abs (x2 - x1) 57 | szy = abs (y2 - y1) 58 | szz = abs (z2 - z1) 59 | c = (v1 ^+^ v2) ^* 0.5 60 | in translate c $ BoundingBox (szx * 0.5) (szy * 0.5) (szz * 0.5) 61 | 62 | boundingSphere :: Vec3f -> Float -> BoundingVolume 63 | boundingSphere c r = translate c $ BoundingEllipse r r r 64 | 65 | containsPoint :: BoundingVolume -> Vec3f -> Bool 66 | containsPoint (BoundingBox x y z) (V3 x' y' z') = 67 | and $ zipWith (\v w -> ((-w) >= v) && (v <= w)) [x', y', z'] [x, y, z] 68 | containsPoint (BoundingEllipse x y z) (V3 x' y' z') = 69 | sqr (x' / x) + sqr (y' / y) + sqr (z' / z) < 1 70 | where 71 | sqr :: Num a => a -> a 72 | sqr k = k * k 73 | containsPoint (Union bv1 bv2) v = containsPoint bv1 v || containsPoint bv2 v 74 | containsPoint (TranslatedVolume t bv) v = containsPoint bv (v ^-^ t) 75 | containsPoint (RotatedVolume q bv) v = containsPoint bv (Quat.rotate (negate q) v) 76 | 77 | -- An orientation is simply a position in world space, a rotation matrix, and 78 | -- and extents vector for each of the new coordinate axes 79 | type Orientation = (Vec3f, Mat3f, Vec3f) 80 | 81 | io :: Orientation 82 | io = (zero, Linear.Matrix.identity, V3 1 1 1) 83 | 84 | data OrientedVolume = Box Orientation 85 | | Ellipse Orientation 86 | 87 | collideOriented :: OrientedVolume -> OrientedVolume -> Bool 88 | 89 | collideOriented (Box (t, o, s)) (Box (t', o', s')) = 90 | -- First we need to rotate and translate the first box into the coordinate 91 | -- space of the second. 92 | let 93 | rotateAtoB :: Mat3f 94 | rotateAtoB = adjoint o' !*! o 95 | 96 | cBwrtA :: Vec3f 97 | cBwrtA = (t' ^-^ t) *! adjoint o 98 | 99 | eBwrtA :: Vec3f 100 | eBwrtA = s' *! adjoint rotateAtoB 101 | 102 | absDot :: Vec3f -> Vec3f -> Float 103 | absDot (V3 x y z) (V3 x' y' z') = 104 | abs (x * x') + abs (y * y') + abs (z * z') 105 | 106 | testAxis :: Vec3f -> Bool 107 | testAxis v = abs (cBwrtA `dot` v) <= ((s `absDot` v) + (eBwrtA `absDot` v)) 108 | 109 | axesA :: [Vec3f] 110 | axesA = [V3 1 0 0, V3 0 1 0, V3 0 0 1] 111 | 112 | axesB :: [Vec3f] 113 | axesB = map (*! rotateAtoB) axesA 114 | 115 | in 116 | any (testAxis . signorm) $ 117 | filter (not . nearZero) $ 118 | [v1 `cross` v2 | v1 <- axesA, v2 <- axesB] ++ axesA ++ axesB 119 | 120 | -- collideOriented (Ellipse (t, o, s)) (Box (t', o', s')) = False 121 | -- collideOriented (Ellipse (t, o, s)) (Ellipse (t', o', s')) = False 122 | 123 | -- The only pattern we're missing is box-ellipse 124 | collideOriented ov1 ov2 = collideOriented ov2 ov1 125 | 126 | colliding :: BoundingVolume -> BoundingVolume -> Bool 127 | colliding bv (Union bv1 bv2) = colliding bv bv1 || colliding bv bv2 128 | colliding (Union bv1 bv2) bv = colliding bv bv1 || colliding bv bv2 129 | colliding bv1 bv2 = 130 | or [collideOriented x y | x <- getO bv1 io, y <- getO bv2 io] 131 | where 132 | getO :: BoundingVolume -> Orientation -> [OrientedVolume] 133 | getO (BoundingBox x y z) (t, o, s) = [Box (t, o, (*) <$> s <*> V3 x y z)] 134 | getO (BoundingEllipse x y z) (t, o, s) = [Ellipse (t, o, (*) <$> s <*> V3 x y z)] 135 | getO (TranslatedVolume t bv) (t', o, s) = getO bv (t ^+^ t', o, s) 136 | getO (RotatedVolume q bv) (t, o, s) = getO bv (t, fromQuaternion q !*! o, s) 137 | getO (Union bv1' bv2') o = getO bv1' o ++ getO bv2' o 138 | -------------------------------------------------------------------------------- /lib/Lambency/Light.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Lambency.Light ( 3 | getLightVarName, 4 | getLightShaderVars, 5 | 6 | mkLightParams, 7 | 8 | spotlight, 9 | dirlight, 10 | pointlight, 11 | 12 | addShadowMap, 13 | 14 | getLightPosition, 15 | setLightPosition, 16 | 17 | getLightDirection, 18 | setLightDirection, 19 | 20 | setLightAmbient, 21 | setLightColor, 22 | setLightIntensity, 23 | ) where 24 | 25 | -------------------------------------------------------------------------------- 26 | import Control.Monad.Reader 27 | 28 | import Lambency.Shader 29 | import Lambency.Types 30 | 31 | import qualified Data.Map as Map 32 | 33 | import Linear.Metric 34 | import Linear.V3 35 | -------------------------------------------------------------------------------- 36 | 37 | mkLightVar :: String -> ShaderValue -> LightVar a 38 | mkLightVar n v = LightVar (n, v) 39 | 40 | mkLightVar3f :: String -> (V3 Float) -> LightVar (V3 Float) 41 | mkLightVar3f n v = mkLightVar n (Vector3Val v) 42 | 43 | mkLightVarf :: String -> Float -> LightVar Float 44 | mkLightVarf n f = mkLightVar n (FloatVal f) 45 | 46 | mkLightParams :: Vec3f -> Vec3f -> Float -> LightParams 47 | mkLightParams a c i = 48 | LightParams 49 | (mkLightVar3f "lightAmbient" a) 50 | (mkLightVar3f "lightColor" c) 51 | (mkLightVarf "lightIntensity" i) 52 | 53 | getLightShaderVars :: Light -> UniformMap 54 | getLightShaderVars (Light params ty _) = 55 | let mkShdrVarPair :: LightVar a -> (String, ShaderValue) 56 | mkShdrVarPair (LightVar x) = x 57 | 58 | getTypeVars (SpotLight x y z) = 59 | [mkShdrVarPair x, mkShdrVarPair y, mkShdrVarPair z] 60 | getTypeVars (DirectionalLight dir) = [mkShdrVarPair dir] 61 | getTypeVars (PointLight pos) = [mkShdrVarPair pos] 62 | 63 | getParamVars (LightParams a c i) = 64 | [mkShdrVarPair a, mkShdrVarPair c, mkShdrVarPair i] 65 | in 66 | Map.fromList $ getTypeVars ty ++ getParamVars params 67 | 68 | spotlight :: LightParams -> Vec3f -> Vec3f -> Float -> Light 69 | spotlight params pos dir ang = 70 | Light { 71 | lightParams = params, 72 | lightType = 73 | SpotLight 74 | (mkLightVar3f "spotlightDir" $ signorm dir) 75 | (mkLightVar3f "spotlightPos" pos) 76 | (mkLightVarf "spotlightCosCutoff" $ cos ang), 77 | lightShadowMap = Nothing 78 | } 79 | 80 | dirlight :: LightParams -> Vec3f -> Light 81 | dirlight params dir = 82 | Light { 83 | lightParams = params, 84 | lightType = DirectionalLight (mkLightVar3f "dirlightDir" $ signorm dir), 85 | lightShadowMap = Nothing 86 | } 87 | 88 | pointlight :: LightParams -> Vec3f -> Light 89 | pointlight params pos = 90 | Light { 91 | lightParams = params, 92 | lightType = PointLight (mkLightVar3f "pointlightPos" pos), 93 | lightShadowMap = Nothing 94 | } 95 | 96 | addShadowMap :: Light -> ResourceLoader Light 97 | addShadowMap l = do 98 | depthTex <- ask >>= flip mkDepthTexture (pure 1024) 99 | return $ l { lightShadowMap = (Just (ShadowMap depthTex, ShadowTechnique'Simple)) } 100 | 101 | getLightPosition :: Light -> Maybe (V3 Float) 102 | getLightPosition (Light _ (SpotLight {..}) _) = 103 | let LightVar (_, Vector3Val v) = spotLightPos 104 | in Just v 105 | getLightPosition (Light _ (PointLight {..}) _) = 106 | let LightVar (_, Vector3Val v) = pointLightPos 107 | in Just v 108 | getLightPosition _ = Nothing 109 | 110 | setLightPosition :: Vec3f -> Light -> Light 111 | setLightPosition pos (Light params (SpotLight {..}) shdw) = 112 | let LightVar (name, _) = spotLightPos 113 | newPos = LightVar (name, Vector3Val pos) 114 | in Light params (SpotLight spotLightDir newPos spotLightCosCutoff) shdw 115 | setLightPosition pos (Light params (PointLight {..}) shdw) = 116 | let LightVar (name, _) = pointLightPos 117 | newPos = LightVar (name, Vector3Val pos) 118 | in Light params (PointLight newPos) shdw 119 | setLightPosition _ light = light -- Silently do nothing for lights that have no position... 120 | 121 | getLightDirection :: Light -> Maybe (V3 Float) 122 | getLightDirection (Light _ (SpotLight {..}) _) = 123 | let LightVar (_, Vector3Val v) = spotLightDir in Just v 124 | getLightDirection (Light _ (DirectionalLight {..}) _) = 125 | let LightVar (_, Vector3Val v) = dirLightDir in Just v 126 | getLightDirection _ = Nothing 127 | 128 | setLightDirection :: Vec3f -> Light -> Light 129 | setLightDirection dir (Light params (SpotLight {..}) shdw) = 130 | let LightVar (name, _) = spotLightDir 131 | newDir = LightVar (name, Vector3Val $ signorm dir) 132 | in Light params (SpotLight newDir spotLightPos spotLightCosCutoff) shdw 133 | setLightDirection dir (Light params (DirectionalLight {..}) shdw) = 134 | let LightVar (name, _) = dirLightDir 135 | newDir = LightVar (name, Vector3Val $ signorm dir) 136 | in Light params (DirectionalLight newDir) shdw 137 | setLightDirection _ light = light -- Silently do nothing for lights that have no direction... 138 | 139 | setLightAmbient :: Vec3f -> Light -> Light 140 | setLightAmbient color (Light params lightTy shadow) = 141 | let newColor = (mkLightVar3f "lightAmbient" color) 142 | in Light (params { ambientColor = newColor}) lightTy shadow 143 | 144 | setLightColor :: Vec3f -> Light -> Light 145 | setLightColor color (Light params lightTy shadow) = 146 | let newColor = (mkLightVar3f "lightColor" color) 147 | in Light (params { lightColor = newColor}) lightTy shadow 148 | 149 | setLightIntensity :: Float -> Light -> Light 150 | setLightIntensity intensity (Light params lightTy shadow) = 151 | let newi = (mkLightVarf "lightIntensity" intensity) 152 | in Light (params { lightIntensity = newi}) lightTy shadow 153 | -------------------------------------------------------------------------------- /lib/Lambency/Mesh.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Mesh ( 2 | Mesh(..), 3 | 4 | getMeshVertexTy, 5 | 6 | genNormalsV3, 7 | genNormalsTV3, 8 | 9 | genTexCoordsV3, 10 | genTexCoordsOV3, 11 | 12 | triangle, 13 | cube, 14 | plane, 15 | quad, 16 | ) where 17 | 18 | -------------------------------------------------------------------------------- 19 | 20 | import Lambency.Vertex 21 | 22 | #if __GLASGOW_HASKELL__ <= 708 23 | import Control.Applicative 24 | #endif 25 | 26 | import Data.Int 27 | import qualified Data.Map as Map 28 | 29 | import Linear hiding (trace) 30 | -------------------------------------------------------------------------------- 31 | 32 | type Vec2f = V2 Float 33 | type Vec3f = V3 Float 34 | 35 | data Mesh a = Mesh { vertices :: [a], 36 | indices :: [Int32] } 37 | deriving (Show) 38 | 39 | getMeshVertexTy :: Vertex a => Mesh a -> VertexTy a 40 | getMeshVertexTy (Mesh vs _) = 41 | let (v : _) = (undefined : vs) 42 | in getVertexTy v 43 | 44 | mkV3 :: (Float, Float, Float) -> V3 Float 45 | mkV3 (a, b, c) = V3 a b c 46 | 47 | triangle :: Mesh Vertex3 48 | triangle = Mesh { 49 | vertices = mkVertex3 . mkV3 <$> [ (-1, -1, 0), (1, -1, 0), (0, 1, 0)], 50 | indices = [0, 1, 2] 51 | } 52 | 53 | cube :: Mesh OTVertex3 54 | cube = Mesh { 55 | vertices = zipWith3 mkNormTexVertex3 (mkV3 <$> [ 56 | -- Front face 57 | (-1.0, -1.0, 1.0), 58 | ( 1.0, -1.0, 1.0), 59 | ( 1.0, 1.0, 1.0), 60 | (-1.0, 1.0, 1.0), 61 | 62 | -- Back face 63 | (-1.0, -1.0, -1.0), 64 | (-1.0, 1.0, -1.0), 65 | ( 1.0, 1.0, -1.0), 66 | ( 1.0, -1.0, -1.0), 67 | 68 | -- Top face 69 | (-1.0, 1.0, -1.0), 70 | (-1.0, 1.0, 1.0), 71 | ( 1.0, 1.0, 1.0), 72 | ( 1.0, 1.0, -1.0), 73 | 74 | -- Bottom face 75 | (-1.0, -1.0, -1.0), 76 | ( 1.0, -1.0, -1.0), 77 | ( 1.0, -1.0, 1.0), 78 | (-1.0, -1.0, 1.0), 79 | 80 | -- Right face 81 | ( 1.0, -1.0, -1.0), 82 | ( 1.0, 1.0, -1.0), 83 | ( 1.0, 1.0, 1.0), 84 | ( 1.0, -1.0, 1.0), 85 | 86 | -- Left face 87 | (-1.0, -1.0, -1.0), 88 | (-1.0, -1.0, 1.0), 89 | (-1.0, 1.0, 1.0), 90 | (-1.0, 1.0, -1.0) 91 | ]) 92 | -- Normals 93 | (concat [ replicate 4 (V3 0 0 1), 94 | replicate 4 (V3 0 0 (-1)), 95 | replicate 4 (V3 0 1 0), 96 | replicate 4 (V3 0 (-1) 0), 97 | replicate 4 (V3 1 0 0), 98 | replicate 4 (V3 (-1) 0 0)]) 99 | -- Texture Coordinates 100 | ((concat . replicate 6) [V2 0 0, V2 1 0, V2 1 1, V2 0 1]), 101 | 102 | indices = concat [[x, x+1, x+2, x, x+2, x+3] | x <- [0,4..20]] 103 | } 104 | 105 | plane :: Mesh OTVertex3 106 | plane = Mesh { 107 | vertices = zipWith3 mkNormTexVertex3 108 | [V3 x 0 z | z <- [(-1),(-0.9)..1], x <- [(-1),(-0.9)..1]] 109 | (replicate (21*21) (V3 0 1 0)) 110 | [V2 u v | v <- [0,0.05..1], u <- [0,0.05..1]], 111 | indices = concat [quadAt x y | y <- [0..19], x <- [0..19]] 112 | } 113 | where quadAt x y = 114 | [idxOf x y, idxOf x (y+1), idxOf (x+1) y, 115 | idxOf (x+1) y, idxOf x (y+1), idxOf (x+1) (y+1)] 116 | idxOf x y = y * 21 + x 117 | 118 | quad :: Mesh TVertex3 119 | quad = Mesh { 120 | vertices = zipWith mkTexVertex3 (map texToVert texcoords) texcoords, 121 | indices = [0, 2, 1, 1, 2, 3] 122 | } 123 | where 124 | texcoords :: [ Vec2f ] 125 | texcoords = [ V2 x y | x <- [0, 1], y <- [1, 0] ] 126 | 127 | texToVert :: Vec2f -> Vec3f 128 | texToVert (V2 x y) = V3 x (1 - y) 0 129 | 130 | 131 | type Triangle = (Vec3f, Vec3f, Vec3f) 132 | 133 | mkTris :: Vertex a => (a -> Vec3f) -> Mesh a -> Map.Map a [Triangle] 134 | mkTris posFn mesh = mkTrisFn (indices mesh) Map.empty 135 | where 136 | vertMap = Map.fromList $ zip [0,1..] (vertices mesh) 137 | 138 | mkTrisFn [] m = m 139 | mkTrisFn (x : y : z : rest) m = 140 | let xv = vertMap Map.! x 141 | yv = vertMap Map.! y 142 | zv = vertMap Map.! z 143 | t = (posFn xv, posFn yv, posFn zv) 144 | miniMap = Map.fromList $ zip [xv, yv, zv] $ repeat [t] 145 | in mkTrisFn rest $ Map.unionWith (++) miniMap m 146 | 147 | mkTrisFn _ _ = error "Not a list of triangle indices!" 148 | 149 | genNormals :: Map.Map a [Triangle] -> Map.Map a Vec3f 150 | genNormals = Map.map genNormal 151 | where 152 | triNormal :: Triangle -> Vec3f 153 | triNormal (v1, v2, v3) = 154 | let x = v2 ^-^ v1 155 | y = v3 ^-^ v1 156 | in signorm $ x `cross` y 157 | 158 | genNormal :: [Triangle] -> Vec3f 159 | genNormal = signorm . foldl1 (^+^) . map triNormal 160 | 161 | genNormalsV3 :: Mesh Vertex3 -> Mesh OVertex3 162 | genNormalsV3 mesh = 163 | let genOVertex :: Map.Map Vertex3 Vec3f -> Map.Map Vertex3 OVertex3 164 | genOVertex = Map.mapWithKey addNormalV3 165 | 166 | ovMap = genOVertex . genNormals . mkTris getVertex3Position $ mesh 167 | in 168 | mesh { vertices = map (ovMap Map.!) $ vertices mesh } 169 | 170 | genNormalsTV3 :: Mesh TVertex3 -> Mesh OTVertex3 171 | genNormalsTV3 mesh = 172 | let genOTVertex :: Map.Map TVertex3 Vec3f -> Map.Map TVertex3 OTVertex3 173 | genOTVertex = Map.mapWithKey addNormalTV3 174 | 175 | otvMap = genOTVertex . genNormals . mkTris getTexVertex3Position $ mesh 176 | in 177 | mesh { vertices = map (otvMap Map.!) $ vertices mesh } 178 | 179 | -- !FIXME! Actually properly generate texture coordinates... this is kind 180 | -- of embarassing 181 | genTexCoordsOV3 :: Mesh OVertex3 -> Mesh OTVertex3 182 | genTexCoordsOV3 (Mesh verts idxs) = Mesh (map (`addTexCoordOV3` zero) verts) idxs 183 | 184 | genTexCoordsV3 :: Mesh Vertex3 -> Mesh TVertex3 185 | genTexCoordsV3 (Mesh verts idxs) = Mesh (map (`addTexCoordV3` zero) verts) idxs 186 | -------------------------------------------------------------------------------- /lib/Lambency/Renderer/OpenGL/Texture.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Renderer.OpenGL.Texture ( 2 | getGLTexObj, 3 | isRenderTexture, 4 | initializeTexture, 5 | createDepthTexture, 6 | updateTexture, 7 | bindRenderTexture, 8 | ) where 9 | 10 | -------------------------------------------------------------------------------- 11 | #if __GLASGOW_HASKELL__ <= 708 12 | import Control.Applicative 13 | #endif 14 | import Control.Monad.Writer 15 | 16 | import qualified Graphics.Rendering.OpenGL as GL 17 | 18 | import Lambency.Types hiding (Renderer(..)) 19 | 20 | -- import System.Directory 21 | import Foreign.Ptr 22 | import Data.Word 23 | 24 | import Linear.V2 25 | -------------------------------------------------------------------------------- 26 | 27 | kShadowMapSize :: GL.GLsizei 28 | kShadowMapSize = 1024 29 | 30 | getGLTexObj :: Texture -> GL.TextureObject 31 | getGLTexObj (Texture (OpenGLTexHandle h _) _) = h 32 | getGLTexObj (RenderTexture (OpenGLTexHandle h _) _) = h 33 | 34 | getGLTexFmt :: Texture -> TextureFormat 35 | getGLTexFmt (Texture _ fmt) = fmt 36 | getGLTexFmt (RenderTexture _ _) = 37 | error "Render textures don't have a texture format" 38 | 39 | fmt2glpfmt :: TextureFormat -> GL.PixelFormat 40 | fmt2glpfmt RGBA8 = GL.RGBA 41 | fmt2glpfmt RGB8 = GL.RGB 42 | fmt2glpfmt Alpha8 = GL.Alpha 43 | 44 | internalglpfmt :: GL.PixelFormat -> GL.PixelInternalFormat 45 | internalglpfmt GL.RGBA = GL.RGBA8 46 | internalglpfmt GL.RGB = GL.RGB8 47 | internalglpfmt GL.Alpha = GL.Alpha8 48 | internalglpfmt _ = 49 | error "We don't know the data used for this pixelformat" 50 | 51 | isRenderTexture :: Texture -> Bool 52 | isRenderTexture (Texture _ _) = False 53 | isRenderTexture (RenderTexture _ _) = True 54 | 55 | bindRenderTexture :: Texture -> IO () 56 | bindRenderTexture (Texture _ _) = return () 57 | bindRenderTexture (RenderTexture _ (OpenGLFBOHandle h)) = do 58 | GL.bindFramebuffer GL.Framebuffer GL.$= h 59 | GL.viewport GL.$= (GL.Position 0 0, GL.Size kShadowMapSize kShadowMapSize) 60 | 61 | destroyTexture :: GL.TextureObject -> IO () 62 | destroyTexture h = do 63 | putStrLn $ concat ["Destroying texture: ", show h] 64 | GL.deleteObjectName h 65 | 66 | destroyFBO :: GL.FramebufferObject -> IO () 67 | destroyFBO fboh = do 68 | putStrLn "Destroying framebuffer object." 69 | GL.deleteObjectName fboh 70 | 71 | initializeTexture :: Ptr a -> V2 Word32 -> TextureFormat -> ResourceLoader Texture 72 | initializeTexture ptr (V2 w h) fmt = do 73 | handle <- liftIO GL.genObjectName 74 | tell $ destroyTexture handle 75 | 76 | liftIO $ do 77 | GL.textureBinding GL.Texture2D GL.$= Just handle 78 | 79 | let glfmt = fmt2glpfmt fmt 80 | size = GL.TextureSize2D (fromIntegral w) (fromIntegral h) 81 | pd = GL.PixelData glfmt GL.UnsignedByte ptr 82 | GL.texImage2D GL.Texture2D GL.NoProxy 0 (internalglpfmt glfmt) size 0 pd 83 | GL.generateMipmap' GL.Texture2D 84 | GL.textureFilter GL.Texture2D GL.$= ((GL.Linear', Just GL.Linear'), GL.Linear') 85 | GL.textureWrapMode GL.Texture2D GL.S GL.$= (GL.Repeated, GL.Repeat) 86 | GL.textureWrapMode GL.Texture2D GL.T GL.$= (GL.Repeated, GL.Repeat) 87 | GL.textureFunction GL.$= GL.Replace 88 | 89 | putStrLn $ concat [ 90 | "Loaded ", show fmt, 91 | " texture with dimensions ", show (w, h), 92 | ": ", show handle] 93 | return $ flip Texture fmt 94 | $ OpenGLTexHandle handle (TexSize $ fromEnum <$> V2 w h) 95 | 96 | updateTexture :: Texture -> Ptr a -> V2 Word32 -> V2 Word32 -> IO () 97 | updateTexture (RenderTexture _ _) _ _ _ = putStrLn "Cannot update render texture" 98 | updateTexture tex ptr (V2 x y) (V2 w h) = do 99 | GL.textureBinding GL.Texture2D GL.$= Just (getGLTexObj tex) 100 | 101 | let pd = GL.PixelData (fmt2glpfmt $ getGLTexFmt tex) GL.UnsignedByte ptr 102 | size = GL.TextureSize2D (fromIntegral w) (fromIntegral h) 103 | pos = GL.TexturePosition2D (fromIntegral x) (fromIntegral y) 104 | GL.texSubImage2D GL.Texture2D 0 pos size pd 105 | 106 | createDepthTexture :: V2 Word32 -> ResourceLoader Texture 107 | createDepthTexture (V2 w h) = do 108 | handle <- liftIO $ GL.genObjectName 109 | 110 | liftIO $ do 111 | GL.textureBinding GL.Texture2D GL.$= Just handle 112 | GL.textureWrapMode GL.Texture2D GL.S GL.$= (GL.Repeated, GL.ClampToEdge) 113 | GL.textureWrapMode GL.Texture2D GL.T GL.$= (GL.Repeated, GL.ClampToEdge) 114 | GL.textureFilter GL.Texture2D GL.$= ((GL.Linear', Nothing), GL.Linear') 115 | GL.textureCompareMode GL.Texture2D GL.$= (Just GL.Lequal) 116 | GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.DepthComponent' 117 | (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0 118 | (GL.PixelData GL.DepthComponent GL.UnsignedInt nullPtr) 119 | 120 | rbHandle <- liftIO $ GL.genObjectName 121 | liftIO $ do 122 | GL.bindFramebuffer GL.Framebuffer GL.$= rbHandle 123 | GL.framebufferTexture2D GL.Framebuffer GL.DepthAttachment GL.Texture2D handle 0 124 | GL.drawBuffer GL.$= GL.NoBuffers 125 | GL.readBuffer GL.$= GL.NoBuffers 126 | GL.get (GL.framebufferStatus GL.Framebuffer) >>= 127 | putStrLn . ((++) "Checking framebuffer status...") . show 128 | 129 | GL.depthMask GL.$= GL.Enabled 130 | GL.depthFunc GL.$= Just GL.Lequal 131 | GL.cullFace GL.$= Just GL.Back 132 | GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject 133 | 134 | tell $ destroyFBO rbHandle 135 | tell $ destroyTexture handle 136 | 137 | liftIO $ putStrLn ("Created FBO: " ++ show rbHandle) 138 | >> putStrLn (concat 139 | [ " with texture of dimensions ", show (w, h) 140 | , ": ", show handle 141 | ]) 142 | 143 | let shadowMapSize = TexSize $ fromEnum <$> V2 w h 144 | return $ RenderTexture (OpenGLTexHandle handle shadowMapSize) 145 | $ OpenGLFBOHandle rbHandle 146 | -------------------------------------------------------------------------------- /examples/CubeDemo.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | -------------------------------------------------------------------------------- 4 | import Prelude hiding (id, (.)) 5 | 6 | #if __GLASGOW_HASKELL__ <= 708 7 | import Control.Applicative 8 | #endif 9 | 10 | import Control.Monad.Reader 11 | 12 | #if __GLASGOW_HASKELL__ <= 708 13 | import Data.Traversable (sequenceA) 14 | #endif 15 | 16 | import Data.Maybe (fromJust, fromMaybe) 17 | import Data.Word 18 | 19 | import qualified Graphics.UI.GLFW as GLFW 20 | import qualified Lambency as L 21 | 22 | import System.FilePath 23 | import Paths_lambency 24 | 25 | import Linear.Vector 26 | import Linear.V3 27 | import Linear.V4 28 | import qualified Linear.Quaternion as Quat 29 | 30 | import Control.Wire 31 | 32 | import qualified Control.Wire as W 33 | import FRP.Netwire.Analyze 34 | import FRP.Netwire.Input 35 | import qualified Yoga as Y 36 | --------------------------------------------------------------------------------- 37 | 38 | quitWire :: L.ContWire a Bool 39 | quitWire = (pure True W.>>> keyPressed GLFW.Key'Q) `L.withDefault` pure False 40 | 41 | initialCam :: L.Camera 42 | initialCam = L.mkPerspCamera 43 | -- Pos Dir Up 44 | ((-15) *^ L.localForward) L.localForward L.localUp 45 | (pi / 4) (4.0 / 3.0) 46 | -- near far 47 | 0.1 1000.0 48 | 49 | demoCam :: L.ContWire () L.Camera 50 | demoCam = L.mkFreeCam initialCam 51 | 52 | loadPlane :: L.ResourceLoader L.RenderObject 53 | loadPlane = L.createRenderObject L.plane 54 | $ L.diffuseColoredMaterial $ V3 0.5 0.5 0.5 55 | 56 | plane :: L.ContWire ((), Bool) (Maybe ()) 57 | plane = L.bracketResource loadPlane 58 | $ (L.liftWireRCW (L.quitWire GLFW.Key'E) W.>>>) 59 | $ L.withResource 60 | $ flip L.staticObject xform 61 | where xform = L.uniformScale 10 $ 62 | L.translate (V3 0 (-2) 0) L.identity 63 | 64 | loadBunny :: L.ResourceLoader [L.RenderObject] 65 | loadBunny = do 66 | objFile <- liftIO $ getDataFileName ("examples" "bunnyN" <.> "obj") 67 | L.loadOBJWithDefaultMaterial objFile 68 | $ Just (L.shinyColoredMaterial $ V3 0.26 0.5 0.26) 69 | 70 | bunny :: L.ContWire ((), Bool) (Maybe ()) 71 | bunny = L.bracketResource loadBunny 72 | $ L.withResource 73 | $ foldl (W.>>>) W.mkId . map (`L.staticObject` xform) 74 | where xform = L.rotate (Quat.axisAngle (V3 0 1 0) pi) $ 75 | L.translate (V3 (-4) (-4.8) (-5)) L.identity 76 | 77 | type CubeResources = (L.Texture, L.Sound, [L.RenderObject]) 78 | loadCubeResources :: L.ResourceLoader CubeResources 79 | loadCubeResources = do 80 | tex <- fmap fromJust 81 | $ liftIO (getDataFileName $ "examples" "crate" <.> "png") 82 | >>= L.loadTexture 83 | 84 | objFile <- liftIO $ getDataFileName ("examples" "cube" <.> "obj") 85 | meshes <- L.loadOBJWithDefaultMaterial objFile $ 86 | Just (L.diffuseTexturedMaterial tex) 87 | 88 | sound <- liftIO (getDataFileName $ "examples" "stereol" <.> "wav") 89 | >>= L.loadSound 90 | return (tex, sound, meshes) 91 | 92 | cubeWire :: L.ContWire (a, Bool) (Maybe ()) 93 | cubeWire = 94 | L.bracketResource loadCubeResources 95 | $ L.withResource 96 | $ \(_, sound, ros) -> 97 | playSound sound 3.0 W.>>> 98 | traverse (\ro -> L.mkObject ro (rotate initial)) ros W.>>> pure () 99 | where 100 | playSound :: L.Sound -> Float -> L.GameWire a a 101 | playSound sound p = L.pulseSound sound W.>>> W.for p W.--> 102 | playSound sound p 103 | 104 | rotate :: L.Transform -> L.GameWire a L.Transform 105 | rotate xform = 106 | W.mkPure (\t _ -> let 107 | rotation = Quat.axisAngle L.localUp $ 3.0 * W.dtime t 108 | newxform = L.rotateWorld rotation xform 109 | in (Right newxform, rotate newxform)) 110 | 111 | initial :: L.Transform 112 | initial = L.rotate (Quat.axisAngle (V3 1 0 1) 0.6) $ 113 | L.uniformScale 2.0 L.identity 114 | 115 | lightWire :: L.ContWire a L.Light 116 | lightWire = 117 | let lightPos = 5 *^ V3 (-2) 1 0 118 | lightParams = L.mkLightParams (V3 0.15 0.15 0.15) (V3 1.0 1.0 1.0) 1.0 119 | initial = L.spotlight lightParams lightPos (negate lightPos) (pi/4) 120 | (V3 _ py pz) = fromJust $ L.getLightPosition initial 121 | in 122 | ((arr $ fromMaybe (error "Light wire inhibited?")) W.<<<) 123 | $ ((id &&& quitWire) W.>>>) 124 | $ L.bracketResource (L.addShadowMap initial) 125 | $ L.withResource 126 | $ \l -> (W.timeF W.>>>) $ W.mkSF_ $ \t -> 127 | let newPos = V3 (sin t * 10) py pz 128 | in L.setLightPosition newPos $ 129 | L.setLightDirection (negate newPos) l 130 | 131 | loadFont :: L.ResourceLoader L.Font 132 | loadFont = L.loadTTFont 18 (V3 1 0 0) =<< 133 | liftIO (getDataFileName $ "examples" "kenpixel" <.> "ttf") 134 | 135 | uiWire :: L.ContWire ((), Bool) (Maybe ()) 136 | uiWire = L.bracketResource loadFont 137 | $ L.withResource 138 | $ \font -> 139 | L.screen 140 | [ L.hbox [renderTime font, L.glue] 141 | , L.glue 142 | -- , button 143 | , L.hbox [L.glue, button] 144 | ] 145 | where 146 | background = let 147 | blue :: V4 Word8 148 | blue = V4 0 0 255 255 149 | 150 | yellow :: V4 Word8 151 | yellow = V4 255 255 0 255 152 | in L.WidgetState { 153 | L.idleLogic = L.colorRenderer blue W.mkId, 154 | L.eventHandlers = 155 | [L.WidgetEvent'OnKeyDown GLFW.Key'U $ L.colorRenderer yellow W.mkId] 156 | } 157 | 158 | button = L.Widget 159 | $ Y.setMargin Y.Edge'All 10.0 160 | $ Y.exact 10.0 10.0 background 161 | 162 | lastRenderTime :: L.GameWire a Float 163 | lastRenderTime = W.mkGen_ $ \_ -> do 164 | lastPicoSeconds <- asks L.lastFrameTime 165 | return . Right $ fromIntegral lastPicoSeconds / 1000000000.0 166 | 167 | avgRenderTimeWire :: L.GameWire a String 168 | avgRenderTimeWire = 169 | ("Frame Time (ms): " ++) . show <$> (lastRenderTime W.>>> sAvg 5) 170 | 171 | frameRenderState font = 172 | let idle = L.dynamicTextRenderer font $ W.mkId W.&&& avgRenderTimeWire 173 | in L.WidgetState idle [] 174 | 175 | renderTime font = L.Widget 176 | $ Y.setMargin Y.Edge'Left 5.0 177 | $ Y.setMargin Y.Edge'Top 15.0 178 | $ Y.exact 300.0 50.0 (frameRenderState font) 179 | 180 | game :: L.Game () 181 | game = 182 | L.Game demoCam [lightWire] 183 | $ (id W.&&& quitWire) W.>>> L.joinResources [cubeWire, bunny, plane, uiWire] 184 | 185 | main :: IO () 186 | main = L.runOpenGL 640 480 "Cube Demo" () game 187 | -------------------------------------------------------------------------------- /lib/Lambency/Shader/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | module Lambency.Shader.Base where 4 | 5 | -------------------------------------------------------------------------------- 6 | import Control.Applicative 7 | import Control.Monad.RWS.Strict 8 | import Control.Monad (MonadPlus(..)) 9 | 10 | import Linear 11 | -------------------------------------------------------------------------------- 12 | 13 | ------------------------------------------------------------ 14 | -- Shader variables 15 | 16 | data Sampler1D 17 | data Sampler2D 18 | data Sampler3D 19 | 20 | data Shadow2D 21 | 22 | data ShaderVarTyRep = Matrix2Ty 23 | | Matrix3Ty 24 | | Matrix4Ty 25 | | Matrix3ListTy 26 | | Matrix4ListTy 27 | | Vector2Ty 28 | | Vector3Ty 29 | | Vector4Ty 30 | | Vector2ListTy 31 | | Vector3ListTy 32 | | Vector4ListTy 33 | | IntTy 34 | | IntListTy 35 | | FloatTy 36 | | FloatListTy 37 | | Sampler1DTy 38 | | Sampler2DTy 39 | | Sampler3DTy 40 | | Shadow2DTy 41 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 42 | 43 | data ShaderVarRep = ShdrVarRep { 44 | shdrVarName :: String, 45 | shdrVarID :: Int, 46 | shdrVarTy :: ShaderVarTyRep 47 | } deriving (Show, Eq, Ord) 48 | 49 | newtype ShaderVar a = ShaderVar ShaderVarRep deriving (Show, Eq, Ord) 50 | newtype ShaderVarTy a = ShaderVarTy ShaderVarTyRep deriving (Show, Read, Eq, Ord, Bounded) 51 | 52 | ------------------------------------------------------------ 53 | -- Shader Expressions 54 | 55 | 56 | data UnaryInfix = Negate 57 | deriving(Show, Eq, Ord, Enum, Bounded) 58 | 59 | data UnaryFun = Floor 60 | | Ceiling 61 | | Fract 62 | | Sine 63 | | Cosine 64 | | Normalize 65 | | Length 66 | | CastFloat 67 | deriving(Show, Eq, Ord, Enum, Bounded) 68 | 69 | data UnaryOp = UnaryInfixOp UnaryInfix 70 | | UnaryFunOp UnaryFun 71 | deriving(Show, Eq, Ord) 72 | 73 | data BinaryInfix = Add 74 | | Sub 75 | | Mult 76 | | Div 77 | | GreaterThan 78 | | LessThan 79 | deriving(Show, Eq, Ord, Enum, Bounded) 80 | 81 | data BinaryFunction = Max 82 | | Min 83 | | Dot 84 | | Pow 85 | | Sample1D 86 | | Sample2D 87 | | Sample3D 88 | | Shadow2D 89 | deriving(Show, Eq, Ord, Enum, Bounded) 90 | 91 | data BinaryOp = BinaryInfixOp BinaryInfix 92 | | BinaryFunOp BinaryFunction 93 | deriving(Show, Eq, Ord) 94 | 95 | data TernaryOp = Clamp 96 | | Mix 97 | deriving(Show, Eq, Ord, Enum, Bounded) 98 | 99 | data Constant = ConstMat2 (M22 Float) 100 | | ConstMat3 (M33 Float) 101 | | ConstMat4 (M44 Float) 102 | | ConstVec2f (V2 Float) 103 | | ConstVec3f (V3 Float) 104 | | ConstVec4f (V4 Float) 105 | | ConstVec2i (V2 Int) 106 | | ConstVec3i (V3 Int) 107 | | ConstVec4i (V4 Int) 108 | | ConstFloat Float 109 | | ConstInt Int 110 | deriving (Show, Ord, Eq) 111 | 112 | data VecExpr = Vec2Expr ExprRep ExprRep 113 | | Vec3Expr ExprRep ExprRep ExprRep 114 | | Vec4Expr ExprRep ExprRep ExprRep ExprRep 115 | deriving (Eq, Show) 116 | 117 | data SwizzleVar = SwizzleX | SwizzleY | SwizzleZ | SwizzleW 118 | deriving(Show, Eq, Ord, Enum, Bounded) 119 | 120 | data ExprRep = VarExpr ShaderVarRep 121 | | ConstExpr Constant 122 | | SwizzleExpr ExprRep (SwizzleVar, Maybe SwizzleVar, Maybe SwizzleVar, Maybe SwizzleVar) 123 | | Unary UnaryOp ExprRep 124 | | Binary BinaryOp ExprRep ExprRep 125 | | Ternary TernaryOp ExprRep ExprRep ExprRep 126 | | NewVec VecExpr 127 | deriving (Eq, Show) 128 | 129 | newtype Expr a = Expr ExprRep deriving (Eq, Show) 130 | 131 | ------------------------------------------------------------ 132 | -- Compiled shader statements 133 | 134 | data DeclarationTy = AttributeDeclTy 135 | | UniformDeclTy 136 | | VaryingDeclTy 137 | | ConstDeclTy 138 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 139 | 140 | data Declaration = Attribute ShaderVarRep 141 | | Uniform ShaderVarRep 142 | | Varying ShaderVarRep 143 | | ConstDecl ShaderVarRep ExprRep 144 | deriving (Eq, Show) 145 | 146 | data SpecialVar = VertexPosition 147 | | FragmentColor 148 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 149 | 150 | data Statement = LocalDecl ShaderVarRep (Maybe ExprRep) 151 | | Assignment ShaderVarRep ExprRep 152 | | SpecialAssignment SpecialVar ShaderVarRep 153 | | IfThenElse ExprRep [Statement] [Statement] 154 | 155 | newtype ShaderInput = ShaderInput { getInputVars :: [ShaderVarRep] } 156 | 157 | data ShaderOutputVar = CustomOutput String ShaderVarRep 158 | | SpecialOutput SpecialVar ShaderVarRep 159 | 160 | newtype ShaderOutput = ShaderOutput { getOutputVars :: [ShaderOutputVar] } 161 | 162 | data ShaderType 163 | = VertexShaderTy 164 | | FragmentShaderTy 165 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 166 | 167 | newtype ShaderContext a = 168 | ShdrCtx { compileShdrCode :: RWST 169 | (ShaderInput, ShaderType) -- Reader 170 | ([Declaration], [Statement]) -- Writer 171 | Int -- State (varID) 172 | Maybe a } 173 | deriving (Functor, Applicative, Monad, Alternative, MonadPlus, 174 | MonadReader (ShaderInput, ShaderType), 175 | MonadWriter ([Declaration], [Statement]), 176 | MonadState Int) 177 | 178 | newtype ShaderCode = ShdrCode (ShaderContext ShaderOutput) 179 | 180 | data ShaderProgram = ShaderProgram { 181 | shaderDecls :: [Declaration], 182 | shaderStmts :: [Statement] 183 | } 184 | 185 | data Shader = Shader { 186 | vertexProgram :: ShaderProgram, 187 | fragmentProgram :: ShaderProgram 188 | } 189 | 190 | -------------------------------------------------------------------------------- /lib/Lambency/Vertex.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Vertex ( 2 | Vertex2, 3 | Vertex3, 4 | TVertex3, 5 | OVertex3, 6 | OTVertex3, 7 | 8 | VertexTy, 9 | 10 | getVertex2Position, 11 | getVertex3Position, 12 | getTexVertex3Position, 13 | getNormVertex3Position, 14 | getNormTexVertex3Position, 15 | 16 | addNormalV3, 17 | addNormalTV3, 18 | 19 | addTexCoordV3, 20 | addTexCoordOV3, 21 | 22 | Vertex(..), 23 | 24 | VertexAttributeTy(..), 25 | VertexAttribute(..), 26 | 27 | HasTextureCoordinates(..), 28 | 29 | mkVertex3, 30 | mkVertex2, 31 | mkTexVertex3, 32 | mkNormVertex3, 33 | mkNormTexVertex3, 34 | ) where 35 | 36 | -------------------------------------------------------------------------------- 37 | import Foreign.Storable 38 | 39 | import Linear.V2 40 | import Linear.V3 41 | 42 | import Foreign.Ptr 43 | -------------------------------------------------------------------------------- 44 | 45 | type Vec2f = V2 Float 46 | type Vec3f = V3 Float 47 | 48 | data VertexAttributeTy = FloatAttribTy 49 | | IntAttribTy 50 | | DoubleAttribTy 51 | deriving (Enum, Bounded, Read, Show, Eq, Ord) 52 | 53 | data VertexAttribute = VertexAttribute Int VertexAttributeTy 54 | 55 | data Vertex2 = Vertex2 !Vec2f deriving (Show, Read, Eq, Ord) 56 | data Vertex3 = Vertex3 !Vec3f deriving (Show, Read, Eq, Ord) 57 | data TVertex3 = TVertex3 !Vec3f !Vec2f deriving (Show, Read, Eq, Ord) 58 | data OVertex3 = OVertex3 !Vec3f !Vec3f deriving (Show, Read, Eq, Ord) 59 | data OTVertex3 = OTVertex3 !Vec3f !Vec3f !Vec2f deriving (Show, Read, Eq, Ord) 60 | 61 | data VertexTyRep = Vertex2Ty 62 | | Vertex3Ty 63 | | TVertex3Ty 64 | | OVertex3Ty 65 | | OTVertex3Ty 66 | deriving (Show, Read, Ord, Eq, Bounded, Enum) 67 | 68 | newtype VertexTy a = VertexTy VertexTyRep 69 | 70 | instance Storable Vertex2 where 71 | sizeOf _ = sizeOf (undefined :: Vec2f) 72 | alignment _ = alignment (undefined :: Vec2f) 73 | peekElemOff ptr off = peekElemOff (castPtr ptr) off >>= (return . Vertex2) 74 | pokeElemOff ptr off (Vertex2 p) = pokeElemOff (castPtr ptr) off p 75 | 76 | instance Storable Vertex3 where 77 | sizeOf _ = sizeOf (undefined :: Vec3f) 78 | alignment _ = alignment (undefined :: Vec3f) 79 | peekElemOff ptr off = peekElemOff (castPtr ptr) off >>= (return . Vertex3) 80 | pokeElemOff ptr off (Vertex3 p) = pokeElemOff (castPtr ptr) off p 81 | 82 | instance Storable TVertex3 where 83 | sizeOf _ = (sizeOf (undefined :: Vec3f)) + 84 | (sizeOf (undefined :: Vec2f)) 85 | alignment _ = max (alignment (undefined :: Vec3f)) (alignment (undefined :: Vec2f)) 86 | 87 | peek ptr = do 88 | p <- peek (castPtr ptr) 89 | uv <- peek (castPtr (ptr `plusPtr` 12)) 90 | return $ TVertex3 p uv 91 | 92 | poke ptr (TVertex3 p uv) = do 93 | poke (castPtr ptr) p 94 | poke (castPtr (ptr `plusPtr` 12)) uv 95 | 96 | instance Storable OVertex3 where 97 | sizeOf _ = (sizeOf (undefined :: Vec3f)) + 98 | (sizeOf (undefined :: Vec3f)) 99 | alignment _ = alignment (undefined :: Vec3f) 100 | 101 | peek ptr = do 102 | p <- peek (castPtr ptr) 103 | n <- peek (castPtr (ptr `plusPtr` 12)) 104 | return $ OVertex3 p n 105 | 106 | poke ptr (OVertex3 p n) = do 107 | poke (castPtr ptr) p 108 | poke (castPtr (ptr `plusPtr` 12)) n 109 | 110 | instance Storable OTVertex3 where 111 | sizeOf _ = (sizeOf (undefined :: Vec3f)) + 112 | (sizeOf (undefined :: Vec3f)) + 113 | (sizeOf (undefined :: Vec2f)) 114 | alignment _ = max (alignment (undefined :: Vec3f)) (alignment (undefined :: Vec2f)) 115 | 116 | peek ptr = do 117 | p <- peek (castPtr ptr) 118 | n <- peek (castPtr (ptr `plusPtr` 12)) 119 | uv <- peek (castPtr (ptr `plusPtr` 24)) 120 | return $ OTVertex3 p n uv 121 | 122 | poke ptr (OTVertex3 p n uv) = do 123 | poke (castPtr ptr) p 124 | poke (castPtr (ptr `plusPtr` 12)) n 125 | poke (castPtr (ptr `plusPtr` 24)) uv 126 | 127 | class (Show a, Eq a, Ord a, Storable a) => Vertex a where 128 | getVertexTy :: a -> VertexTy a 129 | getVertexAttributes :: a -> [VertexAttribute] 130 | getAttribNames :: a -> [String] 131 | 132 | instance Vertex Vertex2 where 133 | getVertexTy _ = VertexTy Vertex2Ty 134 | getVertexAttributes _ = [ 135 | VertexAttribute 2 FloatAttribTy] 136 | getAttribNames _ = ["position"] 137 | 138 | instance Vertex Vertex3 where 139 | getVertexTy _ = VertexTy Vertex3Ty 140 | getVertexAttributes _ = [ 141 | VertexAttribute 3 FloatAttribTy] 142 | getAttribNames _ = ["position"] 143 | 144 | instance Vertex TVertex3 where 145 | getVertexTy _ = VertexTy TVertex3Ty 146 | getVertexAttributes _ = [ 147 | VertexAttribute 3 FloatAttribTy, 148 | VertexAttribute 2 FloatAttribTy] 149 | getAttribNames _ = ["position", "texCoord"] 150 | 151 | instance Vertex OVertex3 where 152 | getVertexTy _ = VertexTy OVertex3Ty 153 | getVertexAttributes _ = [ 154 | VertexAttribute 3 FloatAttribTy, 155 | VertexAttribute 3 FloatAttribTy] 156 | getAttribNames _ = ["position", "normal"] 157 | 158 | instance Vertex OTVertex3 where 159 | getVertexTy _ = VertexTy OTVertex3Ty 160 | getVertexAttributes _ = [ 161 | VertexAttribute 3 FloatAttribTy, 162 | VertexAttribute 3 FloatAttribTy, 163 | VertexAttribute 2 FloatAttribTy] 164 | getAttribNames _ = ["position", "normal", "texCoord"] 165 | 166 | class HasTextureCoordinates a where 167 | getTextureCoordinates :: a -> Vec2f 168 | 169 | instance HasTextureCoordinates TVertex3 where 170 | getTextureCoordinates (TVertex3 _ uv) = uv 171 | 172 | instance HasTextureCoordinates OTVertex3 where 173 | getTextureCoordinates (OTVertex3 _ _ uv) = uv 174 | 175 | addNormalV3 :: Vertex3 -> Vec3f -> OVertex3 176 | addNormalV3 (Vertex3 x) = OVertex3 x 177 | 178 | addNormalTV3 :: TVertex3 -> Vec3f -> OTVertex3 179 | addNormalTV3 (TVertex3 x uv) n = OTVertex3 x n uv 180 | 181 | addTexCoordV3 :: Vertex3 -> Vec2f -> TVertex3 182 | addTexCoordV3 (Vertex3 x) = TVertex3 x 183 | 184 | addTexCoordOV3 :: OVertex3 -> Vec2f -> OTVertex3 185 | addTexCoordOV3 (OVertex3 x n) uv = OTVertex3 x n uv 186 | 187 | getVertex3Position :: Vertex3 -> Vec3f 188 | getVertex3Position (Vertex3 x) = x 189 | 190 | getVertex2Position :: Vertex2 -> Vec2f 191 | getVertex2Position (Vertex2 x) = x 192 | 193 | getTexVertex3Position :: TVertex3 -> Vec3f 194 | getTexVertex3Position (TVertex3 x _) = x 195 | 196 | getNormVertex3Position :: OVertex3 -> Vec3f 197 | getNormVertex3Position (OVertex3 x _) = x 198 | 199 | getNormTexVertex3Position :: OTVertex3 -> Vec3f 200 | getNormTexVertex3Position (OTVertex3 x _ _) = x 201 | 202 | mkVertex3 :: Vec3f -> Vertex3 203 | mkVertex3 = Vertex3 204 | 205 | mkVertex2 :: Vec2f -> Vertex2 206 | mkVertex2 = Vertex2 207 | 208 | mkTexVertex3 :: Vec3f -> Vec2f -> TVertex3 209 | mkTexVertex3 = TVertex3 210 | 211 | mkNormVertex3 :: Vec3f -> Vec3f -> OVertex3 212 | mkNormVertex3 = OVertex3 213 | 214 | mkNormTexVertex3 :: Vec3f -> Vec3f -> Vec2f -> OTVertex3 215 | mkNormTexVertex3 = OTVertex3 216 | -------------------------------------------------------------------------------- /lib/Lambency.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module Lambency ( 3 | initLambency, 4 | module Lambency.Bounds, 5 | module Lambency.Camera, 6 | module Lambency.Font, 7 | module Lambency.GameObject, 8 | module Lambency.Light, 9 | module Lambency.Loaders, 10 | module Lambency.Material, 11 | 12 | Mesh, 13 | genNormalsV3, 14 | genNormalsTV3, 15 | genTexCoordsV3, 16 | genTexCoordsOV3, 17 | triangle, cube, plane, quad, 18 | 19 | module Lambency.Renderer, 20 | module Lambency.Shader, 21 | module Lambency.Sprite, 22 | Texture, loadTexture, createSolidTexture, 23 | module Lambency.Transform, 24 | Camera, CameraType, CameraViewDistance, 25 | LightType, Light, 26 | ShaderValue(..), ShaderMap, 27 | Material, 28 | Renderer, RenderFlag(..), RenderObject(..), 29 | OutputAction(..), 30 | TimeStep, 31 | Sprite, 32 | Game(..), GameConfig(..), GameMonad, 33 | GameWire, ContWire(..), ResourceLoader, ResourceContext, ResourceContextWire, 34 | module Lambency.UI, 35 | module Lambency.Utils, 36 | 37 | RendererType(..), 38 | run, runOpenGL, 39 | toggleWireframe, 40 | module Lambency.Sound 41 | ) where 42 | 43 | -------------------------------------------------------------------------------- 44 | import Prelude hiding ((.)) 45 | 46 | import Control.Monad (unless) 47 | import Control.Monad.RWS.Strict 48 | import Control.Wire ((.)) 49 | import qualified Control.Wire as W 50 | 51 | import GHC.Generics (Generic) 52 | 53 | import qualified Graphics.UI.GLFW as GLFW 54 | import qualified Graphics.Rendering.OpenGL as GL 55 | 56 | import Lambency.Bounds 57 | import Lambency.Camera 58 | import Lambency.Font 59 | import Lambency.GameLoop 60 | import Lambency.GameObject 61 | import Lambency.GameSession 62 | import Lambency.Light 63 | import Lambency.Loaders 64 | import Lambency.Material 65 | import Lambency.Mesh 66 | import Lambency.Renderer 67 | import Lambency.Shader 68 | import Lambency.Sound 69 | import Lambency.Sprite 70 | import Lambency.Texture 71 | import Lambency.Transform 72 | import Lambency.Types 73 | import Lambency.UI 74 | import Lambency.Utils 75 | 76 | import System.IO 77 | -------------------------------------------------------------------------------- 78 | 79 | data RendererType 80 | = RendererType'OpenGL 81 | deriving(Eq, Ord, Bounded, Enum, Show, Read, Generic) 82 | 83 | initLambency :: IO () 84 | initLambency = do 85 | putStrLn "Initializing..." 86 | printInfo GL.vendor "Vendor: " 87 | printInfo GL.renderer "Renderer: " 88 | printInfo GL.glVersion "OpenGL Version: " 89 | printInfo GL.shadingLanguageVersion "GLSL Version: " 90 | -- (mapM_ putStrLn) =<< (GL.get GL.glExtensions) 91 | putStrLn "Done initializing..." 92 | where 93 | printInfo :: GL.GettableStateVar String -> String -> IO () 94 | printInfo sv s = GL.get sv >>= putStrLn . (s ++) 95 | 96 | errorCallback :: GLFW.Error -> String -> IO() 97 | errorCallback e s = putStrLn $ concat ["GLFW Error: ", show e, " ", s] 98 | 99 | makeWindow :: Int -> Int -> String -> IO (Maybe GLFW.Window) 100 | makeWindow width height title = do 101 | putStr "Initializing GLFW..." 102 | r <- GLFW.init 103 | unless r $ ioError (userError "Failed!") 104 | putStrLn "Done" 105 | 106 | GLFW.setErrorCallback $ Just errorCallback 107 | putStr $ "Creating window of size " ++ show (width, height) ++ "..." 108 | GLFW.windowHint $ GLFW.WindowHint'Samples (Just 4) 109 | GLFW.windowHint $ GLFW.WindowHint'Resizable False 110 | jm <- GLFW.createWindow width height title Nothing Nothing 111 | m <- case jm of 112 | Nothing -> ioError (userError "Failed!") 113 | Just m' -> return m' 114 | putStrLn "Done." 115 | 116 | GLFW.makeContextCurrent (Just m) 117 | 118 | -- Implement the viewport size to be the framebuffer size 119 | -- in order to properly deal with retina displays... 120 | -- !FIXME! The user should have some say over this 121 | (szx, szy) <- GLFW.getFramebufferSize m 122 | GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral szx) (fromIntegral szy)) 123 | 124 | -- Initial defaults 125 | GL.blend GL.$= GL.Enabled 126 | GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha) 127 | GL.cullFace GL.$= Just GL.Back 128 | initLambency 129 | initSound 130 | GL.dither GL.$= GL.Disabled 131 | 132 | GL.rowAlignment GL.Unpack GL.$= 1 133 | 134 | GL.get GL.errors >>= mapM_ print 135 | 136 | -- !FIXME! Why is this Maybe? 137 | return (Just m) 138 | 139 | destroyWindow :: Maybe GLFW.Window -> IO () 140 | destroyWindow m = do 141 | case m of 142 | (Just win) -> GLFW.destroyWindow win 143 | Nothing -> return () 144 | GLFW.terminate 145 | freeSound 146 | 147 | withWindow :: Int -> Int -> String -> (GLFW.Window -> IO a) -> IO a 148 | withWindow width height title f = do 149 | mwin <- makeWindow width height title 150 | x <- case mwin of 151 | Just w -> f w 152 | Nothing -> do 153 | putStrLn $ concat ["Lambency.hs (withWindow): Could not create window (", 154 | show width, ", ", show height, ", ", title, ")"] 155 | return undefined 156 | destroyWindow mwin 157 | return x 158 | 159 | -- TODO: This function uses a hacky method of quitting the game currently 160 | -- which doesn't release all of the resources associated with the game logic. 161 | -- As such, care should be taken to make sure that you're not actually trying to 162 | -- relaunch GLFW commands within the same window after this function returns. 163 | -- It's OK that we leak resources here since we're usually using this with a 164 | -- call to withWindow... 165 | runWithGLFW :: GLFW.Window -> Renderer -> a -> Game a -> IO () 166 | runWithGLFW win r initialGameObject (Game cam lights (CW logic)) = do 167 | oldBuffering <- hGetBuffering stdout 168 | hSetBuffering stdout NoBuffering 169 | 170 | GLFW.swapInterval 1 171 | 172 | -- Stick in an initial poll events call... 173 | GLFW.pollEvents 174 | 175 | (config, unloadSprite) <- mkLoopConfig r (Just win) 176 | 177 | let -- Amend the game logic such that it actually quits if we hit the little 178 | -- x in the corner of the window. 179 | quitLogic = let mkQuitter w = W.mkGen $ \dt x -> do 180 | needsQuit <- GameMonad 181 | $ liftIO $ GLFW.windowShouldClose win 182 | (res, w') <- W.stepWire w dt (Right x) 183 | if needsQuit 184 | then return (Right Nothing, mkQuitter w') 185 | else return (res, mkQuitter w') 186 | in CW $ mkQuitter logic 187 | 188 | loopState = mkLoopState initialGameObject $ Game cam lights quitLogic 189 | 190 | runGameLoop loopState config 191 | 192 | unloadSprite 193 | hSetBuffering stdout oldBuffering 194 | 195 | run :: RendererType -> Int -> Int -> String -> a -> Game a -> IO () 196 | run RendererType'OpenGL w h title startObject game = 197 | withWindow w h title $ \win -> runWithGLFW win (openGLRenderer win) startObject game 198 | 199 | runOpenGL :: Int -> Int -> String -> a -> Game a -> IO () 200 | runOpenGL = run RendererType'OpenGL 201 | 202 | toggleWireframe :: Bool -> GameMonad () 203 | toggleWireframe b = GameMonad $ tell ([WireframeAction b], mempty) 204 | -------------------------------------------------------------------------------- /lib/Lambency/Material.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Lambency.Material ( 3 | getMatVarName, 4 | 5 | defaultBlinnPhong, 6 | defaultMaskedSprite, 7 | 8 | materialShaderVars, 9 | 10 | createSimpleMaterial, 11 | shinyTexturedMaterial, 12 | diffuseTexturedMaterial, 13 | shinyColoredMaterial, 14 | diffuseColoredMaterial, 15 | 16 | updateMaterialVar3mf, 17 | updateMaterialVar3vf, 18 | updateMaterialVar4vf, 19 | updateMaterialVarf, 20 | updateMaterialVarTex, 21 | 22 | maskedSpriteMaterial, 23 | texturedSpriteMaterial, 24 | 25 | isUnlit, 26 | isDefined, 27 | usesTextures 28 | ) where 29 | 30 | -------------------------------------------------------------------------------- 31 | import Lambency.Types 32 | 33 | import qualified Data.Map as Map 34 | 35 | import Linear 36 | -------------------------------------------------------------------------------- 37 | 38 | getMatVarName :: MaterialVar a -> String 39 | getMatVarName (MaterialVar (n, _)) = n 40 | 41 | defaultBlinnPhong :: Material 42 | defaultBlinnPhong = BlinnPhongMaterial 43 | { diffuseReflectivity = 44 | MaterialVar ("diffuseColor", Just $ Vector3Val $ V3 1 1 1) 45 | , diffuseMap = MaterialVar ("diffuseMap", Nothing) 46 | , specularExponent = 47 | MaterialVar ("specularExponent", Just $ FloatVal 10.0) 48 | , specularReflectivity = 49 | MaterialVar ("specularColor", Just $ Vector3Val $ V3 1 1 1) 50 | , specularMap = MaterialVar ("specularMap", Nothing) 51 | , ambientReflectivity = 52 | MaterialVar ("ambientColor", Just $ Vector3Val $ V3 1 1 1) 53 | , reflectionInfo = Nothing 54 | , normalMod = Nothing 55 | } 56 | 57 | defaultMaskedSprite :: Material 58 | defaultMaskedSprite = MaskedSpriteMaterial 59 | { spriteMaskColor = 60 | MaterialVar ("spriteMaskColor", Just $ Vector4Val $ V4 0 0 0 1) 61 | , spriteMaskMatrix = MaterialVar ("spriteMaskMatrix", Nothing) 62 | , spriteMask = MaterialVar ("spriteMask", Nothing) 63 | } 64 | 65 | matVarToList :: MaterialVar a -> [(String, ShaderValue)] 66 | matVarToList (MaterialVar (_, Nothing)) = [] 67 | matVarToList (MaterialVar (name, Just val)) = [(name, val)] 68 | 69 | materialShaderVars :: Material -> UniformMap 70 | materialShaderVars (BlinnPhongMaterial{..}) = 71 | Map.fromList $ concat 72 | [ matVarToList diffuseReflectivity, 73 | matVarToList diffuseMap, 74 | matVarToList specularExponent, 75 | matVarToList specularReflectivity, 76 | matVarToList specularMap, 77 | matVarToList ambientReflectivity, 78 | case reflectionInfo of 79 | Just info -> concat [ 80 | matVarToList $ indexOfRefraction info, 81 | matVarToList $ reflectionMap info, 82 | matVarToList $ sharpness info 83 | ] 84 | Nothing -> [], 85 | case normalMod of 86 | Just (BumpMap var) -> matVarToList var 87 | Just (NormalMap var) -> matVarToList var 88 | Nothing -> [] 89 | ] 90 | 91 | materialShaderVars (TexturedSpriteMaterial{..}) = 92 | Map.fromList $ concat 93 | [ matVarToList spriteTextureMatrix, 94 | matVarToList spriteTexture, 95 | matVarToList spriteAlpha 96 | ] 97 | 98 | materialShaderVars (MaskedSpriteMaterial{..}) = 99 | Map.fromList $ concat 100 | [ matVarToList spriteMaskMatrix, 101 | matVarToList spriteMask, 102 | matVarToList spriteMaskColor 103 | ] 104 | 105 | materialShaderVars MinimalMaterial = Map.empty 106 | materialShaderVars _ = 107 | error "Lambency.Material (materialShaderVars): Not implemented!" 108 | 109 | createSimpleMaterial :: Material 110 | createSimpleMaterial = defaultBlinnPhong 111 | 112 | shinyTexturedMaterial :: Texture -> Material 113 | shinyTexturedMaterial tex = 114 | defaultBlinnPhong 115 | { diffuseMap = updateMaterialVarTex tex $ diffuseMap defaultBlinnPhong } 116 | 117 | diffuseTexturedMaterial :: Texture -> Material 118 | diffuseTexturedMaterial tex = 119 | defaultBlinnPhong 120 | { diffuseMap = updateMaterialVarTex tex $ diffuseMap defaultBlinnPhong 121 | , specularReflectivity = 122 | let MaterialVar (name, _) = specularReflectivity defaultBlinnPhong 123 | in MaterialVar (name, Nothing) 124 | } 125 | 126 | shinyColoredMaterial :: V3 Float -> Material 127 | shinyColoredMaterial color = 128 | defaultBlinnPhong 129 | { diffuseReflectivity = 130 | updateMaterialVar3vf color $ diffuseReflectivity defaultBlinnPhong 131 | } 132 | 133 | diffuseColoredMaterial :: V3 Float -> Material 134 | diffuseColoredMaterial color = 135 | defaultBlinnPhong 136 | { diffuseReflectivity = 137 | updateMaterialVar3vf color $ diffuseReflectivity defaultBlinnPhong 138 | , specularReflectivity = 139 | let MaterialVar (name, _) = specularReflectivity defaultBlinnPhong 140 | in MaterialVar (name, Nothing) 141 | } 142 | 143 | maskedSpriteMaterial :: Texture -> Material 144 | maskedSpriteMaterial tex = 145 | defaultMaskedSprite 146 | { spriteMaskMatrix = MaterialVar 147 | ( "spriteMaskMatrix" 148 | , Just $ Matrix3Val identity 149 | ), 150 | spriteMask = MaterialVar 151 | ( "spriteMask" 152 | , Just $ TextureVal undefined tex 153 | ) 154 | } 155 | 156 | texturedSpriteMaterial :: Texture -> Material 157 | texturedSpriteMaterial tex = 158 | TexturedSpriteMaterial 159 | { spriteTextureMatrix = 160 | MaterialVar ("spriteMaskMatrix", Just $ Matrix3Val identity) 161 | , spriteTexture = 162 | MaterialVar ("spriteMask", Just $ TextureVal undefined tex) 163 | , spriteAlpha = MaterialVar ("spriteAlpha", Just $ FloatVal 1) 164 | } 165 | 166 | updateMaterialVar3mf :: M33 Float 167 | -> MaterialVar (M33 Float) 168 | -> MaterialVar (M33 Float) 169 | updateMaterialVar3mf x (MaterialVar (n, _)) = 170 | MaterialVar (n, Just $ Matrix3Val x) 171 | 172 | updateMaterialVar3vf :: V3 Float 173 | -> MaterialVar (V3 Float) 174 | -> MaterialVar (V3 Float) 175 | updateMaterialVar3vf x (MaterialVar (n, _)) = 176 | MaterialVar (n, Just $ Vector3Val x) 177 | 178 | updateMaterialVar4vf :: V4 Float 179 | -> MaterialVar (V4 Float) 180 | -> MaterialVar (V4 Float) 181 | updateMaterialVar4vf x (MaterialVar (n, _)) = 182 | MaterialVar (n, Just $ Vector4Val x) 183 | 184 | updateMaterialVarf :: Float -> MaterialVar Float -> MaterialVar Float 185 | updateMaterialVarf x (MaterialVar (n, _)) = MaterialVar (n, Just $ FloatVal x) 186 | 187 | updateMaterialVarTex :: Texture -> MaterialVar Texture -> MaterialVar Texture 188 | updateMaterialVarTex x (MaterialVar (n, _)) = 189 | MaterialVar (n, Just $ TextureVal undefined x) 190 | 191 | isDefined :: MaterialVar a -> Bool 192 | isDefined (MaterialVar (_, Nothing)) = False 193 | isDefined _ = True 194 | 195 | isUnlit :: Material -> Bool 196 | isUnlit (BlinnPhongMaterial {..}) = False 197 | isUnlit _ = True 198 | 199 | usesTextures :: Material -> Bool 200 | usesTextures (BlinnPhongMaterial {..}) = 201 | isDefined diffuseMap || 202 | isDefined specularMap || 203 | (case normalMod of 204 | Just (BumpMap v) -> isDefined v 205 | Just (NormalMap v) -> isDefined v 206 | Nothing -> False) 207 | usesTextures (TexturedSpriteMaterial {..}) = isDefined spriteTexture 208 | usesTextures (MaskedSpriteMaterial {..}) = isDefined spriteMask 209 | usesTextures _ = False 210 | -------------------------------------------------------------------------------- /lambency.cabal: -------------------------------------------------------------------------------- 1 | -- Initial Lambency.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: lambency 5 | version: 0.0.1.0 6 | synopsis: A Real-Time Rendering Framework written in Haskell 7 | -- description: 8 | homepage: none 9 | license: MIT 10 | license-file: LICENSE 11 | author: Pavel Krajcevski 12 | maintainer: krajcevski@gmail.com 13 | -- copyright: 14 | category: Graphics 15 | build-type: Simple 16 | cabal-version: >=1.8 17 | data-files: font.png 18 | examples/*.obj 19 | examples/*.png 20 | -- examples/*.jpg 21 | examples/*.wav 22 | examples/*.ttf 23 | data-dir: assets 24 | 25 | flag examples 26 | description: Build examples 27 | default: False 28 | 29 | library 30 | hs-source-dirs: lib 31 | extensions: CPP 32 | exposed-modules: Lambency 33 | Lambency.Types 34 | other-modules: Lambency.Bounds 35 | Lambency.Camera 36 | Lambency.Font 37 | Lambency.Light 38 | Lambency.Material 39 | Lambency.Mesh 40 | 41 | Lambency.GameLoop 42 | Lambency.GameObject 43 | Lambency.GameSession 44 | 45 | Lambency.Renderer 46 | Lambency.Renderer.OpenGL.Texture 47 | Lambency.Renderer.OpenGL.Render 48 | 49 | Lambency.ResourceLoader 50 | 51 | Lambency.Loaders 52 | Lambency.Loaders.OBJLoader 53 | Lambency.Loaders.MTLLoader 54 | Lambency.Loaders.Utils 55 | 56 | Lambency.Shader 57 | Lambency.Shader.Base 58 | Lambency.Shader.Expr 59 | Lambency.Shader.OpenGL 60 | Lambency.Shader.Optimization 61 | Lambency.Shader.Optimization.RemoveUnused 62 | Lambency.Shader.Program 63 | Lambency.Shader.Var 64 | 65 | Lambency.Sprite 66 | Lambency.Texture 67 | Lambency.Transform 68 | Lambency.Vertex 69 | Lambency.UI 70 | Lambency.Utils 71 | Lambency.Sound 72 | 73 | Paths_lambency 74 | 75 | ghc-options: -Wall -O3 76 | build-depends: base > 4, 77 | array, 78 | bytestring, 79 | comonad, 80 | containers, 81 | filepath, 82 | freetype2, 83 | GLFW-b >= 3.2.1.0, 84 | hashable >= 1.3, 85 | HCodecs, 86 | JuicyPixels >= 3.2, 87 | linear >= 1.20, 88 | mtl >= 2.1.2, 89 | netwire >= 5.0.0, 90 | netwire-input >= 0.0.3, 91 | netwire-input-glfw >= 0.0.9, 92 | OpenAL, 93 | OpenGL >= 2.9.2.0, 94 | OpenGLRaw >= 3.1, 95 | parsec >= 3.1.7, 96 | profunctors, 97 | semigroups, 98 | stm >= 2.4, 99 | text, 100 | time, 101 | vector, 102 | yoga >= 0.0.0.2, 103 | 104 | -- Eventually replace these... 105 | directory 106 | 107 | -------------------------------------------------------------------------------- 108 | -- 109 | -- Tools 110 | -- 111 | -------------------------------------------------------------------------------- 112 | 113 | executable lobjview 114 | main-is: OBJViewer.hs 115 | hs-source-dirs: tools 116 | extensions: CPP 117 | ghc-options: -Wall -rtsopts -O3 118 | build-depends: base > 4, 119 | GLFW-b, 120 | lambency, 121 | linear >= 1.20, 122 | netwire >= 5.0.0, 123 | netwire-input, 124 | mtl >= 2.1.2, 125 | directory 126 | 127 | -------------------------------------------------------------------------------- 128 | -- 129 | -- Examples 130 | -- 131 | -------------------------------------------------------------------------------- 132 | 133 | executable lambcubedemo 134 | main-is: CubeDemo.hs 135 | hs-source-dirs: examples 136 | other-modules: Paths_lambency 137 | ghc-options: -Wall -rtsopts -O3 138 | extensions: CPP 139 | build-depends: base > 4, 140 | netwire >= 5.0.0, 141 | GLFW-b, 142 | lambency, 143 | linear >= 1.20, 144 | netwire-input, 145 | mtl, 146 | containers, 147 | directory, 148 | filepath, 149 | yoga >= 0.0.0.1 150 | 151 | if flag(examples) 152 | buildable: True 153 | else 154 | buildable: False 155 | 156 | executable lambpong 157 | main-is: Pong.hs 158 | hs-source-dirs: examples 159 | other-modules: Paths_lambency 160 | ghc-options: -Wall -rtsopts -O3 161 | extensions: CPP 162 | build-depends: base > 4, 163 | netwire >= 5.0.0, 164 | netwire-input >= 0.0.3, 165 | GLFW-b, 166 | lambency, 167 | linear >= 1.20, 168 | lens, 169 | mtl, 170 | containers, 171 | directory, 172 | filepath 173 | 174 | if flag(examples) 175 | buildable: True 176 | else 177 | buildable: False 178 | 179 | executable lambshooter 180 | main-is: Shooter.hs 181 | hs-source-dirs: examples 182 | ghc-options: -Wall -rtsopts -O3 183 | extensions: CPP 184 | build-depends: base > 4, 185 | netwire >= 5.0.0, 186 | netwire-input >= 0.0.3, 187 | GLFW-b, 188 | lambency, 189 | linear >= 1.20, 190 | mtl, 191 | containers, 192 | directory, 193 | filepath 194 | 195 | if flag(examples) 196 | buildable: True 197 | else 198 | buildable: False 199 | 200 | executable lambmovesquare 201 | main-is: MovingSquare.hs 202 | hs-source-dirs: examples 203 | ghc-options: -Wall -O3 204 | build-depends: base < 5, 205 | netwire >= 5.0.0, 206 | netwire-input >= 0.0.3, 207 | GLFW-b, 208 | lambency, 209 | linear >= 1.20, 210 | mtl, 211 | containers 212 | 213 | if flag(examples) 214 | buildable: True 215 | else 216 | buildable: False 217 | -------------------------------------------------------------------------------- /lib/Lambency/GameLoop.hs: -------------------------------------------------------------------------------- 1 | module Lambency.GameLoop ( 2 | GameLoopState, mkLoopState, 3 | GameLoopConfig, mkLoopConfig, 4 | runGameLoop 5 | ) where 6 | 7 | -------------------------------------------------------------------------------- 8 | import Control.Monad (when) 9 | import Control.Monad.Reader 10 | import Control.Monad.State 11 | import Control.Monad.RWS.Strict 12 | import qualified Control.Wire as W 13 | 14 | import qualified Graphics.UI.GLFW as GLFW 15 | import qualified Graphics.Rendering.OpenGL as GL 16 | import Data.Time 17 | 18 | import FRP.Netwire.Input.GLFW 19 | 20 | import Lambency.ResourceLoader 21 | import Lambency.Sound 22 | import Lambency.Sprite 23 | import Lambency.Texture 24 | import Lambency.Types 25 | import Lambency.GameSession 26 | 27 | import System.CPUTime 28 | 29 | import Linear 30 | -------------------------------------------------------------------------------- 31 | 32 | maximumFramerate :: NominalDiffTime 33 | maximumFramerate = fromRational . toRational $ (1.0 / 10.0 :: Double) 34 | 35 | -- When we handle actions, only really print logs and play any sounds 36 | -- that may need to start or stop. 37 | handleAction :: OutputAction -> IO () 38 | handleAction (SoundAction sound cmd) = handleCommand sound cmd 39 | handleAction (LogAction s) = putStrLn s 40 | handleAction (WireframeAction True) = GL.polygonMode GL.$= (GL.Line, GL.Line) 41 | handleAction (WireframeAction False) = GL.polygonMode GL.$= (GL.Fill, GL.Fill) 42 | 43 | step :: a -> Game a -> TimeStep -> 44 | GameMonad (Maybe a, Camera, [Light], Game a) 45 | step go game t = do 46 | (Right cam, nCamWire) <- 47 | W.stepWire (getContinuousWire $ mainCamera game) t (Right ()) 48 | (lights, lwires) <- 49 | collect <$> 50 | mapM (\w -> W.stepWire w t $ Right ()) (getContinuousWire <$> dynamicLights game) 51 | (Right result, gameWire) <- 52 | W.stepWire (getContinuousWire $ gameLogic game) t (Right go) 53 | case result of 54 | Nothing -> return (result, cam, lights, newGame nCamWire lwires W.mkEmpty) 55 | Just x -> return (x `seq` result, cam, lights, newGame nCamWire lwires gameWire) 56 | where 57 | collect :: [(Either e b, GameWire a b)] -> ([b], [GameWire a b]) 58 | collect [] = ([], []) 59 | collect ((Left _, _) : _) = error "Internal -- Light wire inhibited?" 60 | collect ((Right obj, wire) : rest) = (obj : objs, wire : wires) 61 | where 62 | (objs, wires) = collect rest 63 | 64 | newGame cam lights logic = 65 | Game { mainCamera = CW cam 66 | , dynamicLights = CW <$> lights 67 | , gameLogic = CW logic 68 | } 69 | 70 | data GameLoopConfig = GameLoopConfig { 71 | gameRenderer :: Renderer, 72 | simpleQuadSprite :: Sprite, 73 | glfwInputControl :: Maybe GLFWInputControl, 74 | windowDimensions :: V2 Int 75 | } 76 | 77 | mkLoopConfig :: Renderer -> Maybe GLFW.Window -> IO (GameLoopConfig, IO ()) 78 | mkLoopConfig r win' = do 79 | -- !FIXME! Use fully opaque 'mask' texture that we can change the color and 80 | -- size for dynamically. This isn't the best way to do this, but it'll work. 81 | (sprite, unloadSprite) <- 82 | runResourceLoader r $ createSolidTexture (pure 255) 83 | >>= loadStaticSpriteWithMask 84 | 85 | -- Collect the window dimensions. TODO: This should be done every frame so 86 | -- that we can properly update our UI on state changes. For now, we just tell 87 | -- GLFW to prevent the user from resizing the window, but that need not be a 88 | -- restriction. 89 | (winDims, ictl) <- case win' of 90 | Just win -> do 91 | winDims <- uncurry V2 <$> liftIO (GLFW.getWindowSize win) 92 | ictl <- Just <$> mkInputControl win 93 | return (winDims, ictl) 94 | Nothing -> return (V2 0 0, Nothing) 95 | 96 | return (GameLoopConfig r sprite ictl winDims, unloadSprite) 97 | 98 | data GameLoopState a = GameLoopState { 99 | currentGameValue :: a, 100 | currentGameLogic :: Game a, 101 | currentGameSession :: GameSession, 102 | currentPhysicsAccum :: NominalDiffTime, 103 | lastFramePicoseconds :: Integer 104 | } 105 | 106 | mkLoopState :: a -> Game a -> GameLoopState a 107 | mkLoopState initialVal initGame = GameLoopState 108 | { currentGameValue = initialVal 109 | , currentGameLogic = initGame 110 | , currentGameSession = mkGameSession 111 | , currentPhysicsAccum = toEnum 0 112 | , lastFramePicoseconds = 0 113 | } 114 | 115 | type GameLoopM a = ReaderT GameLoopConfig (StateT (GameLoopState a) IO) 116 | 117 | runLoop :: UTCTime -> GameLoopM a () 118 | runLoop prevFrameTime = do 119 | (GameLoopState _ _ _ accumulator _) <- get 120 | -- Step 121 | thisFrameTime <- liftIO getCurrentTime 122 | let newAccum = accumulator + (diffUTCTime thisFrameTime prevFrameTime) 123 | modify $ \ls -> ls { currentPhysicsAccum = min newAccum maximumFramerate } 124 | (go, (nextsession, accum), nextGame) <- stepGame 125 | 126 | case go of 127 | Just gobj -> do 128 | ls <- get 129 | put $ GameLoopState gobj nextGame nextsession accum (lastFramePicoseconds ls) 130 | runLoop thisFrameTime 131 | Nothing -> return () 132 | 133 | runGameLoop :: GameLoopState a -> GameLoopConfig -> IO () 134 | runGameLoop st config = do 135 | curTime <- getCurrentTime 136 | evalStateT (runReaderT (runLoop curTime) config) st 137 | 138 | type TimeStepper = (GameSession, NominalDiffTime) 139 | 140 | stepGame :: GameLoopM a (Maybe a, TimeStepper, Game a) 141 | stepGame = do 142 | (GameLoopState go game session accum _) <- get 143 | if (accum < physicsDeltaUTC) 144 | then return (Just go, (session, accum), game) 145 | else runGame 146 | 147 | runGame :: GameLoopM a (Maybe a, TimeStepper, Game a) 148 | runGame = do 149 | gameLoopConfig <- ask 150 | gls <- get 151 | (hasInput, ipt) <- liftIO $ case glfwInputControl gameLoopConfig of 152 | Just glfwIpt -> getInput glfwIpt >>= (\x -> return (True, x)) 153 | Nothing -> return (False, emptyGLFWState) 154 | 155 | -- Retreive the next time step from our game session 156 | (ts, nextSess) <- liftIO $ W.stepSession (currentGameSession gls) 157 | 158 | let 159 | -- The game step is the complete GameMonad computation that 160 | -- produces four values: Either inhibition or a new game value 161 | -- A new camera, a list of dynamic lights, and the next simulation 162 | -- wire 163 | gameStep = step (currentGameValue gls) (currentGameLogic gls) ts 164 | 165 | -- We need to render if we're going to fall below the physics threshold 166 | -- on the next frame. This simulates a while loop. If we don't fall 167 | -- through this threshold, we will perform another physics step before 168 | -- we finally decide to render. 169 | accum = currentPhysicsAccum gls 170 | 171 | winDims = windowDimensions gameLoopConfig 172 | renderTime = lastFramePicoseconds gls 173 | sprite = simpleQuadSprite gameLoopConfig 174 | frameConfig = GameConfig (gameRenderer gameLoopConfig) renderTime winDims sprite 175 | 176 | -- This is the meat of the step routine. This calls runRWS on the 177 | -- main game wire, and uses the results to figure out what needs 178 | -- to be done. 179 | ((result, cam, lights, nextGame), newIpt, (actions, renderActs)) <- 180 | liftIO $ runRWST (nextFrame gameStep) frameConfig ipt 181 | 182 | -- The ReaderT RenderConfig IO program that will do the actual rendering 183 | let accumRemainder = accum - physicsDeltaUTC 184 | needsRender = case result of 185 | Nothing -> False 186 | Just _ -> accumRemainder < physicsDeltaUTC 187 | 188 | frameTime <- 189 | if needsRender 190 | then liftIO $ do 191 | t <- getCPUTime 192 | render (gameRenderer gameLoopConfig) lights cam renderActs 193 | t' <- getCPUTime 194 | return (t' - t) 195 | else return renderTime 196 | 197 | _ <- liftIO $ do 198 | -- Actually do the associated actions 199 | mapM_ handleAction actions 200 | 201 | -- Poll the input 202 | when hasInput $ case glfwInputControl gameLoopConfig of 203 | Just glfwIpt -> pollGLFW newIpt glfwIpt >> return () 204 | Nothing -> return () 205 | 206 | -- If our main wire inhibited, return immediately. 207 | case result of 208 | Just obj -> do 209 | put $ GameLoopState obj nextGame nextSess accumRemainder frameTime 210 | stepGame 211 | Nothing -> return (result, (nextSess, accum), nextGame) 212 | -------------------------------------------------------------------------------- /lib/Lambency/Font.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Font ( 2 | Font, ModifiedFont, IsFont, 3 | loadSystemFont, 4 | loadTTFont, 5 | renderUIString, 6 | stringWidth, stringHeight, 7 | setFontColor, 8 | ) where 9 | 10 | -------------------------------------------------------------------------------- 11 | #if __GLASGOW_HASKELL__ <= 708 12 | import Control.Applicative 13 | #endif 14 | import Control.Monad 15 | import Control.Monad.Reader 16 | 17 | import Data.Array.Storable 18 | import Data.Bits 19 | import Data.List (mapAccumL, foldl') 20 | import qualified Data.Map as Map 21 | import Data.Word 22 | 23 | import Foreign.Storable 24 | 25 | import FreeType 26 | 27 | import Lambency.ResourceLoader 28 | import Lambency.Sprite 29 | import Lambency.Texture 30 | import Lambency.Types 31 | import Lambency.Utils 32 | 33 | import Linear hiding (trace) 34 | 35 | import Paths_lambency 36 | import System.FilePath 37 | -------------------------------------------------------------------------------- 38 | 39 | -- Helpers 40 | 41 | logBase2 :: Int -> Int 42 | #if __GLASGOW_HASKELL__ <= 708 43 | logBase2 1 = 0 44 | logBase2 x 45 | | x <= 0 = error "Log is undefined!" 46 | | otherwise = 1 + logBase2 (x `shiftR` 1) 47 | #else 48 | logBase2 x = finiteBitSize x - 1 - countLeadingZeros x 49 | #endif 50 | 51 | -------------------------------------------------------------------------------- 52 | newtype Font = Font 53 | { getOrigGlyph :: Char -> Maybe (SpriteFrame, (V2 Int, V2 Int)) } 54 | newtype ModifiedFont = MF { 55 | getModifiedGlyph :: Char -> Maybe (SpriteFrame, (V2 Int, V2 Int)) 56 | } 57 | 58 | class IsFont a where 59 | getGlyph :: a -> Char -> Maybe (SpriteFrame, (V2 Int, V2 Int)) 60 | 61 | instance IsFont Font where 62 | getGlyph = getOrigGlyph 63 | 64 | instance IsFont ModifiedFont where 65 | getGlyph = getModifiedGlyph 66 | 67 | glyphSize :: Font -> Char -> (V2 Float, V2 Float) 68 | glyphSize font c = 69 | case (getGlyph font c) of 70 | Nothing -> (zero, zero) 71 | Just (_, (adv, off)) -> (fmap fromIntegral adv, fmap fromIntegral off) 72 | 73 | renderUIString :: Font -> String -> V2 Float -> GameMonad () 74 | renderUIString _ "" _ = return () 75 | renderUIString font str pos = let 76 | glyphSizes :: [(V2 Float, V2 Float)] 77 | glyphSizes = map (glyphSize font) str 78 | 79 | positions :: [V2 Float] 80 | positions = let 81 | helper p (_, off) [] = [(p ^+^ off)] 82 | helper p (adv, off) (a:as) = (p ^+^ off) : (helper (p ^+^ adv) a as) 83 | in 84 | helper pos (head glyphSizes) (tail glyphSizes) 85 | 86 | renderCharAtPos :: Char -> V2 Float -> GameMonad () 87 | renderCharAtPos ' ' _ = return () -- no need to render spaces... 88 | renderCharAtPos c p = 89 | case (getGlyph font c) of 90 | Nothing -> return () 91 | Just (f, _) -> 92 | let V2 _ glyphSzY = fmap fromIntegral $ spriteSize f 93 | fakeSprite = Sprite (cycleSingleton f) 94 | in renderUISprite fakeSprite $ p ^-^ (V2 0 glyphSzY) 95 | in do 96 | mapM_ (uncurry renderCharAtPos) $ zip str positions 97 | 98 | stringHeight :: Font -> String -> Float 99 | stringHeight _ "" = 0 100 | stringHeight f str = foldl' max 0 sizes 101 | where 102 | sizes :: [Float] 103 | sizes = map (getGlyphHeight . getGlyph f) str 104 | 105 | getGlyphHeight :: Maybe (SpriteFrame, a) -> Float 106 | getGlyphHeight Nothing = 0.0 107 | getGlyphHeight (Just (frame, _)) = 108 | let V2 _ y = fromIntegral <$> spriteSize frame in y 109 | 110 | stringWidth :: Font -> String -> Float 111 | stringWidth _ "" = 0 112 | stringWidth f str = foldl' (+) 0 sizes 113 | where 114 | sizes :: [Float] 115 | sizes = map (getX . fst . glyphSize f) str 116 | 117 | getX (V2 x _) = x 118 | 119 | mkFont :: Sprite -> [Char] -> [V2 Int] -> [V2 Int] -> Font 120 | mkFont sprite string advances offsets = 121 | Font 122 | $ flip Map.lookup 123 | $ Map.fromList 124 | $ zip string (zip (cyclicToList $ spriteFrames sprite) (zip advances offsets)) 125 | 126 | charString :: [Char] 127 | charString = " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ" 128 | ++ "[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" 129 | 130 | loadSystemFont :: V3 Float -> ResourceLoader Font 131 | loadSystemFont (V3 r g b) = let 132 | systemOffsets = [V2 x 0 | x <- [0,14..]] 133 | systemSizes = repeat (V2 13 24) 134 | in do 135 | fname <- liftIO $ getDataFileName ("font" <.> "png") 136 | Just tex <- loadTexture fname 137 | Just s <- loadAnimatedSpriteWithMask tex systemSizes systemOffsets 138 | let sprite = changeSpriteColor (V4 r g b 1) s 139 | return $ mkFont sprite charString (repeat zero) (repeat zero) 140 | 141 | setFontColor :: IsFont fnt => V3 Float -> fnt -> ModifiedFont 142 | setFontColor (V3 r g b) fnt = MF $ \c -> do 143 | (f, x) <- getGlyph fnt c 144 | return (changeSpriteFrameColor (V4 r g b 1) f, x) 145 | 146 | -------------------------------------------------------------------------------- 147 | -- Freetype fonts 148 | 149 | analyzeGlyph :: FT_Face -> (Int, Int) -> Char -> IO (Int, Int) 150 | analyzeGlyph ft_face (widthAccum, maxHeight) c = do 151 | ft_Load_Char ft_face (toEnum . fromEnum $ c) FT_LOAD_RENDER 152 | 153 | -- Get the glyph 154 | g <- frGlyph <$> peek ft_face 155 | 156 | -- Get the bitmap for the glyph 157 | bm <- gsrBitmap <$> peek g 158 | 159 | -- Figure out the rows and height of the bitmap 160 | return (widthAccum + (fromEnum $ bWidth bm), max maxHeight (fromEnum $ bRows bm)) 161 | 162 | getGlyphAdvanceOffset :: FT_Face -> Char -> IO (V2 Int, V2 Int) 163 | getGlyphAdvanceOffset ft_face c = do 164 | ft_Load_Char ft_face (toEnum . fromEnum $ c) FT_LOAD_RENDER 165 | 166 | -- Get the glyph 167 | gs <- (frGlyph <$> peek ft_face) >>= peek 168 | 169 | -- Get the advance and offset 170 | let FT_Vector advx advy = gsrAdvance gs 171 | offx = gsrBitmap_left gs 172 | offy = gsrBitmap_top gs 173 | 174 | return $ (fmap fromIntegral $ V2 advx advy, fmap fromIntegral $ V2 offx offy) 175 | 176 | uploadGlyph :: Renderer -> FT_Face -> Texture -> Int -> Char -> IO (Int) 177 | uploadGlyph r ft_face tex widthAccum c = do 178 | ft_Load_Char ft_face (cvt c) FT_LOAD_RENDER 179 | g <- frGlyph <$> peek ft_face 180 | bm <- gsrBitmap <$> peek g 181 | updateTexture r 182 | tex 183 | (bBuffer bm) 184 | (V2 (cvt widthAccum) 0) 185 | (cvt <$> (V2 (bWidth bm) (bRows bm))) 186 | return (widthAccum + (cvt $ bWidth bm)) 187 | where 188 | cvt :: (Enum a, Enum b) => a -> b 189 | cvt = toEnum . fromEnum 190 | 191 | loadTTFont :: Int -> V3 Float -> FilePath -> ResourceLoader Font 192 | loadTTFont fontSize (V3 fontR fontG fontB) filepath = do 193 | (texW, texH, texZeroA, ft_face) <- liftIO $ do 194 | -- Create local copy of freetype library... this will free itself once it 195 | -- goes out of scope... 196 | ft_library <- ft_Init_FreeType 197 | 198 | -- Load the font 199 | ft_face <- ft_New_Face ft_library filepath 0 200 | 201 | -- Set the pixel size 202 | ft_Set_Pixel_Sizes ft_face 0 (toEnum . fromEnum $ fontSize) 203 | 204 | -- Figure out the width and height of the bitmap that we need... 205 | (texW, texH) <- let nextPower2 = (shiftL 1) . (+ 1) . logBase2 206 | updateWH (x, y) = (nextPower2 x, nextPower2 y) 207 | in updateWH <$> foldM (analyzeGlyph ft_face) (0, 0) charString 208 | 209 | -- Create a texture to store all of the glyphs 210 | texZeroA <- ((newArray (1, texW*texH) 0) :: IO (StorableArray Int Word8)) 211 | return (texW, texH, texZeroA, ft_face) 212 | 213 | r <- ask 214 | tex <- runLoaderWith (withStorableArray texZeroA) $ \ptr -> do 215 | mkTexture r ptr (fromIntegral <$> V2 texW texH) Alpha8 216 | 217 | -- Place each glyph into the texture 218 | liftIO $ foldM_ (uploadGlyph r ft_face tex) 0 charString 219 | 220 | -- Generate info for our rendering 221 | advOffs <- liftIO $ mapM (getGlyphAdvanceOffset ft_face) charString 222 | let advances = map (fmap (flip div 64) . fst) advOffs 223 | offsets = map snd advOffs 224 | 225 | sizes <- liftIO $ mapM (analyzeGlyph ft_face (0, 0)) charString 226 | let texOffsets = snd $ mapAccumL (\a (w, _) -> (a + w, V2 a 0)) 0 sizes 227 | sizesV = map (\(x, y) -> V2 x y) sizes 228 | fontColor = V4 fontR fontG fontB 1 229 | 230 | Just s <- loadAnimatedSpriteWithMask tex sizesV texOffsets 231 | return $ mkFont (changeSpriteColor fontColor s) charString advances offsets 232 | -------------------------------------------------------------------------------- /lib/Lambency/GameObject.hs: -------------------------------------------------------------------------------- 1 | module Lambency.GameObject ( 2 | wireFrom, contWireFrom, liftWire, liftWireRCW, 3 | bracketResource, withResource, joinResources, withDefault, 4 | transformedContext, transformedResourceContext, 5 | clippedContext, clippedResourceContext, 6 | withSubResource, 7 | mkContWire, stepContWire, 8 | doOnce, doOnceWithInput, everyFrame, 9 | quitWire, 10 | mkObject, 11 | staticObject, 12 | withVelocity, 13 | pulseSound 14 | ) where 15 | 16 | -------------------------------------------------------------------------------- 17 | import Control.Arrow 18 | import Control.Monad 19 | import Control.Monad.Reader 20 | import Control.Monad.Writer 21 | import Control.Wire 22 | 23 | import Data.Maybe 24 | import Data.Either (isLeft) 25 | import Data.Foldable 26 | import Data.Semigroup () 27 | 28 | import Lambency.Renderer 29 | import Lambency.Sound 30 | import Lambency.Transform 31 | import Lambency.Types 32 | 33 | import Prelude hiding ((.), id) 34 | 35 | import qualified Graphics.UI.GLFW as GLFW 36 | import FRP.Netwire.Input 37 | 38 | import Linear.Vector 39 | -------------------------------------------------------------------------------- 40 | 41 | wireFrom :: GameMonad a -> (a -> GameWire b c) -> GameWire b c 42 | wireFrom prg fn = mkGen $ \dt val -> do 43 | seed <- prg 44 | stepWire (fn seed) dt (Right val) 45 | 46 | contWireFrom :: GameMonad a -> (a -> ContWire b c) -> ContWire b c 47 | contWireFrom prg fn = mkContWire $ \dt val -> do 48 | seed <- prg 49 | stepContWire (fn seed) dt val 50 | 51 | doOnce :: GameMonad () -> GameWire a a 52 | doOnce pgm = wireFrom pgm $ const Control.Wire.id 53 | 54 | doOnceWithInput :: (a -> GameMonad ()) -> GameWire a a 55 | doOnceWithInput fn = mkGenN $ \x -> fn x >> return (Right x, mkId) 56 | 57 | everyFrame :: (a -> GameMonad b) -> ContWire a b 58 | everyFrame fn = CW $ mkGen_ $ \x -> Right <$> (fn x) 59 | 60 | mkObject :: RenderObject -> GameWire a Transform -> GameWire a a 61 | mkObject ro xfw = mkGen $ \dt val -> do 62 | (xform, nextWire) <- stepWire xfw dt (Right val) 63 | case xform of 64 | Right xf -> addRenderAction xf ro >> return (Right val, mkObject ro nextWire) 65 | Left i -> return (Left i, mkObject ro nextWire) 66 | 67 | staticObject :: RenderObject -> Transform -> GameWire a a 68 | staticObject ro = mkObject ro . mkConst . Right 69 | 70 | -- | `transformedContext a b` runs b as if all actions within it were rendered 71 | -- with the transform produced by a 72 | transformedContext :: GameWire a Transform -> GameWire a b -> GameWire a b 73 | transformedContext xfw w = mkGen $ \dt x -> do 74 | (xfResult, xfw') <- stepWire xfw dt (Right x) 75 | case xfResult of 76 | Right xf -> 77 | addTransformedRenderAction xf $ 78 | second (transformedContext xfw') <$> stepWire w dt (Right x) 79 | Left i -> return (Left i, transformedContext xfw' w) 80 | 81 | clippedContext :: GameWire a b -> GameWire b c -> GameWire a c 82 | clippedContext cw w = mkGen $ \dt x -> 83 | addClippedRenderAction (stepWire cw dt (Right x)) $ \(clipResult, cw') -> 84 | case clipResult of 85 | Right clip -> second (clippedContext cw') <$> stepWire w dt (Right clip) 86 | Left i -> return (Left i, clippedContext cw' w) 87 | 88 | withVelocity :: (Monad m, Semigroup s, Monoid s) => 89 | Transform -> Wire (Timed Float s) e m a Vec3f -> 90 | Wire (Timed Float s) e m a Transform 91 | withVelocity initial velWire = velWire >>> (moveXForm initial) 92 | where moveXForm :: (Monad m, Semigroup s, Monoid s) => 93 | Transform -> Wire (Timed Float s) e m Vec3f Transform 94 | moveXForm xf = mkPure $ \t vel -> let 95 | newxform = translate (dtime t *^ vel) xf 96 | in (Right newxform, moveXForm newxform) 97 | 98 | pulseSound :: Sound -> GameWire a a 99 | pulseSound = doOnce . startSound 100 | 101 | loadResources :: ResourceLoader a -> GameMonad (a, IO ()) 102 | loadResources (ResourceLoader loadPrg) = GameMonad $ do 103 | rr <- renderer <$> ask 104 | liftIO $ runWriterT (runReaderT loadPrg rr) 105 | 106 | -- | Runs the initial loading program and uses the resource until the generated 107 | -- wire inhibits, at which point it unloads the resource. Once the resource is 108 | -- freed, the resulting wire returns Nothing indefinitely. The resulting wire 109 | -- also takes a signal to terminate from its input. 110 | bracketResource :: ResourceLoader r 111 | -> ResourceContextWire r a b 112 | -> ContWire (a, Bool) (Maybe b) 113 | bracketResource load (RCW rcw) = CW $ mkGen $ \dt x -> do 114 | -- TODO: Maybe should restrict this to certain types of resources? 115 | (resource, unload) <- loadResources load 116 | stepWire (go unload resource rcw) dt (Right x) 117 | where 118 | go unload res w = mkGen $ \dt (x, quitSignal) -> 119 | let quit = GameMonad $ do 120 | _ <- liftIO unload 121 | return (Right Nothing, pure Nothing) 122 | in if quitSignal then quit else do 123 | (result, w') <- runReaderT (stepWire w dt (Right x)) res 124 | if isLeft result then quit else return (Just <$> result, go unload res w') 125 | 126 | liftWireRCW :: GameWire a b -> ResourceContextWire r a b 127 | liftWireRCW = RCW . liftWire 128 | 129 | liftWire :: (Monad m, MonadTrans t, Monad (t m)) 130 | => Wire s e m a b -> Wire s e (t m) a b 131 | liftWire = mapWire lift 132 | 133 | withResource :: (r -> GameWire a b) -> ResourceContextWire r a b 134 | withResource wireGen = RCW $ mkGen $ \dt x -> do 135 | (r, w) <- second liftWire <$> 136 | (ReaderT $ \r -> stepWire (wireGen r) dt (Right x)) 137 | return (r, w) 138 | 139 | withinContext :: r -> ResourceContextWire r a b -> GameWire a b 140 | withinContext res (RCW w) = 141 | mkGen $ \dt x -> 142 | second (withinContext res . RCW) <$> runReaderT (stepWire w dt (Right x)) res 143 | 144 | transformedResourceContext :: ResourceContextWire r a Transform 145 | -> ResourceContextWire r a b 146 | -> ResourceContextWire r a b 147 | transformedResourceContext xf w = RCW $ mkGen $ \dt x -> 148 | second liftWire <$> 149 | (ReaderT $ \r -> 150 | let xf' = withinContext r xf 151 | w' = withinContext r w 152 | xfw = transformedContext xf' w' 153 | in stepWire xfw dt (Right x)) 154 | 155 | clippedResourceContext :: ResourceContextWire r a b 156 | -> ResourceContextWire r b c 157 | -> ResourceContextWire r a c 158 | clippedResourceContext cw w = RCW $ mkGen $ \dt x -> 159 | second liftWire <$> 160 | (ReaderT $ \r -> 161 | let cw' = withinContext r cw 162 | w' = withinContext r w 163 | xfw = clippedContext cw' w' 164 | in stepWire xfw dt (Right x)) 165 | 166 | joinResources :: Monoid b 167 | => [ContWire (a, Bool) (Maybe b)] 168 | -> ContWire (a, Bool) (Maybe b) 169 | joinResources = mkWire . fmap msequence . sequenceA 170 | where 171 | mkWire (CW w) = CW $ mkGen $ \dt (x, quit) -> do 172 | (Right result, w') <- stepWire w dt (Right (x, quit)) 173 | if not quit && isNothing result 174 | then stepWire w' dt (Right (undefined, True)) 175 | else return (Right result, getContinuousWire . mkWire $ CW w') 176 | 177 | msequence :: (MonadPlus m, Monoid b) => [m b] -> m b 178 | msequence [] = mzero 179 | msequence (v : vs) = foldr (\x y -> x >>= ((<$> y) . mappend)) v vs 180 | 181 | withDefault :: GameWire a b -> ContWire a b -> ContWire a b 182 | withDefault w (CW m) = CW $ w <|> m 183 | 184 | withSubResource :: (r' -> r) 185 | -> ResourceContextWire r a b 186 | -> ResourceContextWire r' a b 187 | withSubResource f (RCW w) = RCW $ mkGen $ \dt x -> do 188 | (r, w') <- withReaderT f $ stepWire w dt (Right x) 189 | return (r, getResourceWire $ withSubResource f (RCW w')) 190 | 191 | mkContWire :: (TimeStep -> a -> GameMonad (b, ContWire a b)) -> ContWire a b 192 | mkContWire f = CW $ mkGen $ \dt x -> do 193 | (r, CW w') <- f dt x 194 | return (Right r, w') 195 | 196 | stepContWire :: ContWire a b -> TimeStep -> a -> GameMonad (b, ContWire a b) 197 | stepContWire (CW w) dt x = do 198 | (Right r, w') <- stepWire w dt (Right x) 199 | return (r, CW w') 200 | 201 | -- Wire that behaves like the identity wire until the given key 202 | -- is pressed, then inhibits forever. 203 | quitWire :: GLFW.Key -> GameWire a a 204 | quitWire key = 205 | rSwitch mkId . (mkId &&& (now . pure mkEmpty . keyPressed key <|> never)) 206 | -------------------------------------------------------------------------------- /lib/Lambency/Transform.hs: -------------------------------------------------------------------------------- 1 | module Lambency.Transform ( 2 | Transform, Invertible(..), Transformable3D(..), 3 | fromForwardUp, fromCoordinateBasis, identity, 4 | right, up, forward, localRight, localUp, localForward, 5 | scale, position, 6 | 7 | rotateWorld, xform2Matrix, transformPoint, invTransformPoint 8 | ) where 9 | 10 | -------------------------------------------------------------------------------- 11 | 12 | import Linear.Matrix hiding (identity) 13 | import Linear.Metric 14 | import Linear.Vector 15 | import Linear.V3 16 | import Linear.V4 17 | import Linear.Quaternion hiding (rotate) 18 | import qualified Linear.Quaternion as Quat 19 | 20 | import qualified Control.Wire as W 21 | #if __GLASGOW_HASKELL__ <= 708 22 | import Control.Applicative 23 | #endif 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | type Vec3f = V3 Float 28 | type Quatf = Quaternion Float 29 | 30 | type Mat3f = M33 Float 31 | type Mat4f = M44 Float 32 | 33 | -- A Transform consists of a right vector, an up vector, a forward vector, a 34 | -- position in world space, and a scaling vector. 35 | type CoordinateBasis = (Vec3f, Vec3f, Vec3f) 36 | 37 | fromForwardUp :: Vec3f -> Vec3f -> CoordinateBasis 38 | fromForwardUp f u = 39 | let 40 | r = u `cross` f 41 | u' = f `cross` r 42 | in (r, u', f) 43 | 44 | basis2Matrix :: CoordinateBasis -> Mat3f 45 | basis2Matrix (r, u, f) = adjoint $ V3 r u f 46 | 47 | -- Basis is orthonormal, so inverse should be a simple transpose. 48 | invertBasis :: CoordinateBasis -> CoordinateBasis 49 | invertBasis (n1, n2, n3) = 50 | let 51 | V3 x1 y1 z1 = n1 52 | V3 x2 y2 z2 = n2 53 | V3 x3 y3 z3 = n3 54 | in 55 | (V3 x1 x2 x3, 56 | V3 y1 y2 y3, 57 | V3 z1 z2 z3) 58 | 59 | -- !FIXME! Transform here is really just a series of operations 60 | -- and not a full blown transform. Ideally, we'd like a few types: 61 | -- 1. TRS that represents a scale, rotation, and translation in 62 | -- that order 63 | -- 2. Invertible transform that represents an arbitrary sequence 64 | -- of translations, rotations, and scalings. 65 | -- 3. Transform that represents anything we can do in linear algebra 66 | -- 67 | -- If we support these, then there is a clear way to go from TRS, which 68 | -- is what almost every object in a 3D scene needs to a Transform, which 69 | -- is what the underlying graphics engine is expecting, while still 70 | -- allowing customized transforms 71 | data Transform = Identity 72 | | Scale Vec3f Transform 73 | | OrthoNormal CoordinateBasis Transform 74 | | Translate Vec3f Transform 75 | deriving (Show) 76 | 77 | identity :: Transform 78 | identity = Identity 79 | 80 | fromCoordinateBasis :: CoordinateBasis -> Transform 81 | fromCoordinateBasis b = OrthoNormal b Identity 82 | 83 | -- !FIXME! There are Lens definitions for these 84 | -- too, but they're used as ex ey and ez in Linear. 85 | localRight :: Vec3f 86 | localRight = V3 1 0 0 87 | 88 | localUp :: Vec3f 89 | localUp = V3 0 1 0 90 | 91 | localForward :: Vec3f 92 | localForward = V3 0 0 1 93 | 94 | right :: Transform -> Vec3f 95 | right Identity = localRight 96 | right (Scale _ xf) = right xf 97 | right (OrthoNormal (r, _, _) _) = r 98 | right (Translate _ xf) = right xf 99 | 100 | up :: Transform -> Vec3f 101 | up Identity = localUp 102 | up (Scale _ xf) = up xf 103 | up (OrthoNormal (_, u, _) _) = u 104 | up (Translate _ xf) = up xf 105 | 106 | forward :: Transform -> Vec3f 107 | forward Identity = localForward 108 | forward (Scale _ xf) = forward xf 109 | forward (OrthoNormal (_, _, f) _) = f 110 | forward (Translate _ xf) = forward xf 111 | 112 | scale :: Transform -> Vec3f 113 | scale Identity = V3 1 1 1 114 | scale (Scale s xf) = (*) <$> s <*> (scale xf) 115 | scale (OrthoNormal _ xf) = scale xf 116 | scale (Translate _ xf) = scale xf 117 | 118 | position :: Transform -> Vec3f 119 | position Identity = zero 120 | position (Scale _ xf) = position xf 121 | position (OrthoNormal _ xf) = position xf 122 | position (Translate t xf) = t ^+^ (position xf) 123 | 124 | updateAxis :: Vec3f -> Vec3f -> Vec3f -> Transform -> Transform 125 | updateAxis nr nu nf Identity = OrthoNormal (nr, nu, nf) Identity 126 | updateAxis nr nu nf (Scale s xf) = OrthoNormal (nr, nu, nf) $ Scale s xf 127 | updateAxis nr nu nf (OrthoNormal _ xf) = OrthoNormal (nr, nu, nf) xf 128 | updateAxis nr nu nf (Translate t xf) = Translate t $ updateAxis nr nu nf xf 129 | 130 | renormalize :: Transform -> Transform 131 | renormalize xf = updateAxis (right xf) u' f' xf 132 | where f' = (right xf) `cross` (up xf) 133 | u' = f' `cross` (right xf) 134 | 135 | rotateWorld :: Quatf -> Transform -> Transform 136 | rotateWorld quat xf = let 137 | 138 | r = right xf 139 | u = up xf 140 | f = forward xf 141 | 142 | invWorldMat :: Mat3f 143 | invWorldMat = V3 r u f 144 | 145 | worldMat :: Mat3f 146 | worldMat = adjoint invWorldMat 147 | 148 | rotateAxis :: Vec3f -> Vec3f 149 | rotateAxis = signorm . (worldMat !*) . (Quat.rotate quat) . (invWorldMat !*) 150 | 151 | in 152 | renormalize $ updateAxis (rotateAxis r) (rotateAxis u) (rotateAxis f) xf 153 | 154 | -- Returns a matrix where that transforms a coordinate space such that the 155 | -- new coordinate system's origin is located at the value of 'p' of the old 156 | -- coordinate space, and the three axes that define forward up and right are 157 | -- now the basis in Z, Y, and X respectively. Scale is applied localy in the 158 | -- original coordinate space. 159 | xform2Matrix :: Transform -> Mat4f 160 | xform2Matrix xf = 161 | let 162 | extendWith :: a -> V3 a -> V4 a 163 | extendWith w (V3 x y z) = V4 x y z w 164 | 165 | V3 rx ry rz = right xf 166 | V3 ux uy uz = up xf 167 | V3 fx fy fz = forward xf 168 | V3 sx sy sz = scale xf 169 | in 170 | V4 171 | (extendWith 0.0 $ (sx *^) $ V3 rx ux fx) 172 | (extendWith 0.0 $ (sy *^) $ V3 ry uy fy) 173 | (extendWith 0.0 $ (sz *^) $ V3 rz uz fz) 174 | (extendWith 1.0 $ position xf) 175 | 176 | class Invertible a where 177 | invert :: a -> a 178 | 179 | instance Invertible Transform where 180 | invert Identity = Identity 181 | invert xform = (foldl (.) id $ modifiers xform) Identity 182 | where modifiers :: Transform -> [Transform -> Transform] 183 | modifiers Identity = [] 184 | modifiers (Scale (V3 x y z) xf) = Scale (V3 (1/x) (1/y) (1/z)) : (modifiers xf) 185 | modifiers (OrthoNormal b xf) = OrthoNormal (invertBasis b) : (modifiers xf) 186 | modifiers (Translate t xf) = Translate (negated t) : (modifiers xf) 187 | 188 | transformPoint :: Transform -> Vec3f -> Vec3f 189 | transformPoint Identity = id 190 | transformPoint (Scale s xf) = \x -> (*) <$> s <*> (transformPoint xf x) 191 | transformPoint (OrthoNormal b xf) = ((basis2Matrix b) !*) . (transformPoint xf) 192 | transformPoint (Translate t xf) = (^+^ t) . (transformPoint xf) 193 | 194 | invTransformPoint :: Transform -> Vec3f -> Vec3f 195 | invTransformPoint xf = transformPoint (invert xf) 196 | 197 | class Transformable3D a where 198 | translate :: Vec3f -> a -> a 199 | rotate :: Quatf -> a -> a 200 | nonuniformScale :: Vec3f -> a -> a 201 | 202 | uniformScale :: Float -> a -> a 203 | uniformScale s = nonuniformScale $ V3 s s s 204 | 205 | transform :: Transform -> a -> a 206 | transform Identity = id 207 | transform (Scale s xf) = (nonuniformScale s) . (transform xf) 208 | transform (OrthoNormal (r, u, _) xf) = let 209 | determineRot :: Vec3f -> Vec3f -> Quatf 210 | determineRot v1 v2 = axisAngle (v1 `cross` v2) (acos $ v1 `dot` v2) 211 | firstRot = determineRot r localRight 212 | secondRot = determineRot (Quat.rotate firstRot u) localUp 213 | in 214 | rotate (firstRot * secondRot) . (transform xf) 215 | transform (Translate t xf) = (translate t) . (transform xf) 216 | 217 | instance Transformable3D Transform where 218 | translate t Identity = Translate t Identity 219 | translate t (Scale s xf) = Translate t $ Scale s xf 220 | translate t (OrthoNormal b xf) = Translate t $ OrthoNormal b xf 221 | translate t (Translate t' xf) = Translate (t ^+^ t') xf 222 | 223 | nonuniformScale s Identity = Scale s Identity 224 | nonuniformScale s (Scale s' xf) = Scale ((*) <$> s <*> s') xf 225 | nonuniformScale s (OrthoNormal b xf) = OrthoNormal b $ nonuniformScale s xf 226 | nonuniformScale s (Translate t xf) = Translate t $ nonuniformScale s xf 227 | 228 | -- Rotates the coordinate axis of the transform by the given quaternion. This 229 | -- function performs a local rotation 230 | rotate quat xf = let 231 | fn :: Vec3f -> Vec3f 232 | fn = Quat.rotate quat 233 | in updateAxis (fn $ right xf) (fn $ up xf) (fn $ forward xf) xf 234 | 235 | --instance Transformable3D (V3 Float) where 236 | -- translate = (^+^) 237 | -- rotate = Quat.rotate 238 | -- nonuniformScale = liftA2 (*) 239 | 240 | instance (Monoid s, Monad m, Transformable3D b) => 241 | Transformable3D (W.Wire s e m a b) where 242 | translate v = fmap (translate v) 243 | nonuniformScale s = fmap (translate s) 244 | rotate r = fmap (rotate r) 245 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the complex Travis configuration, which is intended for use 2 | # on open source libraries which need compatibility across multiple GHC 3 | # versions, must work with cabal-install, and should be 4 | # cross-platform. For more information and other options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.ghc 21 | - $HOME/.cabal 22 | - $HOME/.stack 23 | 24 | # The different configurations we want to test. We have BUILD=cabal which uses 25 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 26 | # of those below. 27 | # 28 | # We set the compiler values here to tell Travis to use a different 29 | # cache file per set of arguments. 30 | # 31 | # If you need to have different apt packages for each combination in the 32 | # matrix, you can use a line such as: 33 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 34 | matrix: 35 | include: 36 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 37 | # https://github.com/hvr/multi-ghc-travis 38 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 39 | compiler: ": #GHC 7.10.3" 40 | addons: {apt: {packages: [xorg-dev,libopenal-dev,cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 41 | - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 42 | compiler: ": #GHC 8.0.2" 43 | addons: {apt: {packages: [xorg-dev,libopenal-dev,cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 44 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 45 | compiler: ": #GHC 8.2.2" 46 | addons: {apt: {packages: [xorg-dev,libopenal-dev,cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 47 | 48 | # Build with the newest GHC and cabal-install. This is an accepted failure, 49 | # see below. 50 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 51 | compiler: ": #GHC HEAD" 52 | addons: {apt: {packages: [xorg-dev,libopenal-dev,cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 53 | 54 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 55 | # variable, such as using --stack-yaml to point to a different file. 56 | - env: BUILD=stack ARGS="" 57 | compiler: ": #stack default" 58 | addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 59 | 60 | - env: BUILD=stack ARGS="--resolver lts-3" 61 | compiler: ": #stack 7.10.2" 62 | addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 63 | 64 | - env: BUILD=stack ARGS="--resolver lts-7" 65 | compiler: ": #stack 8.0.1" 66 | addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 67 | 68 | - env: BUILD=stack ARGS="--resolver lts-9" 69 | compiler: ": #stack 8.0.2" 70 | addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 71 | 72 | - env: BUILD=stack ARGS="--resolver lts-11" 73 | compiler: ": #stack 8.2.2" 74 | addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 75 | 76 | # Nightly builds are allowed to fail 77 | - env: BUILD=stack ARGS="--resolver nightly" 78 | compiler: ": #stack nightly" 79 | addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 80 | 81 | # Build on macOS in addition to Linux 82 | - env: BUILD=stack ARGS="" 83 | compiler: ": #stack default osx" 84 | os: osx 85 | 86 | # Travis includes an macOS which is incompatible with GHC 7.8.4 87 | - env: BUILD=stack ARGS="--resolver lts-3" 88 | compiler: ": #stack 7.10.2 osx" 89 | os: osx 90 | 91 | - env: BUILD=stack ARGS="--resolver lts-7" 92 | compiler: ": #stack 8.0.1 osx" 93 | os: osx 94 | 95 | - env: BUILD=stack ARGS="--resolver lts-9" 96 | compiler: ": #stack 8.0.2 osx" 97 | os: osx 98 | 99 | - env: BUILD=stack ARGS="--resolver lts-11" 100 | compiler: ": #stack 8.2.2 osx" 101 | os: osx 102 | 103 | - env: BUILD=stack ARGS="--resolver nightly" 104 | compiler: ": #stack nightly osx" 105 | os: osx 106 | 107 | ############################################################################## 108 | ## Current issues: 109 | ## 110 | ### The resolver lts-6 has some dependency chain that doesn't include the 111 | ### message "(user goal)" in it's error output. This causes stack to fail for 112 | ### these builds. We can re-enable them once commercialhaskell/stack#3966 is 113 | ### released. 114 | ### 115 | #- env: BUILD=stack ARGS="--resolver lts-6" 116 | # compiler: ": #stack 7.10.3" 117 | # addons: {apt: {packages: [xorg-dev,libopenal-dev,libgmp-dev]}} 118 | # 119 | #- env: BUILD=stack ARGS="--resolver lts-6" 120 | # compiler: ": #stack 7.10.3 osx" 121 | # os: osx 122 | # 123 | ### HCodecs doesn't build on GHC 8.4 due to monoid-semigroup proposal. Need 124 | ### to wait for either giorgidze/HCodecs#6 or Lambency#11 before we can 125 | ### re-enable this build 126 | #- env: BUILD=cabal GHCVER=8.4.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 127 | # compiler: ": #GHC 8.4.1" 128 | # addons: {apt: {packages: [xorg-dev,libopenal-dev,cabal-install-2.0,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 129 | 130 | allow_failures: 131 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 132 | - env: BUILD=stack ARGS="--resolver nightly" 133 | 134 | before_install: 135 | # Using compiler above sets CC to an invalid value, so unset it 136 | - unset CC 137 | 138 | # We want to always allow newer versions of packages when building on GHC HEAD 139 | - CABALARGS="" 140 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 141 | 142 | # Download and unpack the stack executable 143 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 144 | - mkdir -p ~/.local/bin 145 | - | 146 | if [ `uname` = "Darwin" ] 147 | then 148 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 149 | else 150 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 151 | fi 152 | 153 | # Use the more reliable S3 mirror of Hackage 154 | mkdir -p $HOME/.cabal 155 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 156 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 157 | 158 | if [ "$CABALVER" != "1.16" ] 159 | then 160 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 161 | fi 162 | 163 | install: 164 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 165 | - if [ -f configure.ac ]; then autoreconf -i; fi 166 | - | 167 | set -ex 168 | case "$BUILD" in 169 | stack) 170 | # Add in extra-deps for older snapshots, as necessary 171 | stack --no-terminal unpack cabal-install-1.24.0.2 172 | stack --no-terminal init cabal-install-1.24.0.2 --solver --ignore-subdirs 173 | stack --no-terminal install 174 | stack --no-terminal $ARGS init . --force --solver --ignore-subdirs 175 | 176 | # Build the dependencies 177 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 178 | ;; 179 | cabal) 180 | cabal --version 181 | travis_retry cabal update 182 | 183 | # Get the list of packages from the stack.yaml file. Note that 184 | # this will also implicitly run hpack as necessary to generate 185 | # the .cabal files needed by cabal-install. 186 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 187 | 188 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 189 | ;; 190 | esac 191 | set +ex 192 | 193 | script: 194 | - | 195 | set -ex 196 | case "$BUILD" in 197 | stack) 198 | stack --no-terminal $ARGS build --bench --no-run-benchmarks --haddock --no-haddock-deps --flag lambency:examples 199 | ;; 200 | cabal) 201 | cabal install -fexamples --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 202 | 203 | ORIGDIR=$(pwd) 204 | for dir in $PACKAGES 205 | do 206 | cd $dir 207 | cabal check || [ "$CABALVER" == "1.16" ] 208 | cabal sdist 209 | PKGVER=$(cabal info . | awk '{print $2;exit}') 210 | SRC_TGZ=$PKGVER.tar.gz 211 | cd dist 212 | tar zxfv "$SRC_TGZ" 213 | cd "$PKGVER" 214 | cabal configure --enable-tests --ghc-options -O0 215 | cabal build 216 | cabal test 217 | cd $ORIGDIR 218 | done 219 | ;; 220 | esac 221 | set +ex 222 | -------------------------------------------------------------------------------- /lib/Lambency/UI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Lambency.UI ( 3 | UIWire, WidgetEvent(..), WidgetState(..), Widget(..), screen, 4 | animatedSpriteRenderer, spriteRenderer, colorRenderer, 5 | textRenderer, dynamicTextRenderer, 6 | combineRenderers, 7 | hbox, vbox, glue 8 | ) where 9 | 10 | -------------------------------------------------------------------------------- 11 | import Control.Monad (foldM) 12 | import Control.Monad.Reader 13 | import Control.Wire hiding ((.)) 14 | 15 | import Data.Word 16 | 17 | import FRP.Netwire.Input 18 | 19 | import qualified Graphics.UI.GLFW as GLFW 20 | 21 | import Lambency.Font 22 | import Lambency.GameObject 23 | import Lambency.Sprite 24 | import Lambency.Types 25 | 26 | import Linear hiding (trace, identity) 27 | 28 | import Prelude hiding (id) 29 | 30 | import qualified Yoga as Y 31 | -------------------------------------------------------------------------------- 32 | 33 | type UIWire a b = GameWire (Y.LayoutInfo, a) b 34 | 35 | data WidgetEvent a b 36 | = WidgetEvent'OnMouseOver { 37 | eventLogic :: UIWire a b 38 | } 39 | | WidgetEvent'OnMouseDown { 40 | _eventMouseButton :: GLFW.MouseButton, 41 | eventLogic :: UIWire a b 42 | } 43 | | WidgetEvent'OnKeyDown { 44 | _eventKey :: GLFW.Key, 45 | eventLogic :: UIWire a b 46 | } 47 | 48 | data WidgetState a b = WidgetState { 49 | idleLogic :: UIWire a b, 50 | eventHandlers :: [WidgetEvent a b] 51 | } 52 | 53 | blankState :: Monoid b => WidgetState a b 54 | blankState = WidgetState (ignoreFst $ mkConst (Right mempty)) [] 55 | 56 | newtype Widget a b = Widget { getWidgetLayout :: Y.Layout (WidgetState a b) } 57 | newtype WidgetMonad a = WidgetMonad { liftGameMonad :: GameMonad a } 58 | deriving (Functor, Applicative, Monad) 59 | 60 | instance MonadIO WidgetMonad where 61 | liftIO = WidgetMonad . GameMonad . liftIO 62 | 63 | widgetRenderFn :: Monoid b => 64 | TimeStep -> a -> Y.LayoutInfo -> WidgetState a b -> 65 | WidgetMonad (b, WidgetState a b) 66 | widgetRenderFn dt input lytInfo widgetState = WidgetMonad $ 67 | let eventWire :: WidgetEvent a b -> UIWire a b 68 | eventWire (WidgetEvent'OnMouseDown mb uiw) = 69 | second (mousePressed mb) >>> uiw 70 | eventWire (WidgetEvent'OnKeyDown key uiw) = 71 | second (keyPressed key) >>> uiw 72 | eventWire e@(WidgetEvent'OnMouseOver uiw) = mkGen $ \dt' (lyt, ipt) -> do 73 | (Right (mx, my), _) <- stepWire mouseCursor dt' $ Right undefined 74 | (V2 wx wy) <- asks windowSize 75 | let bx0 = Y.nodeLeft lytInfo / fromIntegral wx 76 | bx1 = (bx0 + Y.nodeWidth lytInfo) / fromIntegral wx 77 | by0 = Y.nodeTop lytInfo / fromIntegral wy 78 | by1 = (by0 + Y.nodeHeight lytInfo) / fromIntegral wy 79 | x = (mx + 1.0) * 0.5 80 | y = (my + 1.0) * 0.5 81 | 82 | if x >= bx0 && x <= bx1 && y >= by0 && y <= by1 then 83 | do 84 | (result, uiw') <- stepWire uiw dt' $ Right (lyt, ipt) 85 | return (result, eventWire (WidgetEvent'OnMouseOver uiw')) 86 | else return (Left "Mouse out of bounds", eventWire e) 87 | 88 | handleEvent :: WidgetEvent a b -> (Y.LayoutInfo, a) -> 89 | GameMonad (Maybe (b, WidgetEvent a b)) 90 | handleEvent event arg = do 91 | (result, uiw') <- stepWire (eventWire event) dt $ Right arg 92 | case result of 93 | Left _ -> return Nothing 94 | Right x -> return $ Just (x, event { eventLogic = uiw' }) 95 | 96 | handleEvents :: Monoid b => [WidgetEvent a b] -> (Y.LayoutInfo, a) -> 97 | GameMonad (Maybe b, [WidgetEvent a b]) 98 | handleEvents events arg = 99 | let eventFn (res, evts) event = do 100 | result <- handleEvent event arg 101 | case result of 102 | Nothing -> return (res, event : evts) 103 | Just (x, e) -> case res of 104 | Nothing -> return (Just x, e : evts) 105 | Just r -> return (Just $ r `mappend` x, e : evts) 106 | in foldM eventFn (Nothing, []) events 107 | 108 | wireArg = (lytInfo, input) 109 | in do 110 | (eventResults, events) <- handleEvents (eventHandlers widgetState) wireArg 111 | case eventResults of 112 | Nothing -> do 113 | (result, uiw') <- stepWire (idleLogic widgetState) dt $ Right wireArg 114 | let newState = widgetState { idleLogic = uiw', eventHandlers = events } 115 | case result of 116 | Right x -> return (x, newState) 117 | Left _ -> error "UI wire inhibited?" 118 | Just result -> return (result, widgetState { eventHandlers = events }) 119 | 120 | ignoreFst :: GameWire b c -> GameWire (a, b) c 121 | ignoreFst logic = mkGen $ \dt (_, ipt) -> do 122 | (result, logic') <- stepWire logic dt $ Right ipt 123 | return (result, ignoreFst logic') 124 | 125 | widgetWire :: Monoid b => Widget a b -> GameWire a b 126 | widgetWire (Widget lyt) = mkGen $ \dt input -> do 127 | (result, newLyt) <- liftGameMonad $ Y.foldRender lyt (widgetRenderFn dt input) 128 | return (Right result, widgetWire $ Widget newLyt) 129 | 130 | screenPrg :: Monoid b => [Widget a b] -> GameMonad (Widget a b) 131 | screenPrg children = do 132 | (V2 wx wy) <- asks windowSize 133 | return . Widget $ 134 | Y.withDimensions (fromIntegral wx) (fromIntegral wy) $ 135 | Y.vbox (Y.startToEnd $ getWidgetLayout <$> children) blankState 136 | 137 | screen :: Monoid b => [Widget a b] -> GameWire a b 138 | screen children = wireFrom (asks windowSize) $ runScreen $ 139 | wireFrom (screenPrg children) widgetWire 140 | where 141 | runScreen ui_wire oldWinDims = 142 | let getUIWire False = wireFrom (screenPrg children) widgetWire 143 | getUIWire True = ui_wire 144 | in mkGen $ \dt input -> do 145 | winDims <- asks windowSize 146 | let ui = getUIWire (winDims == oldWinDims) 147 | (result, next_wire') <- stepWire ui dt $ Right input 148 | return (result, runScreen next_wire' winDims) 149 | 150 | renderSpriteAt :: Sprite -> Y.LayoutInfo -> GameMonad () 151 | renderSpriteAt sprite lytInfo = do 152 | let (x, y, w, h) = ( 153 | Y.nodeLeft lytInfo, 154 | Y.nodeTop lytInfo, 155 | Y.nodeWidth lytInfo, 156 | Y.nodeHeight lytInfo) 157 | (V2 _ wy) <- asks windowSize 158 | renderUISpriteWithSize sprite (V2 x (fromIntegral wy - y - h)) (V2 w h) 159 | 160 | renderStringAt :: Font -> String -> Y.LayoutInfo -> GameMonad() 161 | renderStringAt font str lytInfo = do 162 | let (x, y) = (Y.nodeLeft lytInfo, Y.nodeTop lytInfo) 163 | (V2 _ wy) <- asks windowSize 164 | renderUIString font str $ V2 x (fromIntegral wy - y - stringHeight font str) 165 | 166 | animatedRenderer :: Monoid b => GameWire a Sprite -> GameWire a b -> UIWire a b 167 | animatedRenderer spriteWire logic = mkGen $ \dt (lytInfo, val) -> do 168 | (spriteResult, spriteWire') <- stepWire spriteWire dt $ Right val 169 | (logicResult, logic') <- stepWire logic dt $ Right val 170 | case spriteResult of 171 | Right nextSprite -> do 172 | renderSpriteAt nextSprite lytInfo 173 | (nextSpriteResult, _) <- stepWire spriteWire' dt $ Right val 174 | case nextSpriteResult of 175 | Right _ -> return (logicResult, animatedRenderer spriteWire' logic') 176 | Left _ -> return (logicResult, spriteRenderer nextSprite logic') 177 | Left _ -> error "Should never get here" 178 | 179 | animatedSpriteRenderer :: Monoid b => 180 | Sprite -> SpriteAnimationType -> GameWire a b -> 181 | UIWire a b 182 | animatedSpriteRenderer sprite animType = 183 | animatedRenderer (animatedWire sprite animType) 184 | 185 | spriteRenderer :: Monoid b => Sprite -> GameWire a b -> UIWire a b 186 | spriteRenderer s logic = mkGen $ \dt (lytInfo, val) -> do 187 | renderSpriteAt s lytInfo 188 | (result, logic') <- stepWire logic dt $ Right val 189 | return (result, spriteRenderer s logic') 190 | 191 | colorRenderer :: Monoid b => V4 Word8 -> GameWire a b -> UIWire a b 192 | colorRenderer color logic = mkGen $ \dt (lytInfo, val) -> do 193 | let byteColor = fromIntegral <$> color 194 | s <- asks (changeSpriteColor byteColor <$> simpleSprite) 195 | renderSpriteAt s lytInfo 196 | (result, logic') <- stepWire logic dt $ Right val 197 | return (result, spriteRenderer s logic') 198 | 199 | textRenderer :: Monoid b => Font -> String -> GameWire a b -> UIWire a b 200 | textRenderer font str logic = mkGen $ \dt (lytInfo, val) -> do 201 | renderStringAt font str lytInfo 202 | (result, logic') <- stepWire logic dt $ Right val 203 | return (result, textRenderer font str logic') 204 | 205 | dynamicTextRenderer :: Monoid b => Font -> GameWire a (b, String) -> UIWire a b 206 | dynamicTextRenderer font logic = mkGen $ \dt (lytInfo, val) -> do 207 | (wireResult, logic') <- stepWire logic dt $ Right val 208 | result <- case wireResult of 209 | (Right (bVal, str)) -> do 210 | renderStringAt font str lytInfo 211 | return $ Right bVal 212 | (Left e) -> return (Left e) 213 | return (result, dynamicTextRenderer font logic') 214 | 215 | combineRenderers :: Monoid b => [UIWire a b] -> UIWire a b 216 | combineRenderers = mconcat 217 | 218 | hbox :: Monoid b => [Widget a b] -> Widget a b 219 | hbox widgets = Widget 220 | $ Y.stretched 221 | $ Y.hbox (Y.spaceBetween (getWidgetLayout <$> widgets)) blankState 222 | 223 | vbox :: Monoid b => [Widget a b] -> Widget a b 224 | vbox widgets = Widget 225 | $ Y.stretched 226 | $ Y.vbox (Y.spaceBetween (getWidgetLayout <$> widgets)) blankState 227 | 228 | glue :: Monoid b => Widget a b 229 | glue = Widget 230 | $ Y.growable 2.0 (Y.Min 0.0) (Y.Min 0.0) 231 | $ Y.exact 1.0 1.0 blankState 232 | -------------------------------------------------------------------------------- /examples/Pong.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -------------------------------------------------------------------------------- 4 | import Prelude hiding ((.), id) 5 | import Control.Monad.Trans 6 | import Control.Wire 7 | import FRP.Netwire.Input 8 | import FRP.Netwire.Move 9 | 10 | import qualified Graphics.UI.GLFW as GLFW 11 | import qualified Lambency as L 12 | 13 | import System.FilePath 14 | import Paths_lambency 15 | 16 | import Control.Lens 17 | import Linear 18 | -------------------------------------------------------------------------------- 19 | 20 | type Circle = (V2 Float, Float) 21 | type Rect = (V2 Float, V2 Float) 22 | 23 | data Ball = Ball { pos :: V2 Float, vel :: V2 Float } 24 | 25 | screenWidth :: Int 26 | screenWidth = 640 27 | 28 | screenHeight :: Int 29 | screenHeight = 480 30 | 31 | wallHeight :: Int 32 | wallHeight = 10 33 | 34 | paddleHeight :: Int 35 | paddleHeight = 40 36 | 37 | paddleWidth :: Int 38 | paddleWidth = 10 39 | 40 | -- The horizontal offset from the wall 41 | paddleOffset :: Float 42 | paddleOffset = 10 43 | 44 | paddleStartY :: Float 45 | paddleStartY = fromIntegral $ screenHeight `div` 2 46 | 47 | paddleMinY :: Float 48 | paddleMinY = fromIntegral wallHeight 49 | 50 | paddleMaxY :: Float 51 | paddleMaxY = fromIntegral (screenHeight - paddleHeight) - paddleMinY 52 | 53 | paddleSpeed :: Float 54 | paddleSpeed = 70 55 | 56 | scoreOffset :: Float 57 | scoreOffset = 20 58 | 59 | paddleLoc :: Bool -> Float -> V2 Float 60 | paddleLoc True y = V2 paddleOffset y 61 | paddleLoc False y = V2 (fromIntegral (screenWidth - paddleWidth) - paddleOffset) y 62 | 63 | paddleXForm :: V2 Float -> L.Transform 64 | paddleXForm (V2 x y) = 65 | L.translate (V3 x y (-1)) $ 66 | L.nonuniformScale (vi2f3 $ V3 paddleWidth paddleHeight 1) $ 67 | L.identity 68 | 69 | ballRadius :: Float 70 | ballRadius = 5 71 | 72 | ballStartSpeed :: V2 Float 73 | ballStartSpeed = V2 (-85) (-40) 74 | 75 | startBall :: Ball 76 | startBall = Ball (0.5 *^ (vi2f2 $ V2 screenWidth screenHeight)) ballStartSpeed 77 | 78 | -------------------------------------------------- 79 | -- Rendering 80 | 81 | renderPaddle :: L.Sprite -> Bool -> Float -> L.GameMonad () 82 | renderPaddle s b f = 83 | L.renderSprite s (V2 paddleWidth paddleHeight) (-1) (paddleLoc b f) 84 | 85 | renderBall :: L.Sprite -> Ball -> L.GameMonad () 86 | renderBall s (Ball (V2 x y) _) = L.renderSprite s sc (-1) pp 87 | where 88 | pp = V2 (x - ballRadius) (y - ballRadius) 89 | sc = round <$> ((2 *^) $ V2 ballRadius ballRadius) 90 | 91 | renderScore :: L.Font -> Int -> Int -> L.GameMonad () 92 | renderScore f p1 p2 = 93 | let scoreLen = L.stringWidth f (show p1) 94 | c = vi2f2 $ V2 (screenWidth `div` 2) wallHeight 95 | in do 96 | L.renderUIString f (show p1) (c + (V2 (-scoreOffset-scoreLen) scoreOffset)) 97 | L.renderUIString f (show p2) (c + (V2 scoreOffset scoreOffset)) 98 | 99 | dashedMidsection :: L.Sprite -> [(V2 Float, V2 Int, L.Sprite)] 100 | dashedMidsection s = [(tr x, V2 4 20, s) | x <- [0,1..12]] 101 | where 102 | tr :: Int -> V2 Float 103 | tr x = 0.5 *^ (vi2f2 $ V2 screenWidth (80 * x)) ^-^ (V2 1.5 0) 104 | 105 | wallScale :: V2 Int 106 | wallScale = V2 screenWidth wallHeight 107 | 108 | mkWall :: Bool -> L.Sprite -> (V2 Float, V2 Int, L.Sprite) 109 | mkWall True x = (vi2f2 $ V2 0 (screenHeight - wallHeight), wallScale, x) 110 | mkWall False x = (V2 0 0, wallScale, x) 111 | 112 | renderPaddleWire :: L.Sprite -> Bool -> L.GameWire Float Float 113 | renderPaddleWire s playerOne = 114 | mkGen_ $ \y -> renderPaddle s playerOne y >> return (Right y) 115 | 116 | renderBallWire :: L.Sprite -> L.GameWire Ball Ball 117 | renderBallWire s = mkGen_ $ \b -> renderBall s b >> return (Right b) 118 | 119 | renderStatic :: [(V2 Float, V2 Int, L.Sprite)] -> L.GameWire a a 120 | renderStatic rs = mkGen_ $ \x -> mapM_ renderIt rs >> return (Right x) 121 | where 122 | renderIt (pp, sc, s) = L.renderSprite s sc (-1) pp 123 | 124 | -------------------------------------------------- 125 | -- Game logic 126 | 127 | paddleFeedback :: L.GameWire (a, Float) Float -> L.GameWire (a, Float) (Float, Float) 128 | paddleFeedback handler = 129 | let againstTop = when ((>= paddleMaxY) . snd) >>> 130 | handler >>> 131 | (when (< 0) <|> pure 0) 132 | 133 | againstBot = when ((<= paddleMinY) . snd) >>> 134 | handler >>> 135 | (when (> 0) <|> pure 0) 136 | in 137 | (againstTop <|> againstBot <|> handler) >>> 138 | integral paddleStartY >>> 139 | (mkId &&& mkId) 140 | 141 | paddleWire :: Bool -> L.Sprite -> L.GameWire (a, Float) Float -> L.GameWire a Float 142 | paddleWire playerOne ro handler = 143 | loop (second (delay 0) >>> paddleFeedback handler) >>> renderPaddleWire ro playerOne 144 | 145 | ballWire :: L.Sprite -> L.GameWire Ball Ball 146 | ballWire ro = integrateBall >>> renderBallWire ro 147 | where 148 | integrateBall :: L.GameWire Ball Ball 149 | integrateBall = mkSF $ \ds (Ball p v) -> 150 | let dt = realToFrac (dtime ds) 151 | in (Ball (p ^+^ (dt *^ v)) v, integrateBall) 152 | 153 | keyHandler :: L.GameWire (a, Float) Float 154 | keyHandler = 155 | (pure paddleSpeed . keyPressed GLFW.Key'Up) <|> 156 | (pure (-paddleSpeed) . keyPressed GLFW.Key'Down) <|> 157 | pure 0 158 | 159 | collidePaddle :: Bool -> L.Sound -> L.GameWire (Ball, Float) Ball 160 | collidePaddle playerOne sound = mkGen_ collide 161 | where 162 | collide :: (Ball, Float) -> L.GameMonad (Either String Ball) 163 | collide (Ball p v, h) = 164 | let paddleSz = vi2f2 $ V2 paddleWidth paddleHeight 165 | paddleRect = (paddleLoc playerOne h, paddleSz) 166 | v' = (_x %~ negate) v 167 | in 168 | if circleIntersectRect (p, ballRadius) paddleRect 169 | then do 170 | L.startSound sound 171 | return . Right $ Ball p v' 172 | else return . Right $ Ball p v 173 | 174 | collideWall :: L.GameWire Ball Ball 175 | collideWall = mkSF_ collide 176 | where 177 | collide (Ball p v) = 178 | let by = p ^. _y 179 | v' = (_y %~ negate) v 180 | wh = fromIntegral wallHeight + ballRadius 181 | in 182 | if by < wh || by > (fromIntegral screenHeight - wh) 183 | then Ball p v' 184 | else Ball p v 185 | 186 | aiHandler :: L.GameWire (Ball, Float) Float 187 | aiHandler = mkSF_ $ \(Ball p v, h) -> 188 | let dy = (p ^. _y) - (h + (fromIntegral $ paddleHeight `div` 2)) 189 | in L.clamp ((v ^. _y) + dy) (-paddleSpeed) paddleSpeed 190 | 191 | handleScore :: L.Font -> L.GameWire (Int, Ball) (Int, Ball) 192 | handleScore f = scoreWire 0 0 193 | where 194 | handleBall :: Ball -> (Ball, Int) 195 | handleBall b@(Ball p _) 196 | | bx < 0 = (startBall, 1) 197 | | bx > (fromIntegral screenWidth) = (startBall, -1) 198 | | otherwise = (b, 0) 199 | where 200 | bx = p ^._x 201 | 202 | scoreWire :: Int -> Int -> L.GameWire (Int, Ball) (Int, Ball) 203 | scoreWire p1 p2 = mkGenN scoreBall 204 | where 205 | scoreBall (_, b) = 206 | let (b', x) = handleBall b 207 | (p1', p2') = case x of 208 | 1 -> (p1, p2 + 1) 209 | -1 -> (p1 + 1, p2) 210 | _ -> (p1, p2) 211 | in do 212 | renderScore f p1' p2' 213 | return (Right (max p1' p2', b'), scoreWire p1' p2') 214 | 215 | gameFeedback :: L.Sprite -> L.Sprite -> L.Sound -> L.Font 216 | -> L.GameWire (Int, Ball) (Int, Ball) 217 | gameFeedback quad circle sound sysFont = 218 | (second $ 219 | (collideWith True sound keyHandler) >>> 220 | (collideWith False sound aiHandler) >>> 221 | collideWall >>> 222 | ballWire circle) >>> 223 | handleScore sysFont 224 | where 225 | collideWith :: Bool -> L.Sound -> 226 | L.GameWire (Ball, Float) Float -> 227 | L.GameWire Ball Ball 228 | collideWith playerOne s handler = 229 | (mkId &&& paddleWire playerOne quad handler) >>> 230 | collidePaddle playerOne s 231 | 232 | loadGameResources :: L.ResourceLoader (L.Sprite, L.Sound, L.Font) 233 | loadGameResources = do 234 | let color = pure 255 235 | quad <- L.changeSpriteColor (V4 0.9 0.2 0.4 1.0) <$> 236 | (L.createSolidTexture color >>= L.loadStaticSpriteWithMask) 237 | sound <- liftIO (getDataFileName $ "examples" "pong-bloop.wav") 238 | >>= L.loadSound 239 | 240 | fontFilename <- liftIO $ getDataFileName ("examples" "kenpixel.ttf") 241 | sysFont <- L.loadTTFont 36 (V3 1 1 1) fontFilename 242 | 243 | return (quad, sound, sysFont) 244 | 245 | gameWire :: L.ContWire (Int, Bool) (Maybe Int) 246 | gameWire = 247 | L.bracketResource loadGameResources 248 | $ L.withResource 249 | $ \(quad, sound, font) -> 250 | let feedback = gameFeedback quad quad sound font 251 | staticSprites = 252 | mkWall False quad : 253 | mkWall True quad : 254 | dashedMidsection quad 255 | in (loop $ second (delay startBall) >>> feedback) 256 | >>> when (< 10) 257 | >>> renderStatic staticSprites 258 | 259 | pongCam :: L.ContWire () L.Camera 260 | pongCam = pure zero >>> (L.mk2DCam screenWidth screenHeight) 261 | 262 | -------------------------------------------------- 263 | -- Init 264 | 265 | game :: L.Game Int 266 | game = L.Game pongCam [] $ (id &&& quitWire) >>> gameWire 267 | where 268 | quitWire = 269 | (pure True >>> keyPressed GLFW.Key'Q) `L.withDefault` pure False 270 | 271 | main :: IO () 272 | main = L.runOpenGL screenWidth screenHeight "Pong Demo" 0 game 273 | 274 | -------------------------------------------------- 275 | -- Utils 276 | 277 | circleIntersectRect :: Circle -> Rect -> Bool 278 | circleIntersectRect (c, r) (p, sz) = 279 | let p' = p ^+^ sz 280 | cx = L.clamp (c ^._x) (p ^._x) (p' ^._x) 281 | cy = L.clamp (c ^._y) (p ^._y) (p' ^._y) 282 | in norm (V2 cx cy ^-^ c) < r 283 | 284 | vi2f2 :: (Integral a, Floating f) => V2 a -> V2 f 285 | vi2f2 = fmap fromIntegral 286 | 287 | vi2f3 :: (Integral a, Floating f) => V3 a -> V3 f 288 | vi2f3 = fmap fromIntegral 289 | -------------------------------------------------------------------------------- /lib/Lambency/Shader/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Lambency.Shader.Program where 3 | 4 | -------------------------------------------------------------------------------- 5 | import Control.Monad.RWS.Strict 6 | 7 | import qualified Data.Map as Map 8 | 9 | import Lambency.Vertex 10 | 11 | import Lambency.Shader.Base 12 | import Lambency.Shader.Optimization 13 | 14 | import Linear 15 | -------------------------------------------------------------------------------- 16 | 17 | getDeclType :: Declaration -> DeclarationTy 18 | getDeclType (Attribute _) = AttributeDeclTy 19 | getDeclType (Uniform _) = UniformDeclTy 20 | getDeclType (Varying _) = VaryingDeclTy 21 | getDeclType (ConstDecl _ _) = ConstDeclTy 22 | 23 | addCustomOVar :: String -> ShaderVar a -> ShaderOutput -> ShaderOutput 24 | addCustomOVar name (ShaderVar v) (ShaderOutput vs) = ShaderOutput ((CustomOutput name v):vs) 25 | 26 | addVertexPosition :: ShaderVar (V4 Float) -> ShaderOutput -> ShaderOutput 27 | addVertexPosition (ShaderVar v) (ShaderOutput vs) = 28 | ShaderOutput ((SpecialOutput VertexPosition v) : vs) 29 | 30 | addFragmentColor :: ShaderVar (V4 Float) -> ShaderOutput -> ShaderOutput 31 | addFragmentColor (ShaderVar v) (ShaderOutput vs) = 32 | ShaderOutput ((SpecialOutput FragmentColor v) : vs) 33 | 34 | emptyO :: ShaderOutput 35 | emptyO = ShaderOutput [] 36 | 37 | varyingPrefix :: String 38 | varyingPrefix = "_varying_" 39 | 40 | getOutputVar :: ShaderOutputVar -> ShaderVarRep 41 | getOutputVar (CustomOutput "" v) = v 42 | getOutputVar (CustomOutput name (ShdrVarRep _ i ty)) = ShdrVarRep (varyingPrefix ++ name) i ty 43 | getOutputVar (SpecialOutput _ v) = v 44 | 45 | collectOutput :: (ShaderOutputVar -> Bool) -> ShaderOutput -> [ShaderVarRep] 46 | collectOutput fn = map getOutputVar . filter fn . getOutputVars 47 | 48 | collectCustom :: ShaderOutput -> [ShaderVarRep] 49 | collectCustom = collectOutput isCustom 50 | where 51 | isCustom (CustomOutput _ _) = True 52 | isCustom _ = False 53 | 54 | collectSpecial :: ShaderOutput -> [ShaderVarRep] 55 | collectSpecial = collectOutput isSpecial 56 | where 57 | isSpecial (SpecialOutput _ _) = True 58 | isSpecial _ = False 59 | 60 | mkSpecialStmts :: ShaderOutput -> [Statement] 61 | mkSpecialStmts (ShaderOutput ovars) = concatMap mkStmt ovars 62 | where 63 | mkStmt :: ShaderOutputVar -> [Statement] 64 | mkStmt (SpecialOutput sv v) = [SpecialAssignment sv v] 65 | mkStmt _ = [] 66 | 67 | updateStmt :: ShaderOutputVar -> Statement -> [Statement] 68 | updateStmt (SpecialOutput _ _) s = [s] 69 | updateStmt (CustomOutput _ v1) s@(LocalDecl v2 Nothing) 70 | | v1 == v2 = [] 71 | | otherwise = [s] 72 | updateStmt (CustomOutput name v1) s@(LocalDecl v2 (Just e)) 73 | | v1 == v2 = [Assignment v e] 74 | | otherwise = [s] 75 | where 76 | v = v1 { shdrVarName = (varyingPrefix ++ name) } 77 | updateStmt _ s@(Assignment _ _) = [s] 78 | updateStmt _ s@(SpecialAssignment _ _) = [s] 79 | updateStmt v (IfThenElse e s1 s2) = 80 | let output = ShaderOutput [v] 81 | in [IfThenElse e (updateStmts s1 output) (updateStmts s2 output)] 82 | 83 | updateStmts :: [Statement] -> ShaderOutput -> [Statement] 84 | updateStmts stmts vars = 85 | let updateFor :: ShaderOutputVar -> [Statement] -> [Statement] 86 | updateFor v = concat . map (updateStmt v) 87 | in foldl (flip updateFor) stmts (getOutputVars vars) ++ (mkSpecialStmts vars) 88 | 89 | newVar :: String -> ShaderVarTy a -> ShaderContext (ShaderVar a) 90 | newVar name (ShaderVarTy ty) = do 91 | varID <- get 92 | let nextVarID = varID + 1 93 | var = ShaderVar $ ShdrVarRep name nextVarID ty 94 | put nextVarID 95 | return var 96 | 97 | newUniformVar :: String -> ShaderVarTy a -> ShaderContext (ShaderVar a) 98 | newUniformVar n t = do 99 | v@(ShaderVar vrep) <- newVar n t 100 | tell ([Uniform vrep], mempty) 101 | return v 102 | 103 | newAttributeVar :: String -> ShaderVarTy a -> ShaderContext (ShaderVar a) 104 | newAttributeVar n t = do 105 | v@(ShaderVar vrep) <- newVar n t 106 | tell ([Attribute vrep], mempty) 107 | return v 108 | 109 | setE :: ShaderVarTy a -> Expr a -> ShaderContext (ShaderVar a) 110 | setE ty (Expr e) = do 111 | v@(ShaderVar vrep) <- newVar "_t" ty 112 | tell (mempty, [LocalDecl vrep (Just e)]) 113 | return v 114 | 115 | assignE :: ShaderVar a -> Expr a -> ShaderContext () 116 | assignE (ShaderVar v) (Expr e) = tell (mempty, [Assignment v e]) 117 | 118 | emptyPrg :: ShaderProgram 119 | emptyPrg = ShaderProgram [] [] 120 | 121 | ifThen :: Expr Bool -> ShaderContext () -> ShaderContext () -> ShaderContext () 122 | ifThen (Expr e) (ShdrCtx c1) (ShdrCtx c2) = 123 | ShdrCtx $ RWST $ \ipt st -> 124 | case runRWST c1 ipt (st + 1) of 125 | Nothing -> 126 | case runRWST c2 ipt (st + 1) of 127 | Nothing -> Nothing 128 | Just (_, id2, (decls2, s2)) -> Just ((), id2 + 1, (decls2, [IfThenElse e [] s2])) 129 | Just (_, id1, (decls1, s1)) -> 130 | case runRWST c2 ipt (id1 + 1) of 131 | Nothing -> Just ((), id1 + 1, (decls1, [IfThenElse e s1 []])) 132 | Just (_, id2, (decls2, s2)) -> 133 | Just ((), id2 + 1, (decls1 ++ decls2, [IfThenElse e s1 s2])) 134 | 135 | attribToVarTy :: VertexAttribute -> ShaderVarTyRep 136 | attribToVarTy (VertexAttribute 1 IntAttribTy) = IntTy 137 | attribToVarTy (VertexAttribute 1 FloatAttribTy) = FloatTy 138 | attribToVarTy (VertexAttribute 2 FloatAttribTy) = Vector2Ty 139 | attribToVarTy (VertexAttribute 3 FloatAttribTy) = Vector3Ty 140 | attribToVarTy (VertexAttribute 4 FloatAttribTy) = Vector4Ty 141 | attribToVarTy _ = error "Not implemented!" 142 | 143 | getInput :: ShaderVarTy a -> String -> ShaderContext (ShaderVar a) 144 | getInput vty@(ShaderVarTy expected) name = do 145 | (ShaderInput vars, shaderTy) <- ask 146 | let varMap = Map.fromList $ map (\v@(ShdrVarRep n _ _) -> (n, v)) vars 147 | varName <- 148 | case shaderTy of 149 | VertexShaderTy -> do 150 | ShaderVar v <- newAttributeVar name vty 151 | return $ Just v 152 | FragmentShaderTy -> return $ Map.lookup (varyingPrefix ++ name) varMap 153 | case varName 154 | of Nothing -> error $ "Lambency.Shader.Program (getInput): Unknown shader attribute: " ++ name 155 | (Just v@(ShdrVarRep _ _ ty)) 156 | | ty == expected -> return (ShaderVar v) 157 | | otherwise -> error $ 158 | concat ["Lambency.Shader.Program (getInput): ", 159 | "Type mismatch for attribute ", show name, 160 | ": Expected ", show expected, " got ", show ty] 161 | 162 | getInputi :: String -> ShaderContext (ShaderVar Int) 163 | getInputi = getInput (ShaderVarTy IntTy) 164 | 165 | getInputf :: String -> ShaderContext (ShaderVar Float) 166 | getInputf = getInput (ShaderVarTy FloatTy) 167 | 168 | getInput2f :: String -> ShaderContext (ShaderVar (V2 Float)) 169 | getInput2f = getInput (ShaderVarTy Vector2Ty) 170 | 171 | getInput3f :: String -> ShaderContext (ShaderVar (V3 Float)) 172 | getInput3f = getInput (ShaderVarTy Vector3Ty) 173 | 174 | getInput4f :: String -> ShaderContext (ShaderVar (V4 Float)) 175 | getInput4f = getInput (ShaderVarTy Vector4Ty) 176 | 177 | copyShdrVars :: Int -> [ShaderVarRep] -> [ShaderVarRep] 178 | copyShdrVars _ [] = [] 179 | copyShdrVars lastID ((ShdrVarRep n _ ty) : vs) = (ShdrVarRep n lastID ty) : (copyShdrVars (lastID + 1) vs) 180 | 181 | addVertexOutputs :: [ShaderVarRep] -> [ShaderVarRep] -> [Statement] 182 | addVertexOutputs = zipWith setCopyStmt 183 | where 184 | setCopyStmt :: ShaderVarRep -> ShaderVarRep -> Statement 185 | setCopyStmt new old = Assignment new (VarExpr old) 186 | 187 | removeUnusedStmts :: [ShaderVarRep] -> [Statement] -> [Statement] 188 | removeUnusedStmts _ [] = [] 189 | removeUnusedStmts [] s = s 190 | removeUnusedStmts (x:xs) ys = removeUnusedStmts xs $ removeUnusedVar x ys 191 | where 192 | removeUnusedVar :: ShaderVarRep -> [Statement] -> [Statement] 193 | removeUnusedVar _ [] = [] 194 | removeUnusedVar v (s@(LocalDecl v' _) : stmts) 195 | | v == v' = removeUnusedVar v stmts 196 | | otherwise = s : removeUnusedVar v stmts 197 | removeUnusedVar v (s@(Assignment v' _) : stmts) 198 | | v == v' = removeUnusedVar v stmts 199 | | otherwise = s : removeUnusedVar v stmts 200 | removeUnusedVar v (s@(SpecialAssignment _ _) : stmts) = s : removeUnusedVar v stmts 201 | removeUnusedVar v ((IfThenElse e s1 s2) : stmts) = 202 | (IfThenElse e (removeUnusedVar v s1) (removeUnusedVar v s2)) : removeUnusedVar v stmts 203 | 204 | compileProgram :: ShaderCode -> ShaderCode -> Shader 205 | compileProgram (ShdrCode vertexPrg) (ShdrCode fragmentPrg) = 206 | let Just (vs_output, varID, (vs_decls, vs_stmts)) = runRWST 207 | (compileShdrCode vertexPrg) 208 | (ShaderInput [], VertexShaderTy) 209 | (length vs_input_vars) 210 | 211 | vs_input_vars = concat $ map fromAttribute vs_decls 212 | where 213 | fromAttribute (Attribute v) = [v] 214 | fromAttribute _ = [] 215 | 216 | vs_output_vars = collectCustom vs_output 217 | 218 | extra_vs_stmts = 219 | let (ShaderOutput vs_out) = vs_output 220 | isVSInput (SpecialOutput _ _) = False 221 | isVSInput (CustomOutput _ v) = v `elem` vs_input_vars 222 | 223 | toVSOutput var@(CustomOutput _ v) = Assignment (getOutputVar var) (VarExpr v) 224 | toVSOutput _ = error "Lambency.Shader.Program (compileProgram): Only output that matches input should go here." 225 | in map toVSOutput $ filter isVSInput vs_out 226 | 227 | fs_input_vars = vs_output_vars 228 | 229 | fs_input = ShaderInput fs_input_vars 230 | 231 | Just (fs_output, _, (fs_decls, fs_stmts)) = runRWST 232 | (compileShdrCode fragmentPrg) 233 | (fs_input, FragmentShaderTy) 234 | (varID + length fs_input_vars) 235 | 236 | final_fs_stmts = updateStmts fs_stmts fs_output 237 | 238 | used_fs_inputs = filter (flip isShaderVarUsed final_fs_stmts) fs_input_vars 239 | unused_fs_inputs = filter (not . flip isShaderVarUsed final_fs_stmts) fs_input_vars 240 | 241 | final_vs_stmts = removeUnusedStmts unused_fs_inputs $ extra_vs_stmts ++ updateStmts vs_stmts vs_output 242 | 243 | varyingDecls = map Varying used_fs_inputs 244 | -- attribDecls = map Attribute $ filter (flip isShaderVarUsed final_vs_stmts) vs_input_vars 245 | in 246 | Shader { 247 | vertexProgram = ShaderProgram (vs_decls ++ varyingDecls) final_vs_stmts, 248 | fragmentProgram = ShaderProgram (fs_decls ++ varyingDecls) final_fs_stmts 249 | } 250 | 251 | -------------------------------------------------------------------------------- /lib/Lambency/Sprite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Lambency.Sprite ( 3 | changeSpriteFrameColor, 4 | changeSpriteColor, 5 | loadStaticSprite, 6 | loadStaticSpriteWithTexture, 7 | loadStaticSpriteWithMask, 8 | loadAnimatedSprite, 9 | loadAnimatedSpriteWithTexture, 10 | loadAnimatedSpriteWithMask, 11 | loadFixedSizeAnimatedSprite, 12 | 13 | renderSprite, 14 | renderSpriteWithAlpha, 15 | renderUISprite, 16 | renderUISpriteWithSize, 17 | 18 | SpriteAnimationType(..), 19 | animatedWire, 20 | ) where 21 | 22 | -------------------------------------------------------------------------------- 23 | import Control.Comonad 24 | import Control.Monad.Reader 25 | import Control.Wire 26 | 27 | import Data.List (nub) 28 | 29 | import Lambency.Material 30 | import Lambency.Mesh 31 | import Lambency.Renderer 32 | import Lambency.Texture 33 | import Lambency.Transform 34 | import Lambency.Types 35 | import Lambency.Utils 36 | 37 | import Linear hiding (trace, identity) 38 | import qualified Linear 39 | 40 | import Prelude hiding ((.), id) 41 | -------------------------------------------------------------------------------- 42 | 43 | updateColor :: V4 Float -> Material -> Material 44 | updateColor c mat@(MaskedSpriteMaterial {..}) = 45 | mat { spriteMaskColor = updateMaterialVar4vf c spriteMaskColor } 46 | updateColor _ m = 47 | error $ "Lambency.Sprite (updateColor): Unsupported material type: " ++ show m 48 | 49 | updateAlpha :: Float -> Material -> Material 50 | updateAlpha a' mat@(MaskedSpriteMaterial {..}) = 51 | case spriteMaskColor of 52 | MaterialVar (_, Nothing) -> 53 | mat { spriteMaskColor = updateMaterialVar4vf (V4 1 1 1 a') spriteMaskColor } 54 | MaterialVar (_, Just (Vector4Val (V4 r g b _))) -> 55 | mat { spriteMaskColor = updateMaterialVar4vf (V4 r g b a') spriteMaskColor } 56 | MaterialVar (_, Just _) -> 57 | error $ "Lambency.Sprite (updateAlpha): Internal error -- " <> 58 | "spriteMaskColor is not a V4 value??" 59 | 60 | updateAlpha a mat@(TexturedSpriteMaterial {..}) = 61 | mat { spriteAlpha = updateMaterialVarf a spriteAlpha } 62 | updateAlpha _ m = 63 | error $ "Lambency.Sprite (updateColor): Unsupported material type: " ++ show m 64 | 65 | updateMatrixScale :: V2 Float -> M33 Float -> M33 Float 66 | updateMatrixScale (V2 sx sy) (V3 _ _ t) = V3 (V3 sx 0 0) (V3 0 sy 0) t 67 | 68 | updateMatrixTranslation :: V2 Float -> M33 Float -> M33 Float 69 | updateMatrixTranslation (V2 tx ty) (V3 x y _) = V3 x y (V3 tx ty 1) 70 | 71 | getShaderVarMatrix :: MaterialVar Mat3f -> Mat3f 72 | getShaderVarMatrix (MaterialVar (_, Just (Matrix3Val mat))) = mat 73 | getShaderVarMatrix _ = Linear.identity 74 | 75 | updateScale :: V2 Float -> Material -> Material 76 | updateScale s mat@(MaskedSpriteMaterial {..}) = 77 | let newMatrix = updateMatrixScale s $ getShaderVarMatrix spriteMaskMatrix 78 | in mat { spriteMaskMatrix = updateMaterialVar3mf newMatrix spriteMaskMatrix } 79 | updateScale s mat@(TexturedSpriteMaterial {..}) = 80 | let newMatrix = updateMatrixScale s $ getShaderVarMatrix spriteTextureMatrix 81 | in mat { spriteTextureMatrix = updateMaterialVar3mf newMatrix spriteTextureMatrix } 82 | updateScale _ m = 83 | error $ "Lambency.Sprite (updateScale): Unsupported material type: " ++ show m 84 | 85 | updateTranslation :: V2 Float -> Material -> Material 86 | updateTranslation t mat@(MaskedSpriteMaterial {..}) = 87 | let newMatrix = updateMatrixTranslation t $ getShaderVarMatrix spriteMaskMatrix 88 | in mat { spriteMaskMatrix = updateMaterialVar3mf newMatrix spriteMaskMatrix } 89 | updateTranslation t mat@(TexturedSpriteMaterial {..}) = 90 | let newMatrix = updateMatrixTranslation t $ getShaderVarMatrix spriteTextureMatrix 91 | in mat { spriteTextureMatrix = updateMaterialVar3mf newMatrix spriteTextureMatrix } 92 | updateTranslation _ m = 93 | error $ "Lambency.Sprite (updateTranslation): Unsupported material type: " ++ show m 94 | 95 | -- !FIXME! These functions shouldn't be here and we should really be using lenses 96 | mapROMaterial :: (Material -> Material) -> RenderObject -> RenderObject 97 | mapROMaterial fn ro = ro { material = fn (material ro) } 98 | 99 | mapFrameRO :: (RenderObject -> RenderObject) -> SpriteFrame -> SpriteFrame 100 | mapFrameRO fn sf = sf { frameRO = fn (frameRO sf) } 101 | 102 | addTextFlag :: SpriteFrame -> SpriteFrame 103 | addTextFlag = mapFrameRO $ \ro -> ro { flags = nub $ Text : flags ro } 104 | 105 | changeSpriteFrameColor :: V4 Float -> SpriteFrame -> SpriteFrame 106 | changeSpriteFrameColor c = mapFrameRO $ mapROMaterial $ updateColor c 107 | 108 | mapSpriteFrames :: (SpriteFrame -> SpriteFrame) -> Sprite -> Sprite 109 | mapSpriteFrames f (Sprite frames) = Sprite (fmap f frames) 110 | 111 | changeSpriteColor :: V4 Float -> Sprite -> Sprite 112 | changeSpriteColor c = mapSpriteFrames $ changeSpriteFrameColor c 113 | 114 | addRenderFlag :: RenderFlag -> RenderObject -> RenderObject 115 | addRenderFlag flag r = r { flags = nub $ flag : flags r } 116 | 117 | initStaticSprite :: Bool -> Texture -> ResourceLoader Sprite 118 | initStaticSprite isMask tex = do 119 | let mat = if isMask 120 | then maskedSpriteMaterial tex 121 | else texturedSpriteMaterial tex 122 | ro <- (if isMask then addRenderFlag Transparent else id) 123 | <$> createRenderObject quad mat 124 | return $ Sprite 125 | { spriteFrames = cycleSingleton $ SpriteFrame 126 | { offset = zero 127 | , spriteSize = textureSize tex 128 | , frameRO = ro 129 | } 130 | } 131 | 132 | initAnimatedSprite :: Bool -> [V2 Int] -> [V2 Int] -> Texture 133 | -> ResourceLoader Sprite 134 | initAnimatedSprite isMask frameSzs offsets tex = do 135 | let mat = if isMask 136 | then maskedSpriteMaterial tex 137 | else texturedSpriteMaterial tex 138 | ro <- createRenderObject quad mat 139 | return $ Sprite $ cyclicFromList $ zipWith (curry $ genFrame ro) frameSzs offsets 140 | where 141 | genFrame :: RenderObject -> (V2 Int, V2 Int) -> SpriteFrame 142 | genFrame ro (sz, off) = 143 | let texOff = changeRange off 144 | in SpriteFrame { 145 | offset = texOff, 146 | spriteSize = sz, 147 | frameRO = ro { material = 148 | updateScale (changeRange sz) $ 149 | updateTranslation texOff $ 150 | material ro } 151 | } 152 | 153 | changeRange :: V2 Int -> V2 Float 154 | changeRange (V2 ox oy) = 155 | let (V2 tx ty) = textureSize tex 156 | in V2 157 | (newRange (fromIntegral ox) (0, fromIntegral tx) (0, 1)) 158 | (newRange (fromIntegral oy) (0, fromIntegral ty) (0, 1)) 159 | 160 | loadSpriteWith :: FilePath 161 | -> (Texture -> ResourceLoader Sprite) 162 | -> ResourceLoader (Maybe Sprite) 163 | loadSpriteWith f initFn = do 164 | tex <- loadTexture f 165 | case tex of 166 | Nothing -> return Nothing 167 | (Just t@(Texture _ _)) -> Just <$> initFn t 168 | _ -> return Nothing 169 | 170 | loadStaticSpriteWithTexture :: Texture -> ResourceLoader Sprite 171 | loadStaticSpriteWithTexture = initStaticSprite False 172 | 173 | loadStaticSpriteWithMask :: Texture -> ResourceLoader Sprite 174 | loadStaticSpriteWithMask = initStaticSprite True 175 | 176 | loadStaticSprite :: FilePath -> ResourceLoader (Maybe Sprite) 177 | loadStaticSprite f = loadSpriteWith f (initStaticSprite False) 178 | 179 | loadAnimatedSprite :: FilePath -> [V2 Int] -> [V2 Int] 180 | -> ResourceLoader (Maybe Sprite) 181 | loadAnimatedSprite f frameSzs offsets = 182 | loadSpriteWith f $ initAnimatedSprite False frameSzs offsets 183 | 184 | loadAnimatedSpriteWithTexture :: Texture -> [V2 Int] -> [V2 Int] 185 | -> ResourceLoader (Maybe Sprite) 186 | loadAnimatedSpriteWithTexture t frameSzs offsets = 187 | Just <$> initAnimatedSprite False frameSzs offsets t 188 | 189 | loadAnimatedSpriteWithMask :: Texture -> [V2 Int] -> [V2 Int] 190 | -> ResourceLoader (Maybe Sprite) 191 | loadAnimatedSpriteWithMask t frameSzs offsets = 192 | -- !HACK! Not all animated (multi-frame) mask sprites are fonts... 193 | Just . mapSpriteFrames addTextFlag <$> 194 | initAnimatedSprite True frameSzs offsets t 195 | 196 | loadFixedSizeAnimatedSprite :: FilePath -> V2 Int -> [V2 Int] 197 | -> ResourceLoader (Maybe Sprite) 198 | loadFixedSizeAnimatedSprite f frameSz = loadAnimatedSprite f (repeat frameSz) 199 | 200 | renderUISpriteWithSize :: Sprite -> V2 Float -> V2 Float -> GameMonad () 201 | renderUISpriteWithSize sprite pos (V2 sx sy) 202 | = let (V2 px py) = pos 203 | in addTransformedRenderAction (nonuniformScale (V3 sx sy 1) identity) 204 | $ addRenderUIAction (V2 (px / sx) (py / sy)) 205 | (frameRO . extract $ spriteFrames sprite) 206 | 207 | renderUISprite :: Sprite -> V2 Float -> GameMonad () 208 | renderUISprite s@(Sprite frames) pos = 209 | renderUISpriteWithSize s pos $ fromIntegral <$> spriteSize (extract frames) 210 | 211 | renderFrameAt :: RenderObject -> V2 Int -> Float -> V2 Float -> GameMonad () 212 | renderFrameAt ro sc depth (V2 x y) = addRenderAction xf ro 213 | where 214 | (V2 sx sy) = fmap fromIntegral sc 215 | xf = translate (V3 x y depth) $ 216 | nonuniformScale (V3 sx sy 1) identity 217 | 218 | -- Renders an opaque sprite at the given scale, depth, and position 219 | renderSprite :: Sprite -> V2 Int -> Float -> V2 Float -> GameMonad () 220 | renderSprite s = renderSpriteWithAlpha s 1.0 221 | 222 | -- Renders a sprite for the given alpha, scale, depth, and position 223 | renderSpriteWithAlpha :: Sprite -> Float -> V2 Int -> Float -> V2 Float -> 224 | GameMonad () 225 | renderSpriteWithAlpha (Sprite frames) a 226 | | a == 0.0 = \_ _ _ -> return () 227 | | a == 1.0 = renderFrameAt (frameRO $ extract frames) 228 | | otherwise = renderFrameAt (setAlpha . frameRO . extract $ frames) 229 | where 230 | setAlpha ro = ro { material = updateAlpha a (material ro), 231 | flags = nub $ Transparent : flags ro } 232 | 233 | data SpriteAnimationType 234 | = SpriteAnimationType'Forward 235 | | SpriteAnimationType'Backward 236 | | SpriteAnimationType'Loop 237 | | SpriteAnimationType'LoopBack 238 | | SpriteAnimationType'PingPong 239 | deriving (Eq, Ord, Show, Enum, Bounded) 240 | 241 | animatedWire :: Sprite -> SpriteAnimationType -> GameWire a Sprite 242 | animatedWire (Sprite (CyclicList _ _ [])) SpriteAnimationType'Forward = mkEmpty 243 | animatedWire s@(Sprite frames) SpriteAnimationType'Forward = 244 | mkGenN $ \ _ -> do 245 | let nextSprite = Sprite (advance frames) 246 | return (Right s, animatedWire nextSprite SpriteAnimationType'Forward) 247 | 248 | animatedWire (Sprite (CyclicList p c n)) SpriteAnimationType'Backward = 249 | animatedWire (Sprite (CyclicList n c p)) SpriteAnimationType'Forward 250 | 251 | animatedWire s SpriteAnimationType'Loop = 252 | let w = animatedWire s SpriteAnimationType'Forward 253 | in w --> w 254 | 255 | animatedWire s SpriteAnimationType'LoopBack = 256 | let w = animatedWire s SpriteAnimationType'Backward 257 | in w --> w 258 | 259 | animatedWire s SpriteAnimationType'PingPong = 260 | let f = animatedWire s SpriteAnimationType'Forward 261 | b = animatedWire s SpriteAnimationType'Backward 262 | in 263 | f --> b --> animatedWire s SpriteAnimationType'PingPong 264 | -------------------------------------------------------------------------------- /lib/Lambency/Camera.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Lambency.Camera ( 3 | mkOrthoCamera, 4 | mkPerspCamera, 5 | getViewProjMatrix, 6 | 7 | getCamXForm, 8 | setCamXForm, 9 | getCamDist, 10 | setCamDist, 11 | getCamPos, 12 | setCamPos, 13 | getCamDir, 14 | setCamDir, 15 | getCamUp, 16 | setCamUp, 17 | getCamNear, 18 | setCamNear, 19 | getCamFar, 20 | setCamFar, 21 | 22 | camLookAt, 23 | 24 | mkFixedCam, 25 | mkViewerCam, 26 | mkFreeCam, 27 | mk2DCam, 28 | ) where 29 | -------------------------------------------------------------------------------- 30 | import Control.Wire 31 | import qualified Graphics.UI.GLFW as GLFW 32 | import FRP.Netwire.Input 33 | import GHC.Float 34 | import Lambency.Types 35 | import qualified Lambency.Transform as XForm 36 | import qualified Linear.Quaternion as Quat 37 | import Linear 38 | 39 | import Prelude hiding (id, (.)) 40 | -------------------------------------------------------------------------------- 41 | 42 | mkXForm :: Vec3f -> Vec3f -> Vec3f -> XForm.Transform 43 | mkXForm pos dir up = let 44 | r = signorm $ dir `cross` up 45 | u' = signorm $ r `cross` dir 46 | in XForm.translate pos $ XForm.fromCoordinateBasis (r, u', negate dir) 47 | 48 | mkOrthoCamera :: Vec3f -> Vec3f -> Vec3f -> 49 | Float -> Float -> Float -> Float -> Float -> Float -> 50 | Camera 51 | mkOrthoCamera pos dir up l r t b n f = Camera 52 | (mkXForm pos (signorm dir) (signorm up)) 53 | (Ortho l r t b) 54 | (CameraViewDistance n f) 55 | 56 | mkPerspCamera :: Vec3f -> Vec3f -> Vec3f -> 57 | Float -> Float -> Float -> Float -> Camera 58 | mkPerspCamera pos dir up fovy aspratio n f = Camera 59 | 60 | (mkXForm pos (signorm dir) (signorm up)) 61 | 62 | Persp { 63 | fovY = fovy, 64 | aspect = aspratio 65 | } 66 | 67 | CameraViewDistance { 68 | near = n, 69 | far = f 70 | } 71 | 72 | -- !FIXME! Change the following functions to val -> Camera -> Camera 73 | getCamXForm :: Camera -> XForm.Transform 74 | getCamXForm (Camera xf _ _) = xf 75 | 76 | setCamXForm :: Camera -> XForm.Transform -> Camera 77 | setCamXForm (Camera _ cam dist) xf = Camera xf cam dist 78 | 79 | getCamDist :: Camera -> CameraViewDistance 80 | getCamDist (Camera _ _ dist) = dist 81 | 82 | setCamDist :: Camera -> CameraViewDistance -> Camera 83 | setCamDist (Camera loc cam _) dist = Camera loc cam dist 84 | 85 | getCamPos :: Camera -> Vec3f 86 | getCamPos = XForm.position . getCamXForm 87 | 88 | setCamPos :: Camera -> Vec3f -> Camera 89 | setCamPos c p = let 90 | xf = getCamXForm c 91 | nd = XForm.forward xf 92 | u = XForm.up xf 93 | in 94 | setCamXForm c $ mkXForm p (negate nd) u 95 | 96 | getCamDir :: Camera -> Vec3f 97 | getCamDir = negate . XForm.forward . getCamXForm 98 | 99 | setCamDir :: Camera -> Vec3f -> Camera 100 | setCamDir c d = let 101 | xf = getCamXForm c 102 | u = XForm.up xf 103 | p = XForm.position xf 104 | in 105 | setCamXForm c $ mkXForm p d u 106 | 107 | getCamUp :: Camera -> Vec3f 108 | getCamUp = XForm.up . getCamXForm 109 | 110 | setCamUp :: Camera -> Vec3f -> Camera 111 | setCamUp c u = let 112 | xf = getCamXForm c 113 | nd = XForm.forward xf 114 | p = XForm.position xf 115 | in 116 | setCamXForm c $ mkXForm p (negate nd) u 117 | 118 | getCamNear :: Camera -> Float 119 | getCamNear = near . getCamDist 120 | 121 | setCamNear :: Camera -> Float -> Camera 122 | setCamNear c n = let 123 | dist = getCamDist c 124 | in 125 | setCamDist c $ (\d -> d { near = n }) dist 126 | 127 | getCamFar :: Camera -> Float 128 | getCamFar = (far . getCamDist) 129 | 130 | setCamFar :: Camera -> Float -> Camera 131 | setCamFar c f = let 132 | dist = getCamDist c 133 | in 134 | setCamDist c $ (\d -> d { far = f }) dist 135 | 136 | camLookAt :: Vec3f -> Camera -> Camera 137 | camLookAt focus (Camera xf ty dist) 138 | | focus == pos = Camera xf ty dist 139 | | otherwise = Camera (mkXForm pos dir up) ty dist 140 | where 141 | pos = XForm.position xf 142 | dir = signorm $ focus - pos 143 | up = XForm.up xf 144 | 145 | getViewMatrix :: Camera -> Mat4f 146 | getViewMatrix (Camera xf _ _) = 147 | let 148 | extendWith :: Float -> Vec3f -> Vec4f 149 | extendWith w (V3 x y z) = V4 x y z w 150 | pos = negate . XForm.position $ xf 151 | (V3 sx sy sz) = XForm.scale xf 152 | r = XForm.right xf 153 | u = XForm.up xf 154 | f = XForm.forward xf 155 | te :: Vec3f -> Float -> Vec4f 156 | te n sc = extendWith (pos `dot` n) (sc *^ n) 157 | in adjoint $ V4 (te r sx) (te u sy) (te f sz) (V4 0 0 0 1) 158 | 159 | mkProjMatrix :: CameraType -> CameraViewDistance -> Mat4f 160 | mkProjMatrix (Ortho l r t b) (CameraViewDistance{..}) = 161 | transpose $ ortho l r b t near far 162 | mkProjMatrix (Persp {..}) (CameraViewDistance{..}) = 163 | transpose $ perspective fovY aspect near far 164 | 165 | getProjMatrix :: Camera -> Mat4f 166 | getProjMatrix (Camera _ ty dist) = mkProjMatrix ty dist 167 | 168 | getViewProjMatrix :: Camera -> Mat4f 169 | getViewProjMatrix c = (getViewMatrix c) !*! (getProjMatrix c) 170 | 171 | -- 172 | 173 | mkFixedCam :: Camera -> ContWire a Camera 174 | mkFixedCam cam = CW $ mkConst $ Right cam 175 | 176 | type ViewCam = (Camera, Vec3f) 177 | 178 | mkViewerCam :: Camera -> Vec3f -> ContWire a Camera 179 | mkViewerCam initialCam initialFocus = 180 | let handleRotation :: ((Float, Float), ViewCam) -> ViewCam 181 | handleRotation ((0, 0), c) = c 182 | handleRotation ((mx, my), (c@(Camera xform _ _), focus)) = 183 | (setCamPos (setCamDir c (signorm $ negate newPos)) (newPos ^+^ focus), focus) 184 | where 185 | oldPos :: Vec3f 186 | oldPos = XForm.position xform ^-^ focus 187 | 188 | newPos :: Vec3f 189 | newPos = XForm.transformPoint rotation oldPos 190 | 191 | rotation :: XForm.Transform 192 | rotation = flip XForm.rotate XForm.identity $ 193 | foldl1 (*) [ 194 | Quat.axisAngle (XForm.up xform) (-asin mx), 195 | Quat.axisAngle (XForm.right xform) (-asin my)] 196 | 197 | dxScale :: Vec3f -> Vec3f -> Float 198 | dxScale pos focus = (0.4 *) $ distance pos focus 199 | 200 | handleScroll :: ((Double, Double), ViewCam) -> ViewCam 201 | handleScroll ((_, sy), (c, x)) = 202 | let camPos = getCamPos c 203 | camDir = getCamDir c 204 | dx = (dxScale camPos x * double2Float sy) *^ camDir 205 | -- !FIXME! We should really do mouse picking here to keep the focus 206 | -- on whatever point we're intersecting with the mesh... for right now 207 | -- just don't move the focus. 208 | -- in (setCamPos c $ camPos ^+^ dx, x ^+^ dx) 209 | in (setCamPos c $ camPos ^+^ dx, x) 210 | 211 | handlePanning :: ((Float, Float), ViewCam) -> ViewCam 212 | handlePanning ((0, 0), c) = c 213 | handlePanning ((mx, my), (c@(Camera xform _ _), focus)) = 214 | (setCamPos c (oldPos ^+^ dx), focus ^+^ dx) 215 | where 216 | oldPos = XForm.position xform 217 | dx = (dxScale oldPos focus *^) $ 218 | (-mx *^ (XForm.right xform)) ^+^ (my *^ (XForm.up xform)) 219 | 220 | {-- !TODO! This might be good to add to netwire-input --} 221 | mouseIfThen :: GLFW.MouseButton -> GameWire a b -> GameWire a b -> GameWire a b 222 | mouseIfThen mb ifPressed elsePressed = whilePressed 223 | where 224 | whilePressed = (mousePressed mb >>> ifPressed) --> whileNotPressed 225 | whileNotPressed = switch $ 226 | elsePressed &&& 227 | ((mousePressed mb >>> pure whilePressed >>> now) 228 | <|> never) 229 | 230 | mouseDeltas :: GLFW.MouseButton -> GameWire a (Float, Float) 231 | mouseDeltas mb = mouseIfThen mb getDelta $ pure (0, 0) 232 | where 233 | delayM :: Monad m => m a -> Wire s e m a a 234 | delayM x' = mkGenN $ \x -> do 235 | r <- x' 236 | return (Right r, delayM $ return x) 237 | 238 | delayCursor :: GameWire (Float, Float) (Float, Float) 239 | delayCursor = delayM cursor 240 | 241 | getDelta :: GameWire a (Float, Float) 242 | getDelta = 243 | loop $ (mouseCursor *** delayCursor) >>> 244 | (arr $ \((x, y), (x', y')) -> ((x - x', y - y'), (x, y))) 245 | 246 | rotationalDeltas :: GameWire a (Float, Float) 247 | rotationalDeltas = 248 | (keyPressed GLFW.Key'LeftShift >>> pure (0, 0)) 249 | <|> mouseDeltas GLFW.MouseButton'1 250 | 251 | panningDeltas :: GameWire a (Float, Float) 252 | panningDeltas = 253 | (keyPressed GLFW.Key'LeftShift >>> mouseDeltas GLFW.MouseButton'1) 254 | <|> mouseDeltas GLFW.MouseButton'3 255 | in 256 | CW $ loop $ second ( 257 | delay (initialCam, initialFocus) >>> 258 | (rotationalDeltas &&& id) >>> (arr handleRotation) >>> 259 | (panningDeltas &&& id) >>> (arr handlePanning) >>> 260 | (mouseScroll &&& id) >>> (arr handleScroll)) 261 | >>> (arr $ \(_, c@(cam, _)) -> (cam, c)) 262 | 263 | mkFreeCam :: Camera -> ContWire a Camera 264 | mkFreeCam initCam = 265 | CW $ loop ((second (delay initCam >>> updCam)) >>> feedback) 266 | where 267 | feedback :: GameWire (a, b) (b, b) 268 | feedback = mkPure_ $ \(_, x) -> Right (x, x) 269 | 270 | tr :: GLFW.Key -> Float -> (XForm.Transform -> Vec3f) -> 271 | GameWire XForm.Transform XForm.Transform 272 | tr key sc dir = (trans >>> (keyPressed key)) <|> id 273 | where 274 | trans :: GameWire XForm.Transform XForm.Transform 275 | trans = mkSF $ \ts xf -> 276 | (XForm.translate (3.0 * (dtime ts) * sc *^ (dir xf)) xf, trans) 277 | 278 | updCam :: GameWire Camera Camera 279 | updCam = (id &&& (arr getCamXForm >>> xfWire)) 280 | >>> (mkSF_ $ uncurry stepCam) 281 | where 282 | xfWire :: GameWire XForm.Transform XForm.Transform 283 | xfWire = 284 | (tr GLFW.Key'W (-1.0) XForm.forward) >>> 285 | (tr GLFW.Key'S (1.0) XForm.forward) >>> 286 | (tr GLFW.Key'A (-1.0) XForm.right) >>> 287 | (tr GLFW.Key'D (1.0) XForm.right) >>> 288 | (id &&& mouseMickies) >>> 289 | (mkSF_ $ \(xf, (mx, my)) -> 290 | XForm.rotate 291 | (foldl1 (*) [ 292 | Quat.axisAngle (XForm.up xf) (-asin mx), 293 | Quat.axisAngle (XForm.right xf) (-asin my)]) 294 | xf) 295 | 296 | stepCam :: Camera -> XForm.Transform -> Camera 297 | stepCam cam newXForm = setCamXForm cam finalXForm 298 | where 299 | finalXForm = mkXForm 300 | (XForm.position newXForm) 301 | (negate $ XForm.forward newXForm) 302 | (V3 0 1 0) 303 | 304 | mk2DCam :: Int -> Int -> ContWire Vec2f Camera 305 | mk2DCam sx sy = let 306 | toHalfF :: Integral a => a -> Float 307 | toHalfF x = 0.5 * (fromIntegral x) 308 | 309 | hx :: Float 310 | hx = toHalfF sx 311 | 312 | hy :: Float 313 | hy = toHalfF sy 314 | 315 | screenCenter :: V3 Float 316 | screenCenter = V3 hx hy 1 317 | 318 | trPos :: Vec2f -> Vec3f 319 | trPos (V2 x y) = (V3 x y 0) ^+^ screenCenter 320 | in 321 | CW $ mkSF_ $ \vec -> mkOrthoCamera 322 | (trPos vec) (negate XForm.localForward) XForm.localUp 323 | (-hx) (hx) (hy) (-hy) 324 | 0.01 50.0 325 | -------------------------------------------------------------------------------- /lib/Lambency/Shader/OpenGL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lambency.Shader.OpenGL ( 3 | generateOpenGLShader 4 | ) where 5 | 6 | -------------------------------------------------------------------------------- 7 | import qualified Data.ByteString.Char8 as BS 8 | import qualified Data.List as List 9 | import qualified Data.Map as Map 10 | 11 | import qualified Graphics.Rendering.OpenGL as GL 12 | 13 | import Lambency.Shader.Base 14 | import Lambency.Shader.Program 15 | 16 | import qualified Lambency.Types as L 17 | 18 | import Linear 19 | -------------------------------------------------------------------------------- 20 | 21 | showBS :: (Show a) => a -> BS.ByteString 22 | showBS = BS.pack . show 23 | 24 | buildConstant :: Constant -> BS.ByteString 25 | buildConstant (ConstMat2 _) = error "Unable to specify const mat2 variable" 26 | buildConstant (ConstMat3 _) = error "Unable to specify const mat3 variable" 27 | buildConstant (ConstMat4 _) = error "Unable to specify const mat4 variable" 28 | 29 | buildConstant (ConstVec2f (V2 x y)) = 30 | BS.concat ["vec2(", showBS x, ", ", showBS y, ")"] 31 | 32 | buildConstant (ConstVec3f (V3 x y z)) = 33 | BS.concat ["vec3(", showBS x, ", ", showBS y, ", ", showBS z, ")"] 34 | 35 | buildConstant (ConstVec4f (V4 x y z w)) = 36 | BS.concat ["vec4(", showBS x, ", ", showBS y, ", ", showBS z, ", ", showBS w, ")"] 37 | 38 | buildConstant (ConstVec2i (V2 x y)) = 39 | BS.concat ["ivec2(", showBS x, ", ", showBS y, ")"] 40 | 41 | buildConstant (ConstVec3i (V3 x y z)) = 42 | BS.concat ["ivec3(", showBS x, ", ", showBS y, ", ", showBS z, ")"] 43 | 44 | buildConstant (ConstVec4i (V4 x y z w)) = 45 | BS.concat ["ivec4(", showBS x, ", ", showBS y, ", ", showBS z, ", ", showBS w, ")"] 46 | 47 | buildConstant (ConstFloat x) = showBS x 48 | buildConstant (ConstInt x) = showBS x 49 | 50 | -------------------------------------------------- 51 | 52 | getSwizzleBS :: SwizzleVar -> BS.ByteString 53 | getSwizzleBS SwizzleX = "x" 54 | getSwizzleBS SwizzleY = "y" 55 | getSwizzleBS SwizzleZ = "z" 56 | getSwizzleBS SwizzleW = "w" 57 | 58 | buildSwizzle :: (SwizzleVar, Maybe SwizzleVar, Maybe SwizzleVar, Maybe SwizzleVar) -> BS.ByteString 59 | buildSwizzle (v1, Nothing, Nothing, Nothing) = getSwizzleBS v1 60 | buildSwizzle (v1, Just v2, Nothing, Nothing) = BS.concat $ map getSwizzleBS [v1, v2] 61 | buildSwizzle (v1, Just v2, Just v3, Nothing) = BS.concat $ map getSwizzleBS [v1, v2, v3] 62 | buildSwizzle (v1, Just v2, Just v3, Just v4) = BS.concat $ map getSwizzleBS [v1, v2, v3, v4] 63 | buildSwizzle _ = error "Internal error: Swizzle function built incorrectly!" 64 | 65 | -------------------------------------------------- 66 | 67 | unaryOpBS :: UnaryInfix -> BS.ByteString 68 | unaryOpBS Negate = "-" 69 | 70 | unaryFnBS :: UnaryFun -> BS.ByteString 71 | unaryFnBS Floor = "floor" 72 | unaryFnBS Ceiling = "ceil" 73 | unaryFnBS Sine = "sin" 74 | unaryFnBS Cosine = "cos" 75 | unaryFnBS Normalize = "normalize" 76 | unaryFnBS Length = "length" 77 | unaryFnBS Fract = "fract" 78 | unaryFnBS CastFloat = "float" 79 | 80 | buildUnary :: UnaryOp -> ExprRep -> BS.ByteString 81 | buildUnary (UnaryInfixOp op) e = BS.concat [unaryOpBS op, "(", buildExpr e, ")"] 82 | buildUnary (UnaryFunOp op) e = BS.concat [unaryFnBS op, "(", buildExpr e, ")"] 83 | 84 | -------------------------------------------------- 85 | 86 | binOpBS :: BinaryInfix -> BS.ByteString 87 | binOpBS Add = "+" 88 | binOpBS Sub = "-" 89 | binOpBS Mult = "*" 90 | binOpBS Div = "/" 91 | binOpBS LessThan = "<" 92 | binOpBS GreaterThan = ">" 93 | 94 | binFnBS :: BinaryFunction -> BS.ByteString 95 | binFnBS Pow = "pow" 96 | binFnBS Max = "max" 97 | binFnBS Min = "min" 98 | binFnBS Dot = "dot" 99 | binFnBS Sample1D = "texture1D" 100 | binFnBS Sample2D = "texture2D" 101 | binFnBS Sample3D = "texture3D" 102 | binFnBS Shadow2D = "shadow2D" 103 | 104 | buildBinary :: BinaryOp -> ExprRep -> ExprRep -> BS.ByteString 105 | 106 | buildBinary (BinaryInfixOp op) e1 e2 = 107 | BS.concat ["(", buildExpr e1, ") ", 108 | binOpBS op, 109 | " (", buildExpr e2, ")"] 110 | 111 | buildBinary (BinaryFunOp fn) e1 e2 = 112 | BS.concat [binFnBS fn, "(", buildExpr e1, ", ", buildExpr e2, ")"] 113 | 114 | -------------------------------------------------- 115 | 116 | ternFnBS :: TernaryOp -> BS.ByteString 117 | ternFnBS Clamp = "clamp" 118 | ternFnBS Mix = "mix" 119 | 120 | buildTernary :: TernaryOp -> ExprRep -> ExprRep -> ExprRep -> BS.ByteString 121 | buildTernary fn e1 e2 e3 = BS.concat [ 122 | ternFnBS fn, 123 | "(", 124 | buildExpr e1, 125 | ", ", 126 | buildExpr e2, 127 | ", ", 128 | buildExpr e3, 129 | ")"] 130 | 131 | -------------------------------------------------- 132 | 133 | buildVecExpr :: VecExpr -> BS.ByteString 134 | buildVecExpr (Vec2Expr e1 e2) = BS.concat ["vec2(", buildExpr e1, ", ", 135 | buildExpr e2, ")"] 136 | 137 | buildVecExpr (Vec3Expr e1 e2 e3) = BS.concat ["vec3(", 138 | buildExpr e1, ", ", 139 | buildExpr e2, ", ", 140 | buildExpr e3, ")"] 141 | 142 | buildVecExpr (Vec4Expr e1 e2 e3 e4) = BS.concat ["vec4(", 143 | buildExpr e1, ", ", 144 | buildExpr e2, ", ", 145 | buildExpr e3, ", ", 146 | buildExpr e4, ")"] 147 | 148 | -------------------------------------------------- 149 | 150 | buildExpr :: ExprRep -> BS.ByteString 151 | buildExpr (VarExpr v) = varName v 152 | buildExpr (ConstExpr c) = buildConstant c 153 | buildExpr (SwizzleExpr e sw) = BS.concat ["(", buildExpr e, ").", buildSwizzle sw] 154 | buildExpr (Unary op e) = buildUnary op e 155 | buildExpr (Binary op e1 e2) = buildBinary op e1 e2 156 | buildExpr (Ternary op e1 e2 e3) = buildTernary op e1 e2 e3 157 | buildExpr (NewVec ve) = buildVecExpr ve 158 | 159 | buildStatement :: Int -> Statement -> BS.ByteString 160 | buildStatement indent = flip BS.append ";\n" . buildStmt 161 | where buildStmt (LocalDecl v (Just e)) = BS.concat [ 162 | varDeclaration v, 163 | " = ", 164 | buildExpr e] 165 | buildStmt (LocalDecl v Nothing) = varDeclaration v 166 | buildStmt (Assignment v e) = BS.concat [varName v, " = ", buildExpr e] 167 | buildStmt (IfThenElse e s1 s2) = BS.concat [ 168 | "if (", 169 | buildExpr e, 170 | ") {\n", 171 | buildStatements (indent + 2) s1, 172 | BS.replicate indent ' ', 173 | "} else {\n", 174 | buildStatements (indent + 2) s2, 175 | BS.replicate indent ' ', 176 | "}"] 177 | buildStmt (SpecialAssignment VertexPosition v) = 178 | BS.concat ["gl_Position = ", varName v] 179 | buildStmt (SpecialAssignment FragmentColor v) = 180 | BS.concat ["gl_FragColor = ", varName v] 181 | 182 | buildStatements :: Int -> [Statement] -> BS.ByteString 183 | buildStatements indent stmts = 184 | BS.concat $ map ((BS.append $ BS.replicate indent ' ') . buildStatement indent) stmts 185 | 186 | varTy :: ShaderVarTyRep -> BS.ByteString 187 | varTy Matrix2Ty = "mat2" 188 | varTy Matrix3Ty = "mat3" 189 | varTy Matrix4Ty = "mat4" 190 | varTy Vector2Ty = "vec2" 191 | varTy Vector3Ty = "vec3" 192 | varTy Vector4Ty = "vec4" 193 | varTy IntTy = "int" 194 | varTy FloatTy = "float" 195 | varTy Sampler1DTy = "sampler1D" 196 | varTy Sampler2DTy = "sampler2D" 197 | varTy Sampler3DTy = "sampler3D" 198 | varTy Shadow2DTy = "sampler2DShadow" 199 | varTy _ = error "Lambency.Shader.OpenGL -- varTy: Not implemented!" 200 | 201 | {-- !FIXME! what was I thinking here? 202 | varTy IntListTy = "IntListTy" 203 | varTy FloatListTy = "FloatListTy" 204 | varTy Matrix3ListTy = "Matrix3ListTy" 205 | varTy Matrix4ListTy = "Matrix4ListTy" 206 | varTy Vector2ListTy = "Vector2ListTy" 207 | varTy Vector3ListTy = "Vector3ListTy" 208 | varTy Vector4ListTy = "Vector4ListTy" 209 | --} 210 | 211 | varName :: ShaderVarRep -> BS.ByteString 212 | varName (ShdrVarRep n i _) = BS.concat [BS.pack n, "_", showBS i] 213 | 214 | varDeclaration :: ShaderVarRep -> BS.ByteString 215 | varDeclaration v@(ShdrVarRep _ _ ty) = BS.concat [varTy ty, " ", varName v] 216 | 217 | buildDeclaration :: Declaration -> BS.ByteString 218 | buildDeclaration = flip BS.append ";\n" . declString 219 | where 220 | declString :: Declaration -> BS.ByteString 221 | declString (Attribute v) = BS.append "attribute " (varDeclaration v) 222 | declString (Uniform v) = BS.append "uniform " (varDeclaration v) 223 | declString (Varying v) = BS.append "varying " (varDeclaration v) 224 | declString (ConstDecl v e) = BS.concat [ 225 | "const ", 226 | varDeclaration v, 227 | " = ", 228 | buildExpr e] 229 | 230 | buildDeclarations :: [Declaration] -> BS.ByteString 231 | buildDeclarations decls' = 232 | let groupDecls x y = getDeclType x == getDeclType y 233 | decls = concat $ List.groupBy groupDecls decls' 234 | in BS.concat $ map buildDeclaration decls ++ [BS.singleton '\n'] 235 | 236 | buildOpenGLSource :: ShaderProgram -> BS.ByteString 237 | buildOpenGLSource (ShaderProgram decls stmts) = 238 | BS.concat ["#version 120\n", 239 | buildDeclarations decls, 240 | "void main() {\n", 241 | buildStatements 2 stmts, 242 | "}"] 243 | 244 | printShaderSrc :: BS.ByteString -> IO () 245 | printShaderSrc shdrSrc = putStrLn $ BS.unpack numberedSrc 246 | where 247 | numStrs = map (BS.take 5 . flip (BS.append) ": " . showBS) [1::Int,2..] 248 | numberedSrc = BS.intercalate (BS.singleton '\n') $ 249 | zipWith BS.append numStrs $ BS.lines shdrSrc 250 | 251 | generateShader :: ShaderProgram -> GL.ShaderType -> IO (GL.Shader) 252 | generateShader prg ty = do 253 | shdr <- GL.createShader ty 254 | let shdrSrc = buildOpenGLSource prg 255 | GL.shaderSourceBS shdr GL.$= shdrSrc 256 | GL.compileShader shdr 257 | success <- GL.get $ GL.compileStatus shdr 258 | -- printShaderSrc shdrSrc 259 | case success of 260 | True -> return () 261 | False -> do 262 | putStrLn (replicate 80 '-') 263 | shaderLog <- GL.get $ GL.shaderInfoLog shdr 264 | putStrLn shaderLog 265 | printShaderSrc shdrSrc 266 | putStrLn (replicate 80 '-') 267 | error "Internal Error: OpenGL shader compilation failed!" 268 | return shdr 269 | 270 | toHighLevel :: ShaderVarTyRep -> L.ShaderValue 271 | toHighLevel Matrix2Ty = L.Matrix2Val identity 272 | toHighLevel Matrix3Ty = L.Matrix3Val identity 273 | toHighLevel Matrix4Ty = L.Matrix4Val identity 274 | toHighLevel Matrix3ListTy = L.Matrix3ListVal [] 275 | toHighLevel Matrix4ListTy = L.Matrix4ListVal [] 276 | toHighLevel Vector2Ty = L.Vector2Val zero 277 | toHighLevel Vector3Ty = L.Vector3Val zero 278 | toHighLevel Vector4Ty = L.Vector4Val zero 279 | toHighLevel Vector2ListTy = L.Vector2ListVal [] 280 | toHighLevel Vector3ListTy = L.Vector3ListVal [] 281 | toHighLevel Vector4ListTy = L.Vector4ListVal [] 282 | toHighLevel IntTy = L.IntVal 0 283 | toHighLevel IntListTy = L.IntListVal [] 284 | toHighLevel FloatTy = L.FloatVal 0 285 | toHighLevel FloatListTy = L.FloatListVal [] 286 | toHighLevel Sampler1DTy = L.TextureVal undefined undefined 287 | toHighLevel Sampler2DTy = L.TextureVal undefined undefined 288 | toHighLevel Sampler3DTy = L.TextureVal undefined undefined 289 | toHighLevel Shadow2DTy = L.ShadowMapVal undefined undefined 290 | 291 | lookupUniform :: GL.Program -> Declaration -> IO (String, L.ShaderVar) 292 | lookupUniform prg (Uniform v@(ShdrVarRep n _ ty)) = do 293 | uloc <- GL.get $ GL.uniformLocation prg (BS.unpack $ varName v) 294 | if uloc == (GL.UniformLocation (-1)) 295 | then error $ concat ["Internal Error: Did not find uniform " 296 | , n, " of type ", show ty 297 | ] 298 | else return (n, L.Uniform (toHighLevel ty) (L.OpenGLUniformBinding uloc)) 299 | lookupUniform _ _ = error "Internal error: Is not a uniform!" 300 | 301 | lookupAttrib :: GL.Program -> Declaration -> IO (String, L.ShaderVar) 302 | lookupAttrib prg (Attribute v@(ShdrVarRep n _ ty)) = do 303 | aloc <- GL.get $ GL.attribLocation prg (BS.unpack $ varName v) 304 | if aloc == (GL.AttribLocation maxBound) 305 | then error $ concat ["Internal Error: Did not find attribute " 306 | , n, " of type ", show ty 307 | ] 308 | else return (n, L.Attribute (toHighLevel ty) (L.OpenGLAttributeBinding aloc)) 309 | lookupAttrib _ _ = error "Internal error: Is not an attribute!" 310 | 311 | genVariableLocs :: GL.Program -> [Declaration] -> IO (L.ShaderMap) 312 | genVariableLocs prg decls = 313 | let ufrms = filter ((== UniformDeclTy) . getDeclType) decls 314 | attribs = filter ((== AttributeDeclTy) . getDeclType) decls 315 | in do 316 | attrMap <- mapM (lookupAttrib prg) attribs 317 | ufrmMap <- mapM (lookupUniform prg) ufrms 318 | return $ Map.union (Map.fromList attrMap) (Map.fromList ufrmMap) 319 | 320 | generateOpenGLShader :: Shader -> IO (L.Shader) 321 | generateOpenGLShader (Shader vs@(ShaderProgram vs_decls _) 322 | fs@(ShaderProgram fs_decls _)) = do 323 | prg <- GL.createProgram 324 | generateShader vs GL.VertexShader >>= GL.attachShader prg 325 | generateShader fs GL.FragmentShader >>= GL.attachShader prg 326 | GL.linkProgram prg 327 | 328 | vars <- genVariableLocs prg (vs_decls ++ fs_decls) 329 | 330 | return $ L.OpenGLShader prg vars 331 | --------------------------------------------------------------------------------