diff --git a/FWGL.hs b/FWGL.hs --- a/FWGL.hs +++ b/FWGL.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + {-| The main module. You should also import a backend: * FWGL.Backend.JavaScript: GHCJS/WebGL backend (contained in fwgl-javascript) * FWGL.Backend.GLFW.GL20: GLFW/OpenGL 2.0 backend (contained in fwgl-glfw) - * FWGL.Backend.GLFW.GLES20: GLFW/OpenGL ES 2.0 backend (WIP) And a graphics system: @@ -12,6 +13,7 @@ * "FWGL.Graphics.D3": 3D graphics * "FWGL.Graphics.Custom": advanced custom graphics + "FWGL.Shader" contains the EDSL to make custom shaders. -} module FWGL ( @@ -19,10 +21,15 @@ module FWGL.Input, module FWGL.Utils, module FRP.Yampa, - Output(..), - run + draw, + run, + run', + Output, + (.>), + io, ) where +import Control.Monad.IO.Class import FWGL.Audio import FWGL.Backend import FWGL.Input @@ -33,16 +40,35 @@ import FRP.Yampa -- | The general output. -data Output = Output [Layer] Audio -- StateT ... IO +newtype Output = Output { drawOutput :: Draw () } +-- | Compose two 'Output' effects. +(.>) :: Output -> Output -> Output +Output a .> Output b = Output $ a >> b + +-- | Draw some layers. +draw :: BackendIO => [Layer] -> Output +draw layers = Output $ mapM_ drawLayer layers + +-- | Perform an IO action. +io :: IO () -> Output +io = Output . liftIO + -- | Run a FWGL program. run :: BackendIO - => SF Input Output -- ^ Main signal + => SF (Input ()) Output -- ^ Main signal -> IO () -run sigf = setup initState loop sigf +run = run' $ return () + +-- | Run a FWGL program, using custom inputs. +run' :: BackendIO + => IO inp -- ^ An IO effect generating the custom inputs. + -> SF (Input inp) Output + -> IO () +run' customInput sigf = setup initState loop customInput sigf where initState w h = evalGL $ drawInit w h - loop (Output scenes _) ctx drawState = - flip evalGL ctx . flip execDraw drawState $ - do drawBegin - mapM_ drawLayer scenes - drawEnd + loop (Output act) ctx drawState = + flip evalGL ctx . flip execDraw drawState $ do + drawBegin + act + drawEnd diff --git a/FWGL/Backend/IO.hs b/FWGL/Backend/IO.hs --- a/FWGL/Backend/IO.hs +++ b/FWGL/Backend/IO.hs @@ -12,5 +12,6 @@ setup :: (Int -> Int -> Ctx -> IO state) -> (out -> Ctx -> state -> IO state) - -> SF Input out + -> IO inp + -> SF (Input inp) out -> IO () diff --git a/FWGL/Graphics/Custom.hs b/FWGL/Graphics/Custom.hs --- a/FWGL/Graphics/Custom.hs +++ b/FWGL/Graphics/Custom.hs @@ -2,29 +2,36 @@ TypeFamilies, FlexibleContexts #-} module FWGL.Graphics.Custom ( - module FWGL.Vector, - Layer, Object, - AttrList(..), - Geometry, - Texture, - Color(..), (~~), - program, + unsafeJoin, nothing, static, + + Program, + program, global, globalDraw, globalTexture, globalTexSize, + + Layer, layer, subLayer, - unsafeJoin, + + Geometry, + AttrList(..), mkGeometry, + + Texture, mkTexture, textureURL, textureFile, - colorTex + + Color(..), + colorTex, + + module FWGL.Vector ) where import Control.Applicative @@ -50,7 +57,7 @@ static :: Geometry i -> Object '[] i static = ObjectMesh . StaticGeom --- | Sets a global (uniform) of an object. +-- | Sets a global variable (uniform) of an object. global :: (Typeable g, UniformCPU c g) => g -> c -> Object gs is -> Object (g ': gs) is global g c = globalDraw g $ return c diff --git a/FWGL/Graphics/D2.hs b/FWGL/Graphics/D2.hs --- a/FWGL/Graphics/D2.hs +++ b/FWGL/Graphics/D2.hs @@ -38,7 +38,7 @@ layer, layerPrg, program, - -- * Sublayers + -- ** Sublayers C.subLayer, -- * Custom 2D objects Object, diff --git a/FWGL/Graphics/D3.hs b/FWGL/Graphics/D3.hs --- a/FWGL/Graphics/D3.hs +++ b/FWGL/Graphics/D3.hs @@ -37,7 +37,7 @@ Program, layer, layerPrg, - program, + program, -- TODO: wrong! -- ** Sublayers C.subLayer, -- * Custom 3D objects diff --git a/FWGL/Graphics/Types.hs b/FWGL/Graphics/Types.hs --- a/FWGL/Graphics/Types.hs +++ b/FWGL/Graphics/Types.hs @@ -10,7 +10,6 @@ LoadedTexture(..), Geometry(..), Mesh(..), - Light(..), Object(..), Layer(..) ) where @@ -31,6 +30,7 @@ newtype UniformLocation = UniformLocation GL.UniformLocation +-- | The state of the 'Draw' monad. data DrawState = DrawState { program :: Maybe (Program '[] '[]), loadedProgram :: Maybe LoadedProgram, @@ -40,6 +40,7 @@ textureImages :: ResMap TextureImage LoadedTexture } +-- | A monad that represents OpenGL actions with some state ('DrawState'). newtype Draw a = Draw { unDraw :: StateT DrawState GL a } deriving (Functor, Applicative, Monad, MonadIO) @@ -59,9 +60,14 @@ StaticGeom :: Geometry is -> Mesh is DynamicGeom :: Geometry is -> Geometry is -> Mesh is -data Light - --- | An object is a set of geometries associated with some uniforms. +-- | An object is a set of geometries associated with some uniforms. For +-- example, if you want to draw a rotating cube, its vertices, normals, etc. +-- would be the 'Geometry', the combination of the geometry and the value of the +-- model matrix would be the 'Object', and the combination of the object with +-- a 'Program' would be the 'Layer'. In fact, 'Object's are just descriptions +-- of the actions to perform to draw something. Instead, the Element types in +-- "FWGL.Graphics.D2" and "FWGL.Graphics.D3" represent managed (high level) objects, +-- and they are ultimately converted to them. data Object (gs :: [*]) (is :: [*]) where ObjectEmpty :: Object gs is ObjectMesh :: Mesh is -> Object gs is @@ -69,16 +75,8 @@ -> Object gs is -> Object gs' is ObjectAppend :: Object gs is -> Object gs' is' -> Object gs'' is'' -{- --- | An 'Element' is anything that can be converted to an 'Object'. -class Element o gs is | o -> gs is where - object :: o -> Object gs is - -instance Element (Object gs is) gs is where - object = id --} - --- | An object associated with a program. +-- | An object associated with a program. It can also be a layer included in +-- another. data Layer = forall oi pi og pg. (Subset oi pi, Subset og pg) => Layer (Program pg pi) (Object og oi) | SubLayer Int Int Layer (Texture -> [Layer]) diff --git a/FWGL/Input.hs b/FWGL/Input.hs --- a/FWGL/Input.hs +++ b/FWGL/Input.hs @@ -12,7 +12,8 @@ click, pointer, resize, - size + size, + custom ) where import Data.Maybe @@ -34,54 +35,59 @@ } -- | The general input. -data Input = Input { - inputEvents :: H.HashMap InputEvent [EventData] +data Input a = Input { + inputEvents :: H.HashMap InputEvent [EventData], + inputCustom :: a } instance Hashable InputEvent where hashWithSalt salt = hashWithSalt salt . fromEnum -- | Keyboard release. -keyUp :: Key -> SF Input (Event ()) +keyUp :: Key -> SF (Input a) (Event ()) keyUp k = evEdge KeyUp $ isKey k -- | Keyboard press. -keyDown :: Key -> SF Input (Event ()) +keyDown :: Key -> SF (Input a) (Event ()) keyDown k = evEdge KeyDown $ isKey k -- | Keyboard down. -key :: Key -> SF Input (Event ()) +key :: Key -> SF (Input a) (Event ()) key k = sscan upDown NoEvent <<< keyUp k &&& keyDown k -- | Mouse press. -mouseDown :: MouseButton -> SF Input (Event (Int, Int)) +mouseDown :: MouseButton -> SF (Input a) (Event (Int, Int)) mouseDown b = evPointer MouseDown $ \d -> dataButton d == Just b -- | Mouse release. -mouseUp :: MouseButton -> SF Input (Event (Int, Int)) +mouseUp :: MouseButton -> SF (Input a) (Event (Int, Int)) mouseUp b = evPointer MouseUp $ \d -> dataButton d == Just b -- | Mouse down. -mouse :: MouseButton -> SF Input (Event (Int, Int)) +mouse :: MouseButton -> SF (Input a) (Event (Int, Int)) mouse b = sscan upDown NoEvent <<< mouseUp b &&& mouseDown b -- | Left click. -click :: SF Input (Event (Int, Int)) +click :: SF (Input a) (Event (Int, Int)) click = mouseDown MouseLeft -- | Pointer location in pixels. -pointer :: SF Input (Int, Int) +pointer :: SF (Input a) (Int, Int) pointer = evPointer MouseMove (const True) >>> hold (0, 0) -- | Window/framebuffer/canvas/etc. resize. -resize :: SF Input (Event (Int, Int)) +resize :: SF (Input a) (Event (Int, Int)) resize = evSearch Resize (isJust . dataFramebufferSize) >>^ fmap (fromJust . dataFramebufferSize) -- | Window/framebuffer/canvas size. -size :: SF Input (Int, Int) +size :: SF (Input a) (Int, Int) size = resize >>> hold (0, 0) +-- | Custom input. +custom :: SF (Input a) a +custom = arr inputCustom + {- keyDownLimited :: KeyCode a => Double -> a -> SF Input (Event ()) keyLimited :: KeyCode a => Double -> a -> SF Input (Event ()) -} @@ -96,15 +102,16 @@ Just k' -> k == k' Nothing -> False -evSearch :: InputEvent -> (EventData -> Bool) -> SF Input (Event EventData) +evSearch :: InputEvent -> (EventData -> Bool) -> SF (Input a) (Event EventData) evSearch ev bP = arr $ \ inp -> case H.lookup ev $ inputEvents inp of Just bs -> eventHead $ filter bP bs Nothing -> NoEvent -evEdge :: InputEvent -> (EventData -> Bool) -> SF Input (Event ()) +evEdge :: InputEvent -> (EventData -> Bool) -> SF (Input a) (Event ()) evEdge ev bP = evSearch ev bP >>> arr isEvent >>> edge -evPointer :: InputEvent -> (EventData -> Bool) -> SF Input (Event (Int, Int)) +evPointer :: InputEvent -> (EventData -> Bool) + -> SF (Input a) (Event (Int, Int)) evPointer ev bP = evSearch ev bP >>> arr (\ e -> case e of Event ed -> case dataPointer ed of diff --git a/FWGL/Shader.hs b/FWGL/Shader.hs --- a/FWGL/Shader.hs +++ b/FWGL/Shader.hs @@ -1,5 +1,49 @@ {-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-} +{-| +An example of shader variable: + +@ + newtype Transform2 = Transform2 M3 + deriving (Typeable,-- This have a name in the shader. + ShaderType, -- This is a type in the GPU (3x3 matrix). + UniformCPU CM3) -- This can be used as an uniform + and you can set it using a CPU + 3x3 matrix + (FWGL.Vector.'FWGL.Vector.M3'). +@ + +An example of vertex shader: + +@ + vertexShader :: VertexShader + -- The types of the uniforms: + '[Transform2, View2, Depth] + -- The types of the attributes: + '[Position2, UV] + -- The types of the varying (outputs), excluding 'VertexShaderOutput'. + '[UV] + vertexShader + -- Set of uniforms: + (Transform2 trans :- View2 view :- Depth z :- N) + -- Set of attributes: + (Position2 (V2 x y) :- uv@(UV _) :- N) = + -- Matrix and vector multiplication: + let V3 x' y' _ = view * trans * V3 x y 1 + -- Set of outputs: + in Vertex (V4 x' y' z 1) -- Vertex position. + :- uv :- N +@ + +Required extensions: + +@ +\{\-# LANGUAGE DataKinds, RebindableSyntax, DeriveDataTypeable, + GeneralizedNewtypeDeriving, GADTs #\-\} +@ + +-} + module FWGL.Shader ( Shader, VertexShader, @@ -75,11 +119,26 @@ import Prelude ((.), id, const, flip, ($)) import qualified Prelude as CPU +-- | Floats in the CPU. type CFloat = CPU.Float + +-- | Samplers in the CPU. type CSampler2D = CPU.ActiveTexture + +-- | 2D vectors in the CPU. type CV2 = CPU.V2 + +-- | 3D vectors in the CPU. type CV3 = CPU.V3 + +-- | 4D vectors in the CPU. type CV4 = CPU.V4 + +-- | 2x2 matrices in the CPU. type CM2 = CPU.M2 + +-- | 3x3 matrices in the CPU. type CM3 = CPU.M3 + +-- | 4x4 matrices in the CPU. type CM4 = CPU.M4 diff --git a/FWGL/Shader/CPU.hs b/FWGL/Shader/CPU.hs --- a/FWGL/Shader/CPU.hs +++ b/FWGL/Shader/CPU.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies #-} -- FWGL.Shader.Variables? (+ loadUniform, loadAttribute, inputName, etc.) -module FWGL.Shader.CPU where +module FWGL.Shader.CPU (UniformCPU(..), AttributeCPU(..)) where import Data.Word (Word) import Data.Typeable @@ -10,9 +10,11 @@ import qualified FWGL.Vector as CPU import Prelude as CPU +-- | CPU types convertible to GPU types (as uniforms). class Typeable g => UniformCPU c g | g -> c where setUniform :: UniformLocation -> g -> c -> GL () +-- | CPU types convertible to GPU types (as attributes). class Typeable g => AttributeCPU c g | g -> c where encodeAttribute :: g -> [c] -> GL Array setAttribute :: g -> GLUInt -> GL () diff --git a/FWGL/Shader/Language.hs b/FWGL/Shader/Language.hs --- a/FWGL/Shader/Language.hs +++ b/FWGL/Shader/Language.hs @@ -16,8 +16,10 @@ fromRational, fromInteger, negate, + Mul, (*), (/), + Sum, (+), (-), (^), @@ -43,15 +45,32 @@ | Apply String [Expr] | X Expr | Y Expr | Z Expr | W Expr | Literal String deriving (Prelude.Eq) +-- | A GPU boolean. newtype Bool = Bool Expr deriving Typeable + +-- | A GPU float. newtype Float = Float Expr deriving Typeable + +-- | A GPU sampler (sampler2D in GLSL). newtype Sampler2D = Sampler2D Expr deriving Typeable --- | NB: These are different types from 'FWGL.Vector.V2', 'FWGL.Vector.V3', etc. + +-- | A GPU 2D vector. +-- NB: This is a different type from FWGL.Vector.'FWGL.Vector.V2'. data V2 = V2 Float Float deriving (Typeable) + +-- | A GPU 3D vector. data V3 = V3 Float Float Float deriving (Typeable) + +-- | A GPU 4D vector. data V4 = V4 Float Float Float Float deriving (Typeable) + +-- | A GPU 2x2 matrix. data M2 = M2 V2 V2 deriving (Typeable) + +-- | A GPU 3x3 matrix. data M3 = M3 V3 V3 V3 deriving (Typeable) + +-- | A GPU 4x4 matrix. data M4 = M4 V4 V4 V4 V4 deriving (Typeable) infix 4 =! @@ -62,6 +81,7 @@ (&&!) :: Prelude.Bool -> Prelude.Bool -> Prelude.Bool (&&!) = (Prelude.&&) +-- | A type in the GPU. class ShaderType t where toExpr :: t -> Expr @@ -238,6 +258,7 @@ instance Matrix M3 instance Matrix M4 +-- | Types that can be multiplied. class Mul a b c | a b -> c instance Mul Float Float Float instance Mul V2 V2 V2 @@ -273,6 +294,7 @@ (/) :: (Mul a b c, ShaderType a, ShaderType b, ShaderType c) => a -> b -> c x / y = fromExpr $ Op2 "/" (toExpr x) (toExpr y) +-- | Types that can be added. class Sum a instance Sum Float instance Sum V2 diff --git a/FWGL/Shader/Shader.hs b/FWGL/Shader/Shader.hs --- a/FWGL/Shader/Shader.hs +++ b/FWGL/Shader/Shader.hs @@ -24,14 +24,18 @@ infixr 4 :- +-- | An heterogeneous set of 'ShaderType's and 'Typeable's. data STList :: [*] -> * where N :: STList '[] (:-) :: (ShaderType a, Typeable a, IsMember a xs ~ False) => a -> STList xs -> STList (a ': xs) +-- | The condition for a valid 'Shader'. type Valid gs is os = ( StaticList gs, StaticList is, StaticList os , StaticSTList gs, StaticSTList is, StaticSTList os) +-- | A function from a (heterogeneous) set of uniforms and a set of inputs +-- (attributes or varyings) to a set of outputs (varyings). type Shader gs is os = STList gs -> STList is -> STList os stFold :: (forall x. (Typeable x, ShaderType x) => acc -> x -> acc) diff --git a/FWGL/Shader/Stages.hs b/FWGL/Shader/Stages.hs --- a/FWGL/Shader/Stages.hs +++ b/FWGL/Shader/Stages.hs @@ -16,10 +16,17 @@ import FWGL.Shader.Language import FWGL.Shader.Shader +-- | A 'Shader' with a 'VertexShaderOutput' output. type VertexShader g i o = Shader g i (VertexShaderOutput ': o) + +-- | A 'Shader' with only a 'FragmentShaderOutput' output. type FragmentShader g i = Shader g i (FragmentShaderOutput ': '[]) +-- | The condition for a valid 'VertexShader'. type ValidVertex g i o = (Valid g i o, IsMember VertexShaderOutput o ~ False) +-- | The position of the vertex. newtype VertexShaderOutput = Vertex V4 deriving (Typeable, ShaderType) + +-- | The RGBA color of the fragment (1.0 = #FF). newtype FragmentShaderOutput = Fragment V4 deriving (Typeable, ShaderType) diff --git a/FWGL/Utils.hs b/FWGL/Utils.hs --- a/FWGL/Utils.hs +++ b/FWGL/Utils.hs @@ -11,16 +11,16 @@ -- | Generate a view matrix that transforms the pixel coordinates in OpenGL -- coordinates. -screenScale :: SF Input M3 -screenScale = size >>^ \(x, y) -> scaleMat3 (V2 (1 / fromIntegral x) - (1 / fromIntegral y)) +screenScale :: SF (Input a) M3 +screenScale = size >>^ \(x, y) -> scaleMat3 (V2 (2 / fromIntegral x) + (2 / fromIntegral y)) -- | Generate a perspective view matrix using the aspect ratio of the -- framebuffer. perspective4 :: Float -- ^ Far -> Float -- ^ Near -> Float -- ^ FOV - -> SF Input M4 + -> SF (Input a) M4 perspective4 f n fov = size >>^ \(w, h) -> perspectiveMat4 f n fov (fromIntegral w / fromIntegral h) @@ -29,7 +29,7 @@ perspectiveView :: Float -- ^ Far -> Float -- ^ Near -> Float -- ^ FOV - -> SF (Input, M4) M4 + -> SF (Input a, M4) M4 perspectiveView far near fov = perspective4 far near fov *** identity >>^ \(perspMat, viewMat) -> mul4 viewMat perspMat diff --git a/fwgl.cabal b/fwgl.cabal --- a/fwgl.cabal +++ b/fwgl.cabal @@ -1,12 +1,12 @@ name: fwgl -version: 0.1.1.0 +version: 0.1.2.0 synopsis: FRP 2D/3D game engine description: FRP 2D/3D game engine (work in progress). -homepage: https://github.com/ZioCrocifisso/FWGL +homepage: https://github.com/ziocroc/FWGL stability: experimental license: BSD3 license-file: LICENSE -author: Luca "ZioCrocifisso" Prezzavento +author: Luca "ziocroc" Prezzavento maintainer: ziocroc@gmail.com category: Game, Game Engine, Javascript build-type: Simple