diff --git a/FWGL.hs b/FWGL.hs new file mode 100644 --- /dev/null +++ b/FWGL.hs @@ -0,0 +1,47 @@ +{-| + The main module. You should also import a backend: + + * "FWGL.Backend.JavaScript": GHCJS/WebGL backend + * FWGL.Backend.GLFW.GLES20: GLFW/OpenGL ES 2.0 backend (WIP) + * FWGL.Backend.GLFW.GL32: GLFW/OpenGL 3.2 backend (WIP) + + + And a graphics system: + + * "FWGL.Graphics.D2": 2D graphics + * FWGL.Graphics.D3: 3D graphics (WIP) + * "FWGL.Graphics.Custom": advanced custom graphics + + "FWGL.Shader" contains the EDSL to make custom shaders. +-} +module FWGL ( + module FWGL.Audio, + module FWGL.Input, + module FWGL.Utils, + module FRP.Yampa, + Output(..), + run +) where + +import FWGL.Audio +import FWGL.Backend +import FWGL.Input +import FWGL.Internal.GL (evalGL) +import FWGL.Graphics.Draw +import FWGL.Graphics.Types +import FWGL.Utils +import FRP.Yampa + +-- | The general output. +data Output = Output [Layer] Audio -- StateT ... IO + +-- | Run a FWGL program. +run :: BackendIO + => SF Input Output -- ^ Main signal + -> IO () +run sigf = setup initState loop 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 diff --git a/FWGL/Audio.hs b/FWGL/Audio.hs new file mode 100644 --- /dev/null +++ b/FWGL/Audio.hs @@ -0,0 +1,4 @@ +module FWGL.Audio where + +-- | It doesn't do anything (for now). +data Audio = Audio diff --git a/FWGL/Backend.hs b/FWGL/Backend.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend.hs @@ -0,0 +1,7 @@ +module FWGL.Backend ( + module FWGL.Backend.GLES, + module FWGL.Backend.IO +) where + +import FWGL.Backend.GLES +import FWGL.Backend.IO diff --git a/FWGL/Backend/GLES.hs b/FWGL/Backend/GLES.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/GLES.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE NullaryTypeClasses, TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} + +module FWGL.Backend.GLES where + +import Data.Word +import FWGL.Graphics.Color +import FWGL.Vector + +class ( Integral GLEnum + , Integral GLUInt + , Integral GLInt + , Integral GLSize + , Num GLEnum + , Num GLUInt + , Num GLInt + , Num GLPtrDiff + , Num GLSize) => GLES where + type Ctx + type GLEnum + type GLUInt + type GLInt + type GLPtr + type GLPtrDiff + type GLSize + type GLString + type GLBool + type Buffer + type UniformLocation + type Texture + type Shader + type Program + type FrameBuffer + type RenderBuffer + -- type ActiveInfo + -- type ShaderPrecisionFormat + type Array + type Float32Array + type Int32Array + type Image + + true :: GLBool + false :: GLBool + nullGLPtr :: GLPtr + -- arrayGLPtr :: Array -> (GLPtr -> IO a) -> IO a + toGLString :: String -> GLString + noBuffer :: Buffer + noTexture :: Texture + encodeM2 :: M2 -> IO Float32Array + encodeM3 :: M3 -> IO Float32Array + encodeM4 :: M4 -> IO Float32Array + encodeFloats :: [Float] -> IO Array + encodeV2s :: [V2] -> IO Array + encodeV3s :: [V3] -> IO Array + encodeV4s :: [V4] -> IO Array + encodeUShorts :: [Word16] -> IO Array + encodeColors :: [Color] -> IO Array + + glActiveTexture :: Ctx -> GLEnum -> IO () + glAttachShader :: Ctx -> Program -> Shader -> IO () + glBindAttribLocation :: Ctx -> Program -> GLUInt -> GLString -> IO () + glBindBuffer :: Ctx -> GLEnum -> Buffer -> IO () + glBindFramebuffer :: Ctx -> GLEnum -> FrameBuffer -> IO () + glBindRenderbuffer :: Ctx -> GLEnum -> RenderBuffer -> IO () + glBindTexture :: Ctx -> GLEnum -> Texture -> IO () + glBlendColor :: Ctx -> Float -> Float -> Float -> Float -> IO () + glBlendEquation :: Ctx -> GLEnum -> IO () + glBlendEquationSeparate :: Ctx -> GLEnum -> GLEnum -> IO () + glBlendFunc :: Ctx -> GLEnum -> GLEnum -> IO () + glBlendFuncSeparate :: Ctx -> GLEnum -> GLEnum -> GLEnum -> GLEnum -> IO () + glBufferData :: Ctx -> GLEnum -> Array -> GLEnum -> IO () + glBufferSubData :: Ctx -> GLEnum -> GLPtrDiff -> Array -> IO () + glCheckFramebufferStatus :: Ctx -> GLEnum -> IO GLEnum + glClear :: Ctx -> GLEnum -> IO () + glClearColor :: Ctx -> Float -> Float -> Float -> Float -> IO () + glClearDepth :: Ctx -> Float -> IO () + glClearStencil :: Ctx -> GLInt -> IO () + glColorMask :: Ctx -> GLBool -> GLBool -> GLBool -> GLBool -> IO () + glCompileShader :: Ctx -> Shader -> IO () + glCompressedTexImage2D :: Ctx -> GLEnum -> GLInt -> GLEnum -> GLSize -> GLSize -> GLInt -> Array -> IO () + glCompressedTexSubImage2D :: Ctx -> GLEnum -> GLInt -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> Array -> IO () + glCopyTexImage2D :: Ctx -> GLEnum -> GLInt -> GLEnum -> GLInt -> GLInt -> GLSize -> GLSize -> GLInt -> IO () + glCopyTexSubImage2D :: Ctx -> GLEnum -> GLInt -> GLInt -> GLInt -> GLInt -> GLInt -> GLSize -> GLSize -> IO () + glCreateBuffer :: Ctx -> IO Buffer + glCreateFramebuffer :: Ctx -> IO FrameBuffer + glCreateProgram :: Ctx -> IO Program + glCreateRenderbuffer :: Ctx -> IO RenderBuffer + glCreateShader :: Ctx -> GLEnum -> IO Shader + glCreateTexture :: Ctx -> IO Texture + glCullFace :: Ctx -> GLEnum -> IO () + glDeleteBuffer :: Ctx -> Buffer -> IO () + glDeleteFramebuffer :: Ctx -> FrameBuffer -> IO () + glDeleteProgram :: Ctx -> Program -> IO () + glDeleteRenderbuffer :: Ctx -> RenderBuffer -> IO () + glDeleteShader :: Ctx -> Shader -> IO () + glDeleteTexture :: Ctx -> Texture -> IO () + glDepthFunc :: Ctx -> GLEnum -> IO () + glDepthMask :: Ctx -> GLBool -> IO () + glDepthRange :: Ctx -> Float -> Float -> IO () + glDetachShader :: Ctx -> Program -> Shader -> IO () + glDisable :: Ctx -> GLEnum -> IO () + glDisableVertexAttribArray :: Ctx -> GLUInt -> IO () + glDrawArrays :: Ctx -> GLEnum -> GLInt -> GLSize -> IO () + glDrawElements :: Ctx -> GLEnum -> GLSize -> GLEnum -> GLPtr-> IO () + glEnable :: Ctx -> GLEnum -> IO () + glEnableVertexAttribArray :: Ctx -> GLUInt -> IO () + glFinish :: Ctx -> IO () + glFlush :: Ctx -> IO () + glFramebufferRenderbuffer :: Ctx -> GLEnum -> GLEnum -> GLEnum -> RenderBuffer -> IO () + glFramebufferTexture2D :: Ctx -> GLEnum -> GLEnum -> GLEnum -> Texture -> GLInt -> IO () + glFrontFace :: Ctx -> GLEnum -> IO () + glGenerateMipmap :: Ctx -> GLEnum -> IO () + -- glGetActiveAttrib :: Ctx -> Program -> GLEnum -> IO ActiveInfo + -- glGetActiveUniform :: Ctx -> Program -> GLEnum -> IO ActiveInfo + glGetAttribLocation :: Ctx -> Program -> GLString -> IO GLInt + -- glGetBufferParameter :: Ctx -> Word -> Word -> IO (JSRef a) + -- glGetParameter :: Ctx -> Word -> IO (JSRef a) + glGetError :: Ctx -> IO GLEnum + -- glGetFramebufferAttachmentParameter :: Ctx -> GLEnum -> GLEnum -> IO Word + glGetProgramInfoLog :: Ctx -> Program -> IO GLString + -- glGetRenderbufferParameter :: Ctx -> Word -> Word -> IO (JSRef a) + -- glGetShaderParameter :: Ctx -> Shader -> Word -> IO (JSRef a) + -- glGetShaderPrecisionFormat :: Ctx -> GLEnum -> GLEnum -> IO ShaderPrecisionFormat + glGetShaderInfoLog :: Ctx -> Shader -> IO GLString + glGetShaderSource :: Ctx -> Shader -> IO GLString + -- glGetTexParameter :: Ctx -> Word -> Word -> IO (JSRef a) + -- glGetUniform :: Ctx -> Program -> UniformLocation -> IO (JSRef a) + glGetUniformLocation :: Ctx -> Program -> GLString -> IO UniformLocation + -- glGetVertexAttrib :: Ctx -> Word -> Word -> IO (JSRef a) + -- glGetVertexAttribOffset :: Ctx -> Word -> GLEnum -> IO Word + glHint :: Ctx -> GLEnum -> GLEnum -> IO () + glIsBuffer :: Ctx -> Buffer -> IO GLBool + glIsEnabled :: Ctx -> GLEnum -> IO GLBool + glIsFramebuffer :: Ctx -> FrameBuffer -> IO GLBool + glIsProgram :: Ctx -> Program -> IO GLBool + glIsRenderbuffer :: Ctx -> RenderBuffer -> IO GLBool + glIsShader :: Ctx -> Shader -> IO GLBool + glIsTexture :: Ctx -> Texture -> IO GLBool + glLineWidth :: Ctx -> Float -> IO () + glLinkProgram :: Ctx -> Program -> IO () + glPixelStorei :: Ctx -> GLEnum -> GLInt -> IO () + glPolygonOffset :: Ctx -> Float -> Float -> IO () + glReadPixels :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> Array -> IO () + glRenderbufferStorage :: Ctx -> GLEnum -> GLEnum -> GLSize -> GLSize -> IO () + glSampleCoverage :: Ctx -> Float -> GLBool -> IO () + glScissor :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> IO () + glShaderSource :: Ctx -> Shader -> GLString -> IO () + glStencilFunc :: Ctx -> GLEnum -> GLInt -> GLUInt -> IO () + glStencilFuncSeparate :: Ctx -> GLEnum -> GLEnum -> GLInt -> GLUInt -> IO () + glStencilMask :: Ctx -> GLUInt -> IO () + glStencilMaskSeparate :: Ctx -> GLEnum -> GLUInt -> IO () + glStencilOp :: Ctx -> GLEnum -> GLEnum -> GLEnum -> IO () + glStencilOpSeparate :: Ctx -> GLEnum -> GLEnum -> GLEnum -> GLEnum -> IO () + glTexImage2DBuffer :: Ctx -> GLEnum -> GLInt -> GLInt -> GLSize -> GLSize -> GLInt -> GLEnum -> GLEnum -> Array -> IO () + glTexImage2DImage :: Ctx -> GLEnum -> GLInt -> GLInt -> GLEnum -> GLEnum -> Image -> IO () + glTexParameterf :: Ctx -> GLEnum -> GLEnum -> Float -> IO () + glTexParameteri :: Ctx -> GLEnum -> GLEnum -> GLInt -> IO () + glTexSubImage2D :: Ctx -> GLEnum -> GLInt -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> Array -> IO () + glUniform1f :: Ctx -> UniformLocation -> Float -> IO () + glUniform1fv :: Ctx -> UniformLocation -> Float32Array -> IO () + glUniform1i :: Ctx -> UniformLocation -> GLInt -> IO () + glUniform1iv :: Ctx -> UniformLocation -> Int32Array -> IO () + glUniform2f :: Ctx -> UniformLocation -> Float -> Float -> IO () + glUniform2fv :: Ctx -> UniformLocation -> Float32Array -> IO () + glUniform2i :: Ctx -> UniformLocation -> GLInt -> GLInt -> IO () + glUniform2iv :: Ctx -> UniformLocation -> Int32Array -> IO () + glUniform3f :: Ctx -> UniformLocation -> Float -> Float -> Float -> IO () + glUniform3fv :: Ctx -> UniformLocation -> Float32Array -> IO () + glUniform3i :: Ctx -> UniformLocation -> GLInt -> GLInt -> GLInt -> IO () + glUniform3iv :: Ctx -> UniformLocation -> Int32Array -> IO () + glUniform4f :: Ctx -> UniformLocation -> Float -> Float -> Float -> Float -> IO () + glUniform4fv :: Ctx -> UniformLocation -> Float32Array -> IO () + glUniform4i :: Ctx -> UniformLocation -> GLInt -> GLInt -> GLInt -> GLInt -> IO () + glUniform4iv :: Ctx -> UniformLocation -> Int32Array -> IO () + glUniformMatrix2fv :: Ctx -> UniformLocation -> GLBool -> Float32Array -> IO () + glUniformMatrix3fv :: Ctx -> UniformLocation -> GLBool -> Float32Array -> IO () + glUniformMatrix4fv :: Ctx -> UniformLocation -> GLBool -> Float32Array -> IO () + glUseProgram :: Ctx -> Program -> IO () + glValidateProgram :: Ctx -> Program -> IO () + glVertexAttrib1f :: Ctx -> GLUInt -> Float -> IO () + glVertexAttrib1fv :: Ctx -> GLUInt -> Float32Array -> IO () + glVertexAttrib2f :: Ctx -> GLUInt -> Float -> Float -> IO () + glVertexAttrib2fv :: Ctx -> GLUInt -> Float32Array -> IO () + glVertexAttrib3f :: Ctx -> GLUInt -> Float -> Float -> Float -> IO () + glVertexAttrib3fv :: Ctx -> GLUInt -> Float32Array -> IO () + glVertexAttrib4f :: Ctx -> GLUInt -> Float -> Float -> Float -> Float -> IO () + glVertexAttrib4fv :: Ctx -> GLUInt -> Float32Array -> IO () + glVertexAttribPointer :: Ctx -> GLUInt -> GLInt -> GLEnum -> GLBool -> GLSize -> GLPtr -> IO () + glViewport :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> IO () + + gl_DEPTH_BUFFER_BIT :: GLEnum + gl_STENCIL_BUFFER_BIT :: GLEnum + gl_COLOR_BUFFER_BIT :: GLEnum + gl_POINTS :: GLEnum + gl_LINES :: GLEnum + gl_LINE_LOOP :: GLEnum + gl_LINE_STRIP :: GLEnum + gl_TRIANGLES :: GLEnum + gl_TRIANGLE_STRIP :: GLEnum + gl_TRIANGLE_FAN :: GLEnum + gl_ZERO :: GLEnum + gl_ONE :: GLEnum + gl_SRC_COLOR :: GLEnum + gl_ONE_MINUS_SRC_COLOR :: GLEnum + gl_SRC_ALPHA :: GLEnum + gl_ONE_MINUS_SRC_ALPHA :: GLEnum + gl_DST_ALPHA :: GLEnum + gl_ONE_MINUS_DST_ALPHA :: GLEnum + gl_DST_COLOR :: GLEnum + gl_ONE_MINUS_DST_COLOR :: GLEnum + gl_SRC_ALPHA_SATURATE :: GLEnum + gl_FUNC_ADD :: GLEnum + gl_BLEND_EQUATION :: GLEnum + gl_BLEND_EQUATION_RGB :: GLEnum + gl_BLEND_EQUATION_ALPHA :: GLEnum + gl_FUNC_SUBTRACT :: GLEnum + gl_FUNC_REVERSE_SUBTRACT :: GLEnum + gl_BLEND_DST_RGB :: GLEnum + gl_BLEND_SRC_RGB :: GLEnum + gl_BLEND_DST_ALPHA :: GLEnum + gl_BLEND_SRC_ALPHA :: GLEnum + gl_CONSTANT_COLOR :: GLEnum + gl_ONE_MINUS_CONSTANT_COLOR :: GLEnum + gl_CONSTANT_ALPHA :: GLEnum + gl_ONE_MINUS_CONSTANT_ALPHA :: GLEnum + gl_BLEND_COLOR :: GLEnum + gl_ARRAY_BUFFER :: GLEnum + gl_ELEMENT_ARRAY_BUFFER :: GLEnum + gl_ARRAY_BUFFER_BINDING :: GLEnum + gl_ELEMENT_ARRAY_BUFFER_BINDING :: GLEnum + gl_STREAM_DRAW :: GLEnum + gl_STATIC_DRAW :: GLEnum + gl_DYNAMIC_DRAW :: GLEnum + gl_BUFFER_SIZE :: GLEnum + gl_BUFFER_USAGE :: GLEnum + gl_CURRENT_VERTEX_ATTRIB :: GLEnum + gl_FRONT :: GLEnum + gl_BACK :: GLEnum + gl_FRONT_AND_BACK :: GLEnum + gl_CULL_FACE :: GLEnum + gl_BLEND :: GLEnum + gl_DITHER :: GLEnum + gl_STENCIL_TEST :: GLEnum + gl_DEPTH_TEST :: GLEnum + gl_SCISSOR_TEST :: GLEnum + gl_POLYGON_OFFSET_FILL :: GLEnum + gl_SAMPLE_ALPHA_TO_COVERAGE :: GLEnum + gl_SAMPLE_COVERAGE :: GLEnum + gl_NO_ERROR :: GLEnum + gl_INVALID_ENUM :: GLEnum + gl_INVALID_VALUE :: GLEnum + gl_INVALID_OPERATION :: GLEnum + gl_OUT_OF_MEMORY :: GLEnum + gl_CW :: GLEnum + gl_CCW :: GLEnum + gl_LINE_WIDTH :: GLEnum + gl_ALIASED_POINT_SIZE_RANGE :: GLEnum + gl_ALIASED_LINE_WIDTH_RANGE :: GLEnum + gl_CULL_FACE_MODE :: GLEnum + gl_FRONT_FACE :: GLEnum + gl_DEPTH_RANGE :: GLEnum + gl_DEPTH_WRITEMASK :: GLEnum + gl_DEPTH_CLEAR_VALUE :: GLEnum + gl_DEPTH_FUNC :: GLEnum + gl_STENCIL_CLEAR_VALUE :: GLEnum + gl_STENCIL_FUNC :: GLEnum + gl_STENCIL_FAIL :: GLEnum + gl_STENCIL_PASS_DEPTH_FAIL :: GLEnum + gl_STENCIL_PASS_DEPTH_PASS :: GLEnum + gl_STENCIL_REF :: GLEnum + gl_STENCIL_VALUE_MASK :: GLEnum + gl_STENCIL_WRITEMASK :: GLEnum + gl_STENCIL_BACK_FUNC :: GLEnum + gl_STENCIL_BACK_FAIL :: GLEnum + gl_STENCIL_BACK_PASS_DEPTH_FAIL :: GLEnum + gl_STENCIL_BACK_PASS_DEPTH_PASS :: GLEnum + gl_STENCIL_BACK_REF :: GLEnum + gl_STENCIL_BACK_VALUE_MASK :: GLEnum + gl_STENCIL_BACK_WRITEMASK :: GLEnum + gl_VIEWPORT :: GLEnum + gl_SCISSOR_BOX :: GLEnum + gl_COLOR_CLEAR_VALUE :: GLEnum + gl_COLOR_WRITEMASK :: GLEnum + gl_UNPACK_ALIGNMENT :: GLEnum + gl_PACK_ALIGNMENT :: GLEnum + gl_MAX_TEXTURE_SIZE :: GLEnum + gl_MAX_VIEWPORT_DIMS :: GLEnum + gl_SUBPIXEL_BITS :: GLEnum + gl_RED_BITS :: GLEnum + gl_GREEN_BITS :: GLEnum + gl_BLUE_BITS :: GLEnum + gl_ALPHA_BITS :: GLEnum + gl_DEPTH_BITS :: GLEnum + gl_STENCIL_BITS :: GLEnum + gl_POLYGON_OFFSET_UNITS :: GLEnum + gl_POLYGON_OFFSET_FACTOR :: GLEnum + gl_TEXTURE_BINDING_2D :: GLEnum + gl_SAMPLE_BUFFERS :: GLEnum + gl_SAMPLES :: GLEnum + gl_SAMPLE_COVERAGE_VALUE :: GLEnum + gl_SAMPLE_COVERAGE_INVERT :: GLEnum + gl_COMPRESSED_TEXTURE_FORMATS :: GLEnum + gl_DONT_CARE :: GLEnum + gl_FASTEST :: GLEnum + gl_NICEST :: GLEnum + gl_GENERATE_MIPMAP_HINT :: GLEnum + gl_BYTE :: GLEnum + gl_UNSIGNED_BYTE :: GLEnum + gl_SHORT :: GLEnum + gl_UNSIGNED_SHORT :: GLEnum + gl_INT :: GLEnum + gl_UNSIGNED_INT :: GLEnum + gl_FLOAT :: GLEnum + gl_DEPTH_COMPONENT :: GLEnum + gl_ALPHA :: GLEnum + gl_RGB :: GLEnum + gl_RGBA :: GLEnum + gl_LUMINANCE :: GLEnum + gl_LUMINANCE_ALPHA :: GLEnum + gl_UNSIGNED_SHORT_4_4_4_4 :: GLEnum + gl_UNSIGNED_SHORT_5_5_5_1 :: GLEnum + gl_UNSIGNED_SHORT_5_6_5 :: GLEnum + gl_FRAGMENT_SHADER :: GLEnum + gl_VERTEX_SHADER :: GLEnum + gl_MAX_VERTEX_ATTRIBS :: GLEnum + gl_MAX_VERTEX_UNIFORM_VECTORS :: GLEnum + gl_MAX_VARYING_VECTORS :: GLEnum + gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS :: GLEnum + gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS :: GLEnum + gl_MAX_TEXTURE_IMAGE_UNITS :: GLEnum + gl_MAX_FRAGMENT_UNIFORM_VECTORS :: GLEnum + gl_SHADER_TYPE :: GLEnum + gl_DELETE_STATUS :: GLEnum + gl_LINK_STATUS :: GLEnum + gl_VALIDATE_STATUS :: GLEnum + gl_ATTACHED_SHADERS :: GLEnum + gl_ACTIVE_UNIFORMS :: GLEnum + gl_ACTIVE_ATTRIBUTES :: GLEnum + gl_SHADING_LANGUAGE_VERSION :: GLEnum + gl_CURRENT_PROGRAM :: GLEnum + gl_NEVER :: GLEnum + gl_LESS :: GLEnum + gl_EQUAL :: GLEnum + gl_LEQUAL :: GLEnum + gl_GREATER :: GLEnum + gl_NOTEQUAL :: GLEnum + gl_GEQUAL :: GLEnum + gl_ALWAYS :: GLEnum + gl_KEEP :: GLEnum + gl_REPLACE :: GLEnum + gl_INCR :: GLEnum + gl_DECR :: GLEnum + gl_INVERT :: GLEnum + gl_INCR_WRAP :: GLEnum + gl_DECR_WRAP :: GLEnum + gl_VENDOR :: GLEnum + gl_RENDERER :: GLEnum + gl_VERSION :: GLEnum + gl_NEAREST :: GLEnum + gl_LINEAR :: GLEnum + gl_NEAREST_MIPMAP_NEAREST :: GLEnum + gl_LINEAR_MIPMAP_NEAREST :: GLEnum + gl_NEAREST_MIPMAP_LINEAR :: GLEnum + gl_LINEAR_MIPMAP_LINEAR :: GLEnum + gl_TEXTURE_MAG_FILTER :: GLEnum + gl_TEXTURE_MIN_FILTER :: GLEnum + gl_TEXTURE_WRAP_S :: GLEnum + gl_TEXTURE_WRAP_T :: GLEnum + gl_TEXTURE_2D :: GLEnum + gl_TEXTURE :: GLEnum + gl_TEXTURE_CUBE_MAP :: GLEnum + gl_TEXTURE_BINDING_CUBE_MAP :: GLEnum + gl_TEXTURE_CUBE_MAP_POSITIVE_X :: GLEnum + gl_TEXTURE_CUBE_MAP_NEGATIVE_X :: GLEnum + gl_TEXTURE_CUBE_MAP_POSITIVE_Y :: GLEnum + gl_TEXTURE_CUBE_MAP_NEGATIVE_Y :: GLEnum + gl_TEXTURE_CUBE_MAP_POSITIVE_Z :: GLEnum + gl_TEXTURE_CUBE_MAP_NEGATIVE_Z :: GLEnum + gl_MAX_CUBE_MAP_TEXTURE_SIZE :: GLEnum + gl_TEXTURE0 :: GLEnum + gl_TEXTURE1 :: GLEnum + gl_TEXTURE2 :: GLEnum + gl_TEXTURE3 :: GLEnum + gl_TEXTURE4 :: GLEnum + gl_TEXTURE5 :: GLEnum + gl_TEXTURE6 :: GLEnum + gl_TEXTURE7 :: GLEnum + gl_TEXTURE8 :: GLEnum + gl_TEXTURE9 :: GLEnum + gl_TEXTURE10 :: GLEnum + gl_TEXTURE11 :: GLEnum + gl_TEXTURE12 :: GLEnum + gl_TEXTURE13 :: GLEnum + gl_TEXTURE14 :: GLEnum + gl_TEXTURE15 :: GLEnum + gl_TEXTURE16 :: GLEnum + gl_TEXTURE17 :: GLEnum + gl_TEXTURE18 :: GLEnum + gl_TEXTURE19 :: GLEnum + gl_TEXTURE20 :: GLEnum + gl_TEXTURE21 :: GLEnum + gl_TEXTURE22 :: GLEnum + gl_TEXTURE23 :: GLEnum + gl_TEXTURE24 :: GLEnum + gl_TEXTURE25 :: GLEnum + gl_TEXTURE26 :: GLEnum + gl_TEXTURE27 :: GLEnum + gl_TEXTURE28 :: GLEnum + gl_TEXTURE29 :: GLEnum + gl_TEXTURE30 :: GLEnum + gl_TEXTURE31 :: GLEnum + gl_ACTIVE_TEXTURE :: GLEnum + gl_REPEAT :: GLEnum + gl_CLAMP_TO_EDGE :: GLEnum + gl_MIRRORED_REPEAT :: GLEnum + gl_FLOAT_VEC2 :: GLEnum + gl_FLOAT_VEC3 :: GLEnum + gl_FLOAT_VEC4 :: GLEnum + gl_INT_VEC2 :: GLEnum + gl_INT_VEC3 :: GLEnum + gl_INT_VEC4 :: GLEnum + gl_BOOL :: GLEnum + gl_BOOL_VEC2 :: GLEnum + gl_BOOL_VEC3 :: GLEnum + gl_BOOL_VEC4 :: GLEnum + gl_FLOAT_MAT2 :: GLEnum + gl_FLOAT_MAT3 :: GLEnum + gl_FLOAT_MAT4 :: GLEnum + gl_SAMPLER_2D :: GLEnum + gl_SAMPLER_CUBE :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_ENABLED :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_SIZE :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_STRIDE :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_TYPE :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_NORMALIZED :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_POINTER :: GLEnum + gl_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING :: GLEnum + gl_COMPILE_STATUS :: GLEnum + gl_LOW_FLOAT :: GLEnum + gl_MEDIUM_FLOAT :: GLEnum + gl_HIGH_FLOAT :: GLEnum + gl_LOW_INT :: GLEnum + gl_MEDIUM_INT :: GLEnum + gl_HIGH_INT :: GLEnum + gl_FRAMEBUFFER :: GLEnum + gl_RENDERBUFFER :: GLEnum + gl_RGBA4 :: GLEnum + gl_RGB5_A1 :: GLEnum + gl_RGB565 :: GLEnum + gl_DEPTH_COMPONENT16 :: GLEnum + gl_STENCIL_INDEX8 :: GLEnum + gl_RENDERBUFFER_WIDTH :: GLEnum + gl_RENDERBUFFER_HEIGHT :: GLEnum + gl_RENDERBUFFER_INTERNAL_FORMAT :: GLEnum + gl_RENDERBUFFER_RED_SIZE :: GLEnum + gl_RENDERBUFFER_GREEN_SIZE :: GLEnum + gl_RENDERBUFFER_BLUE_SIZE :: GLEnum + gl_RENDERBUFFER_ALPHA_SIZE :: GLEnum + gl_RENDERBUFFER_DEPTH_SIZE :: GLEnum + gl_RENDERBUFFER_STENCIL_SIZE :: GLEnum + gl_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE :: GLEnum + gl_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME :: GLEnum + gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL :: GLEnum + gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE :: GLEnum + gl_COLOR_ATTACHMENT0 :: GLEnum + gl_DEPTH_ATTACHMENT :: GLEnum + gl_STENCIL_ATTACHMENT :: GLEnum + gl_NONE :: GLEnum + gl_FRAMEBUFFER_COMPLETE :: GLEnum + gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT :: GLEnum + gl_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT :: GLEnum + gl_FRAMEBUFFER_INCOMPLETE_DIMENSIONS :: GLEnum + gl_FRAMEBUFFER_UNSUPPORTED :: GLEnum + gl_FRAMEBUFFER_BINDING :: GLEnum + gl_RENDERBUFFER_BINDING :: GLEnum + gl_MAX_RENDERBUFFER_SIZE :: GLEnum + gl_INVALID_FRAMEBUFFER_OPERATION :: GLEnum diff --git a/FWGL/Backend/IO.hs b/FWGL/Backend/IO.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/IO.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NullaryTypeClasses, TypeFamilies #-} + +module FWGL.Backend.IO where + +import FRP.Yampa +import FWGL.Backend.GLES +import FWGL.Input + +class GLES => BackendIO where + -- TODO: loadImage may fail + loadImage :: String -> ((Image, Int, Int) -> IO ()) -> IO () + + setup :: (Int -> Int -> Ctx -> IO state) + -> (out -> Ctx -> state -> IO state) + -> SF Input out + -> IO () diff --git a/FWGL/Backend/JavaScript.hs b/FWGL/Backend/JavaScript.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/JavaScript.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE NullaryTypeClasses, TypeFamilies, UndecidableInstances #-} + +{-| The GHCJS/WebGL backend. This just exports the instances for 'BackendIO' + and 'GLES'. -} +module FWGL.Backend.JavaScript () where + +import Control.Applicative +import Control.Concurrent +import qualified Data.HashMap.Strict as H +import Data.IORef +import Data.Word +import FRP.Yampa +import FWGL.Backend +import FWGL.Backend.JavaScript.Event +import qualified FWGL.Backend.JavaScript.WebGL as JS +import FWGL.Graphics.Color +import FWGL.Input +import FWGL.Vector +import GHCJS.Foreign +import GHCJS.Types +import GHCJS.Marshal + +foreign import javascript unsafe + "var img = new Image(); \ + \img.src = $1; \ + \img.onload = function() { return $2(img); }; " + loadImageRaw :: JSString -> JSFun (JSRef a -> IO ()) -> IO () + +foreign import javascript unsafe "document.querySelector($1)" + query :: JSString -> IO (JSRef a) + +foreign import javascript unsafe "$2.getAttribute($1)" + getAttributeRaw :: JSString -> JSRef a -> IO JSString + +getAttribute :: String -> JSRef a -> IO String +getAttribute attr e = fromJSString <$> getAttributeRaw (toJSString attr) e + +foreign import javascript unsafe "window.requestAnimationFrame($1)" + requestAnimationFrame :: JSFun (JSRef Double -> IO ()) -> IO () + +foreign import javascript unsafe "$1.focus()" focus :: JSRef a -> IO () + +instance BackendIO where + loadImage url f = asyncCallback1 NeverRetain callback + >>= loadImageRaw (toJSString url) + where callback img = + do (Just w) <- getProp "width" img >>= fromJSRef + (Just h) <- getProp "height" img >>= fromJSRef + f (img, w, h) + + setup initState draw sigf = + do element <- query $ toJSString "canvas" + eventSrc <- source handledEvents element + ctx <- JS.getCtx element + (Just w) <- getProp "clientWidth" element >>= fromJSRef + (Just h) <- getProp "clientHeight" element >>= fromJSRef + focus element -- ... no + drawStateRef <- initState w h ctx >>= newIORef + reactStateRef <- reactInit (return $ initInput w h) + (\ _ _ -> actuate ctx drawStateRef) + sigf + onFrame $ frame reactStateRef eventSrc Nothing + where frame rsf src last crf = + do events <- clear src + (Just cur) <- fromJSRef crf + let tm = case last of + Just l -> cur - l + Nothing -> 0 + react rsf (tm, Just $ Input events) + -- print tm -- debug + onFrame $ frame rsf src (Just cur) + + onFrame handler = asyncCallback1 NeverRetain handler + >>= requestAnimationFrame + + initInput w h = Input $ H.singleton Resize [ + EventData { + dataFramebufferSize = Just (w, h), + dataPointer = Nothing, + dataButton = Nothing, + dataKey = Nothing + }] + + actuate ctx ref out = readIORef ref >>= + draw out ctx >>= + -- execDraw (drawBegin >> drawScene s) >>= + writeIORef ref >> return False + handledEvents = [ MouseUp + , MouseDown + , MouseMove + , KeyUp + , KeyDown + , Resize ] + +instance GLES where + type Ctx = JS.Ctx + type GLEnum = Word + type GLUInt = Word + type GLInt = Int + type GLPtr = Word + type GLPtrDiff = Word + type GLSize = Int + type GLString = JSString + type GLBool = Bool + type Buffer = JS.Buffer + type UniformLocation = JS.UniformLocation + type Texture = JS.Texture + type Shader = JS.Shader + type Program = JS.Program + type FrameBuffer = JS.FrameBuffer + type RenderBuffer = JS.RenderBuffer + -- type ActiveInfo = JS.ActiveInfo + -- type ShaderPrecisionFormat = JS.ShaderPrecisionFormat + type Array = JS.ArrayBufferView + type Float32Array = JS.Float32Array + type Int32Array = JS.Int32Array + type Image = JS.Image + + true = True + false = False + nullGLPtr = 0 + toGLString = toJSString + noBuffer = JS.noBuffer + noTexture = JS.noTexture + + encodeM2 (M2 (V2 a1 a2) (V2 b1 b2)) = JS.listToJSArray [ a1, a2, b1, b2] + >>= JS.float32Array + + encodeM3 (M3 (V3 a1 a2 a3) + (V3 b1 b2 b3) + (V3 c1 c2 c3)) = JS.listToJSArray [ a1, a2, a3 + , b1, b2, b3 + , c1, c2, c3] + >>= JS.float32Array + encodeM4 (M4 (V4 a1 a2 a3 a4) + (V4 b1 b2 b3 b4) + (V4 c1 c2 c3 c4) + (V4 d1 d2 d3 d4) ) = JS.listToJSArray [ a1, a2, a3, a4 + , b1, b2, b3, b4 + , c1, c2, c3, c4 + , d1, d2, d3, d4 ] + >>= JS.float32Array + encodeFloats v = JS.listToJSArray v >>= JS.float32View + + -- TODO: decent implementation + encodeV2s v = JS.toJSArray next (False, v) >>= JS.float32View + where next (False, xs@(V2 x _ : _)) = Just (x, (True, xs)) + next (True, V2 _ y : xs) = Just (y, (False, xs)) + next (_, []) = Nothing + + encodeV3s v = JS.toJSArray next (0, v) >>= JS.float32View + where next (0, xs@(V3 x _ _ : _)) = Just (x, (1, xs)) + next (1, xs@(V3 _ y _ : _)) = Just (y, (2, xs)) + next (2, V3 _ _ z : xs) = Just (z, (0, xs)) + next (_, []) = Nothing + + -- TODO + encodeV4s = error "encodeV4s: TODO" + + encodeUShorts v = JS.listToJSArray v >>= JS.uint16View + + encodeColors v = JS.toJSArray next (0, v) >>= JS.uint8View + where next (0, xs@(Color x _ _ _ : _)) = Just (x, (1, xs)) + next (1, xs@(Color _ y _ _ : _)) = Just (y, (2, xs)) + next (2, xs@(Color _ _ z _ : _)) = Just (z, (3, xs)) + next (3, Color _ _ _ w : xs) = Just (w, (0, xs)) + next (_, []) = Nothing + + glActiveTexture = JS.glActiveTexture + glAttachShader = JS.glAttachShader + glBindAttribLocation = JS.glBindAttribLocation + glBindBuffer = JS.glBindBuffer + glBindFramebuffer = JS.glBindFramebuffer + glBindRenderbuffer = JS.glBindRenderbuffer + glBindTexture = JS.glBindTexture + glBlendColor = JS.glBlendColor + glBlendEquation = JS.glBlendEquation + glBlendEquationSeparate = JS.glBlendEquationSeparate + glBlendFunc = JS.glBlendFunc + glBlendFuncSeparate = JS.glBlendFuncSeparate + glBufferData = JS.glBufferData + glBufferSubData = JS.glBufferSubData + glCheckFramebufferStatus = JS.glCheckFramebufferStatus + glClear = JS.glClear + glClearColor = JS.glClearColor + glClearDepth = JS.glClearDepth + glClearStencil = JS.glClearStencil + glColorMask = JS.glColorMask + glCompileShader = JS.glCompileShader + glCompressedTexImage2D = JS.glCompressedTexImage2D + glCompressedTexSubImage2D = JS.glCompressedTexSubImage2D + glCopyTexImage2D = JS.glCopyTexImage2D + glCopyTexSubImage2D = JS.glCopyTexSubImage2D + glCreateBuffer = JS.glCreateBuffer + glCreateFramebuffer = JS.glCreateFramebuffer + glCreateProgram = JS.glCreateProgram + glCreateRenderbuffer = JS.glCreateRenderbuffer + glCreateShader = JS.glCreateShader + glCreateTexture = JS.glCreateTexture + glCullFace = JS.glCullFace + glDeleteBuffer = JS.glDeleteBuffer + glDeleteFramebuffer = JS.glDeleteFramebuffer + glDeleteProgram = JS.glDeleteProgram + glDeleteRenderbuffer = JS.glDeleteRenderbuffer + glDeleteShader = JS.glDeleteShader + glDeleteTexture = JS.glDeleteTexture + glDepthFunc = JS.glDepthFunc + glDepthMask = JS.glDepthMask + glDepthRange = JS.glDepthRange + glDetachShader = JS.glDetachShader + glDisable = JS.glDisable + glDisableVertexAttribArray = JS.glDisableVertexAttribArray + glDrawArrays = JS.glDrawArrays + glDrawElements = JS.glDrawElements + glEnable = JS.glEnable + glEnableVertexAttribArray = JS.glEnableVertexAttribArray + glFinish = JS.glFinish + glFlush = JS.glFlush + glFramebufferRenderbuffer = JS.glFramebufferRenderbuffer + glFramebufferTexture2D = JS.glFramebufferTexture2D + glFrontFace = JS.glFrontFace + glGenerateMipmap = JS.glGenerateMipmap + -- glGetActiveAttrib = JS.glGetActiveAttrib + -- glGetActiveUniform = JS.glGetActiveUniform + glGetAttribLocation = JS.glGetAttribLocation + -- glGetBufferParameter = JS.glGetBufferParameter + -- glGetParameter = JS.glGetParameter + glGetError = JS.glGetError + -- glGetFramebufferAttachmentParameter = JS.glGetFramebufferAttachmentParameter + glGetProgramInfoLog = JS.glGetProgramInfoLog + -- glGetRenderbufferParameter = JS.glGetRenderbufferParameter + -- glGetShaderParameter = JS.glGetShaderParameter + -- glGetShaderPrecisionFormat = JS.glGetShaderPrecisionFormat + glGetShaderInfoLog = JS.glGetShaderInfoLog + glGetShaderSource = JS.glGetShaderSource + -- glGetTexParameter = JS.glGetTexParameter + -- glGetUniform = JS.glGetUniform + glGetUniformLocation = JS.glGetUniformLocation + -- glGetVertexAttrib = JS.glGetVertexAttrib + -- glGetVertexAttribOffset = JS.glGetVertexAttribOffset + glHint = JS.glHint + glIsBuffer = JS.glIsBuffer + glIsEnabled = JS.glIsEnabled + glIsFramebuffer = JS.glIsFramebuffer + glIsProgram = JS.glIsProgram + glIsRenderbuffer = JS.glIsRenderbuffer + glIsShader = JS.glIsShader + glIsTexture = JS.glIsTexture + glLineWidth = JS.glLineWidth + glLinkProgram = JS.glLinkProgram + glPixelStorei = JS.glPixelStorei + glPolygonOffset = JS.glPolygonOffset + glReadPixels = JS.glReadPixels + glRenderbufferStorage = JS.glRenderbufferStorage + glSampleCoverage = JS.glSampleCoverage + glScissor = JS.glScissor + glShaderSource = JS.glShaderSource + glStencilFunc = JS.glStencilFunc + glStencilFuncSeparate = JS.glStencilFuncSeparate + glStencilMask = JS.glStencilMask + glStencilMaskSeparate = JS.glStencilMaskSeparate + glStencilOp = JS.glStencilOp + glStencilOpSeparate = JS.glStencilOpSeparate + glTexImage2DBuffer = JS.glTexImage2DBuffer + glTexImage2DImage = JS.glTexImage2DElement + glTexParameterf = JS.glTexParameterf + glTexParameteri = JS.glTexParameteri + glTexSubImage2D = JS.glTexSubImage2D + glUniform1f = JS.glUniform1f + glUniform1fv = JS.glUniform1fv + glUniform1i = JS.glUniform1i + glUniform1iv = JS.glUniform1iv + glUniform2f = JS.glUniform2f + glUniform2fv = JS.glUniform2fv + glUniform2i = JS.glUniform2i + glUniform2iv = JS.glUniform2iv + glUniform3f = JS.glUniform3f + glUniform3fv = JS.glUniform3fv + glUniform3i = JS.glUniform3i + glUniform3iv = JS.glUniform3iv + glUniform4f = JS.glUniform4f + glUniform4fv = JS.glUniform4fv + glUniform4i = JS.glUniform4i + glUniform4iv = JS.glUniform4iv + glUniformMatrix2fv = JS.glUniformMatrix2fv + glUniformMatrix3fv = JS.glUniformMatrix3fv + glUniformMatrix4fv = JS.glUniformMatrix4fv + glUseProgram = JS.glUseProgram + glValidateProgram = JS.glValidateProgram + glVertexAttrib1f = JS.glVertexAttrib1f + glVertexAttrib1fv = JS.glVertexAttrib1fv + glVertexAttrib2f = JS.glVertexAttrib2f + glVertexAttrib2fv = JS.glVertexAttrib2fv + glVertexAttrib3f = JS.glVertexAttrib3f + glVertexAttrib3fv = JS.glVertexAttrib3fv + glVertexAttrib4f = JS.glVertexAttrib4f + glVertexAttrib4fv = JS.glVertexAttrib4fv + glVertexAttribPointer = JS.glVertexAttribPointer + glViewport = JS.glViewport + + gl_DEPTH_BUFFER_BIT = JS.gl_DEPTH_BUFFER_BIT + gl_STENCIL_BUFFER_BIT = JS.gl_STENCIL_BUFFER_BIT + gl_COLOR_BUFFER_BIT = JS.gl_COLOR_BUFFER_BIT + gl_POINTS = JS.gl_POINTS + gl_LINES = JS.gl_LINES + gl_LINE_LOOP = JS.gl_LINE_LOOP + gl_LINE_STRIP = JS.gl_LINE_STRIP + gl_TRIANGLES = JS.gl_TRIANGLES + gl_TRIANGLE_STRIP = JS.gl_TRIANGLE_STRIP + gl_TRIANGLE_FAN = JS.gl_TRIANGLE_FAN + gl_ZERO = JS.gl_ZERO + gl_ONE = JS.gl_ONE + gl_SRC_COLOR = JS.gl_SRC_COLOR + gl_ONE_MINUS_SRC_COLOR = JS.gl_ONE_MINUS_SRC_COLOR + gl_SRC_ALPHA = JS.gl_SRC_ALPHA + gl_ONE_MINUS_SRC_ALPHA = JS.gl_ONE_MINUS_SRC_ALPHA + gl_DST_ALPHA = JS.gl_DST_ALPHA + gl_ONE_MINUS_DST_ALPHA = JS.gl_ONE_MINUS_DST_ALPHA + gl_DST_COLOR = JS.gl_DST_COLOR + gl_ONE_MINUS_DST_COLOR = JS.gl_ONE_MINUS_DST_COLOR + gl_SRC_ALPHA_SATURATE = JS.gl_SRC_ALPHA_SATURATE + gl_FUNC_ADD = JS.gl_FUNC_ADD + gl_BLEND_EQUATION = JS.gl_BLEND_EQUATION + gl_BLEND_EQUATION_RGB = JS.gl_BLEND_EQUATION_RGB + gl_BLEND_EQUATION_ALPHA = JS.gl_BLEND_EQUATION_ALPHA + gl_FUNC_SUBTRACT = JS.gl_FUNC_SUBTRACT + gl_FUNC_REVERSE_SUBTRACT = JS.gl_FUNC_REVERSE_SUBTRACT + gl_BLEND_DST_RGB = JS.gl_BLEND_DST_RGB + gl_BLEND_SRC_RGB = JS.gl_BLEND_SRC_RGB + gl_BLEND_DST_ALPHA = JS.gl_BLEND_DST_ALPHA + gl_BLEND_SRC_ALPHA = JS.gl_BLEND_SRC_ALPHA + gl_CONSTANT_COLOR = JS.gl_CONSTANT_COLOR + gl_ONE_MINUS_CONSTANT_COLOR = JS.gl_ONE_MINUS_CONSTANT_COLOR + gl_CONSTANT_ALPHA = JS.gl_CONSTANT_ALPHA + gl_ONE_MINUS_CONSTANT_ALPHA = JS.gl_ONE_MINUS_CONSTANT_ALPHA + gl_BLEND_COLOR = JS.gl_BLEND_COLOR + gl_ARRAY_BUFFER = JS.gl_ARRAY_BUFFER + gl_ELEMENT_ARRAY_BUFFER = JS.gl_ELEMENT_ARRAY_BUFFER + gl_ARRAY_BUFFER_BINDING = JS.gl_ARRAY_BUFFER_BINDING + gl_ELEMENT_ARRAY_BUFFER_BINDING = JS.gl_ELEMENT_ARRAY_BUFFER_BINDING + gl_STREAM_DRAW = JS.gl_STREAM_DRAW + gl_STATIC_DRAW = JS.gl_STATIC_DRAW + gl_DYNAMIC_DRAW = JS.gl_DYNAMIC_DRAW + gl_BUFFER_SIZE = JS.gl_BUFFER_SIZE + gl_BUFFER_USAGE = JS.gl_BUFFER_USAGE + gl_CURRENT_VERTEX_ATTRIB = JS.gl_CURRENT_VERTEX_ATTRIB + gl_FRONT = JS.gl_FRONT + gl_BACK = JS.gl_BACK + gl_FRONT_AND_BACK = JS.gl_FRONT_AND_BACK + gl_CULL_FACE = JS.gl_CULL_FACE + gl_BLEND = JS.gl_BLEND + gl_DITHER = JS.gl_DITHER + gl_STENCIL_TEST = JS.gl_STENCIL_TEST + gl_DEPTH_TEST = JS.gl_DEPTH_TEST + gl_SCISSOR_TEST = JS.gl_SCISSOR_TEST + gl_POLYGON_OFFSET_FILL = JS.gl_POLYGON_OFFSET_FILL + gl_SAMPLE_ALPHA_TO_COVERAGE = JS.gl_SAMPLE_ALPHA_TO_COVERAGE + gl_SAMPLE_COVERAGE = JS.gl_SAMPLE_COVERAGE + gl_NO_ERROR = JS.gl_NO_ERROR + gl_INVALID_ENUM = JS.gl_INVALID_ENUM + gl_INVALID_VALUE = JS.gl_INVALID_VALUE + gl_INVALID_OPERATION = JS.gl_INVALID_OPERATION + gl_OUT_OF_MEMORY = JS.gl_OUT_OF_MEMORY + gl_CW = JS.gl_CW + gl_CCW = JS.gl_CCW + gl_LINE_WIDTH = JS.gl_LINE_WIDTH + gl_ALIASED_POINT_SIZE_RANGE = JS.gl_ALIASED_POINT_SIZE_RANGE + gl_ALIASED_LINE_WIDTH_RANGE = JS.gl_ALIASED_LINE_WIDTH_RANGE + gl_CULL_FACE_MODE = JS.gl_CULL_FACE_MODE + gl_FRONT_FACE = JS.gl_FRONT_FACE + gl_DEPTH_RANGE = JS.gl_DEPTH_RANGE + gl_DEPTH_WRITEMASK = JS.gl_DEPTH_WRITEMASK + gl_DEPTH_CLEAR_VALUE = JS.gl_DEPTH_CLEAR_VALUE + gl_DEPTH_FUNC = JS.gl_DEPTH_FUNC + gl_STENCIL_CLEAR_VALUE = JS.gl_STENCIL_CLEAR_VALUE + gl_STENCIL_FUNC = JS.gl_STENCIL_FUNC + gl_STENCIL_FAIL = JS.gl_STENCIL_FAIL + gl_STENCIL_PASS_DEPTH_FAIL = JS.gl_STENCIL_PASS_DEPTH_FAIL + gl_STENCIL_PASS_DEPTH_PASS = JS.gl_STENCIL_PASS_DEPTH_PASS + gl_STENCIL_REF = JS.gl_STENCIL_REF + gl_STENCIL_VALUE_MASK = JS.gl_STENCIL_VALUE_MASK + gl_STENCIL_WRITEMASK = JS.gl_STENCIL_WRITEMASK + gl_STENCIL_BACK_FUNC = JS.gl_STENCIL_BACK_FUNC + gl_STENCIL_BACK_FAIL = JS.gl_STENCIL_BACK_FAIL + gl_STENCIL_BACK_PASS_DEPTH_FAIL = JS.gl_STENCIL_BACK_PASS_DEPTH_FAIL + gl_STENCIL_BACK_PASS_DEPTH_PASS = JS.gl_STENCIL_BACK_PASS_DEPTH_PASS + gl_STENCIL_BACK_REF = JS.gl_STENCIL_BACK_REF + gl_STENCIL_BACK_VALUE_MASK = JS.gl_STENCIL_BACK_VALUE_MASK + gl_STENCIL_BACK_WRITEMASK = JS.gl_STENCIL_BACK_WRITEMASK + gl_VIEWPORT = JS.gl_VIEWPORT + gl_SCISSOR_BOX = JS.gl_SCISSOR_BOX + gl_COLOR_CLEAR_VALUE = JS.gl_COLOR_CLEAR_VALUE + gl_COLOR_WRITEMASK = JS.gl_COLOR_WRITEMASK + gl_UNPACK_ALIGNMENT = JS.gl_UNPACK_ALIGNMENT + gl_PACK_ALIGNMENT = JS.gl_PACK_ALIGNMENT + gl_MAX_TEXTURE_SIZE = JS.gl_MAX_TEXTURE_SIZE + gl_MAX_VIEWPORT_DIMS = JS.gl_MAX_VIEWPORT_DIMS + gl_SUBPIXEL_BITS = JS.gl_SUBPIXEL_BITS + gl_RED_BITS = JS.gl_RED_BITS + gl_GREEN_BITS = JS.gl_GREEN_BITS + gl_BLUE_BITS = JS.gl_BLUE_BITS + gl_ALPHA_BITS = JS.gl_ALPHA_BITS + gl_DEPTH_BITS = JS.gl_DEPTH_BITS + gl_STENCIL_BITS = JS.gl_STENCIL_BITS + gl_POLYGON_OFFSET_UNITS = JS.gl_POLYGON_OFFSET_UNITS + gl_POLYGON_OFFSET_FACTOR = JS.gl_POLYGON_OFFSET_FACTOR + gl_TEXTURE_BINDING_2D = JS.gl_TEXTURE_BINDING_2D + gl_SAMPLE_BUFFERS = JS.gl_SAMPLE_BUFFERS + gl_SAMPLES = JS.gl_SAMPLES + gl_SAMPLE_COVERAGE_VALUE = JS.gl_SAMPLE_COVERAGE_VALUE + gl_SAMPLE_COVERAGE_INVERT = JS.gl_SAMPLE_COVERAGE_INVERT + gl_COMPRESSED_TEXTURE_FORMATS = JS.gl_COMPRESSED_TEXTURE_FORMATS + gl_DONT_CARE = JS.gl_DONT_CARE + gl_FASTEST = JS.gl_FASTEST + gl_NICEST = JS.gl_NICEST + gl_GENERATE_MIPMAP_HINT = JS.gl_GENERATE_MIPMAP_HINT + gl_BYTE = JS.gl_BYTE + gl_UNSIGNED_BYTE = JS.gl_UNSIGNED_BYTE + gl_SHORT = JS.gl_SHORT + gl_UNSIGNED_SHORT = JS.gl_UNSIGNED_SHORT + gl_INT = JS.gl_INT + gl_UNSIGNED_INT = JS.gl_UNSIGNED_INT + gl_FLOAT = JS.gl_FLOAT + gl_DEPTH_COMPONENT = JS.gl_DEPTH_COMPONENT + gl_ALPHA = JS.gl_ALPHA + gl_RGB = JS.gl_RGB + gl_RGBA = JS.gl_RGBA + gl_LUMINANCE = JS.gl_LUMINANCE + gl_LUMINANCE_ALPHA = JS.gl_LUMINANCE_ALPHA + gl_UNSIGNED_SHORT_4_4_4_4 = JS.gl_UNSIGNED_SHORT_4_4_4_4 + gl_UNSIGNED_SHORT_5_5_5_1 = JS.gl_UNSIGNED_SHORT_5_5_5_1 + gl_UNSIGNED_SHORT_5_6_5 = JS.gl_UNSIGNED_SHORT_5_6_5 + gl_FRAGMENT_SHADER = JS.gl_FRAGMENT_SHADER + gl_VERTEX_SHADER = JS.gl_VERTEX_SHADER + gl_MAX_VERTEX_ATTRIBS = JS.gl_MAX_VERTEX_ATTRIBS + gl_MAX_VERTEX_UNIFORM_VECTORS = JS.gl_MAX_VERTEX_UNIFORM_VECTORS + gl_MAX_VARYING_VECTORS = JS.gl_MAX_VARYING_VECTORS + gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS = JS.gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS + gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS = JS.gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS + gl_MAX_TEXTURE_IMAGE_UNITS = JS.gl_MAX_TEXTURE_IMAGE_UNITS + gl_MAX_FRAGMENT_UNIFORM_VECTORS = JS.gl_MAX_FRAGMENT_UNIFORM_VECTORS + gl_SHADER_TYPE = JS.gl_SHADER_TYPE + gl_DELETE_STATUS = JS.gl_DELETE_STATUS + gl_LINK_STATUS = JS.gl_LINK_STATUS + gl_VALIDATE_STATUS = JS.gl_VALIDATE_STATUS + gl_ATTACHED_SHADERS = JS.gl_ATTACHED_SHADERS + gl_ACTIVE_UNIFORMS = JS.gl_ACTIVE_UNIFORMS + gl_ACTIVE_ATTRIBUTES = JS.gl_ACTIVE_ATTRIBUTES + gl_SHADING_LANGUAGE_VERSION = JS.gl_SHADING_LANGUAGE_VERSION + gl_CURRENT_PROGRAM = JS.gl_CURRENT_PROGRAM + gl_NEVER = JS.gl_NEVER + gl_LESS = JS.gl_LESS + gl_EQUAL = JS.gl_EQUAL + gl_LEQUAL = JS.gl_LEQUAL + gl_GREATER = JS.gl_GREATER + gl_NOTEQUAL = JS.gl_NOTEQUAL + gl_GEQUAL = JS.gl_GEQUAL + gl_ALWAYS = JS.gl_ALWAYS + gl_KEEP = JS.gl_KEEP + gl_REPLACE = JS.gl_REPLACE + gl_INCR = JS.gl_INCR + gl_DECR = JS.gl_DECR + gl_INVERT = JS.gl_INVERT + gl_INCR_WRAP = JS.gl_INCR_WRAP + gl_DECR_WRAP = JS.gl_DECR_WRAP + gl_VENDOR = JS.gl_VENDOR + gl_RENDERER = JS.gl_RENDERER + gl_VERSION = JS.gl_VERSION + gl_NEAREST = JS.gl_NEAREST + gl_LINEAR = JS.gl_LINEAR + gl_NEAREST_MIPMAP_NEAREST = JS.gl_NEAREST_MIPMAP_NEAREST + gl_LINEAR_MIPMAP_NEAREST = JS.gl_LINEAR_MIPMAP_NEAREST + gl_NEAREST_MIPMAP_LINEAR = JS.gl_NEAREST_MIPMAP_LINEAR + gl_LINEAR_MIPMAP_LINEAR = JS.gl_LINEAR_MIPMAP_LINEAR + gl_TEXTURE_MAG_FILTER = JS.gl_TEXTURE_MAG_FILTER + gl_TEXTURE_MIN_FILTER = JS.gl_TEXTURE_MIN_FILTER + gl_TEXTURE_WRAP_S = JS.gl_TEXTURE_WRAP_S + gl_TEXTURE_WRAP_T = JS.gl_TEXTURE_WRAP_T + gl_TEXTURE_2D = JS.gl_TEXTURE_2D + gl_TEXTURE = JS.gl_TEXTURE + gl_TEXTURE_CUBE_MAP = JS.gl_TEXTURE_CUBE_MAP + gl_TEXTURE_BINDING_CUBE_MAP = JS.gl_TEXTURE_BINDING_CUBE_MAP + gl_TEXTURE_CUBE_MAP_POSITIVE_X = JS.gl_TEXTURE_CUBE_MAP_POSITIVE_X + gl_TEXTURE_CUBE_MAP_NEGATIVE_X = JS.gl_TEXTURE_CUBE_MAP_NEGATIVE_X + gl_TEXTURE_CUBE_MAP_POSITIVE_Y = JS.gl_TEXTURE_CUBE_MAP_POSITIVE_Y + gl_TEXTURE_CUBE_MAP_NEGATIVE_Y = JS.gl_TEXTURE_CUBE_MAP_NEGATIVE_Y + gl_TEXTURE_CUBE_MAP_POSITIVE_Z = JS.gl_TEXTURE_CUBE_MAP_POSITIVE_Z + gl_TEXTURE_CUBE_MAP_NEGATIVE_Z = JS.gl_TEXTURE_CUBE_MAP_NEGATIVE_Z + gl_MAX_CUBE_MAP_TEXTURE_SIZE = JS.gl_MAX_CUBE_MAP_TEXTURE_SIZE + gl_TEXTURE0 = JS.gl_TEXTURE0 + gl_TEXTURE1 = JS.gl_TEXTURE1 + gl_TEXTURE2 = JS.gl_TEXTURE2 + gl_TEXTURE3 = JS.gl_TEXTURE3 + gl_TEXTURE4 = JS.gl_TEXTURE4 + gl_TEXTURE5 = JS.gl_TEXTURE5 + gl_TEXTURE6 = JS.gl_TEXTURE6 + gl_TEXTURE7 = JS.gl_TEXTURE7 + gl_TEXTURE8 = JS.gl_TEXTURE8 + gl_TEXTURE9 = JS.gl_TEXTURE9 + gl_TEXTURE10 = JS.gl_TEXTURE10 + gl_TEXTURE11 = JS.gl_TEXTURE11 + gl_TEXTURE12 = JS.gl_TEXTURE12 + gl_TEXTURE13 = JS.gl_TEXTURE13 + gl_TEXTURE14 = JS.gl_TEXTURE14 + gl_TEXTURE15 = JS.gl_TEXTURE15 + gl_TEXTURE16 = JS.gl_TEXTURE16 + gl_TEXTURE17 = JS.gl_TEXTURE17 + gl_TEXTURE18 = JS.gl_TEXTURE18 + gl_TEXTURE19 = JS.gl_TEXTURE19 + gl_TEXTURE20 = JS.gl_TEXTURE20 + gl_TEXTURE21 = JS.gl_TEXTURE21 + gl_TEXTURE22 = JS.gl_TEXTURE22 + gl_TEXTURE23 = JS.gl_TEXTURE23 + gl_TEXTURE24 = JS.gl_TEXTURE24 + gl_TEXTURE25 = JS.gl_TEXTURE25 + gl_TEXTURE26 = JS.gl_TEXTURE26 + gl_TEXTURE27 = JS.gl_TEXTURE27 + gl_TEXTURE28 = JS.gl_TEXTURE28 + gl_TEXTURE29 = JS.gl_TEXTURE29 + gl_TEXTURE30 = JS.gl_TEXTURE30 + gl_TEXTURE31 = JS.gl_TEXTURE31 + gl_ACTIVE_TEXTURE = JS.gl_ACTIVE_TEXTURE + gl_REPEAT = JS.gl_REPEAT + gl_CLAMP_TO_EDGE = JS.gl_CLAMP_TO_EDGE + gl_MIRRORED_REPEAT = JS.gl_MIRRORED_REPEAT + gl_FLOAT_VEC2 = JS.gl_FLOAT_VEC2 + gl_FLOAT_VEC3 = JS.gl_FLOAT_VEC3 + gl_FLOAT_VEC4 = JS.gl_FLOAT_VEC4 + gl_INT_VEC2 = JS.gl_INT_VEC2 + gl_INT_VEC3 = JS.gl_INT_VEC3 + gl_INT_VEC4 = JS.gl_INT_VEC4 + gl_BOOL = JS.gl_BOOL + gl_BOOL_VEC2 = JS.gl_BOOL_VEC2 + gl_BOOL_VEC3 = JS.gl_BOOL_VEC3 + gl_BOOL_VEC4 = JS.gl_BOOL_VEC4 + gl_FLOAT_MAT2 = JS.gl_FLOAT_MAT2 + gl_FLOAT_MAT3 = JS.gl_FLOAT_MAT3 + gl_FLOAT_MAT4 = JS.gl_FLOAT_MAT4 + gl_SAMPLER_2D = JS.gl_SAMPLER_2D + gl_SAMPLER_CUBE = JS.gl_SAMPLER_CUBE + gl_VERTEX_ATTRIB_ARRAY_ENABLED = JS.gl_VERTEX_ATTRIB_ARRAY_ENABLED + gl_VERTEX_ATTRIB_ARRAY_SIZE = JS.gl_VERTEX_ATTRIB_ARRAY_SIZE + gl_VERTEX_ATTRIB_ARRAY_STRIDE = JS.gl_VERTEX_ATTRIB_ARRAY_STRIDE + gl_VERTEX_ATTRIB_ARRAY_TYPE = JS.gl_VERTEX_ATTRIB_ARRAY_TYPE + gl_VERTEX_ATTRIB_ARRAY_NORMALIZED = JS.gl_VERTEX_ATTRIB_ARRAY_NORMALIZED + gl_VERTEX_ATTRIB_ARRAY_POINTER = JS.gl_VERTEX_ATTRIB_ARRAY_POINTER + gl_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING = JS.gl_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING + gl_COMPILE_STATUS = JS.gl_COMPILE_STATUS + gl_LOW_FLOAT = JS.gl_LOW_FLOAT + gl_MEDIUM_FLOAT = JS.gl_MEDIUM_FLOAT + gl_HIGH_FLOAT = JS.gl_HIGH_FLOAT + gl_LOW_INT = JS.gl_LOW_INT + gl_MEDIUM_INT = JS.gl_MEDIUM_INT + gl_HIGH_INT = JS.gl_HIGH_INT + gl_FRAMEBUFFER = JS.gl_FRAMEBUFFER + gl_RENDERBUFFER = JS.gl_RENDERBUFFER + gl_RGBA4 = JS.gl_RGBA4 + gl_RGB5_A1 = JS.gl_RGB5_A1 + gl_RGB565 = JS.gl_RGB565 + gl_DEPTH_COMPONENT16 = JS.gl_DEPTH_COMPONENT16 + gl_STENCIL_INDEX8 = JS.gl_STENCIL_INDEX8 + gl_RENDERBUFFER_WIDTH = JS.gl_RENDERBUFFER_WIDTH + gl_RENDERBUFFER_HEIGHT = JS.gl_RENDERBUFFER_HEIGHT + gl_RENDERBUFFER_INTERNAL_FORMAT = JS.gl_RENDERBUFFER_INTERNAL_FORMAT + gl_RENDERBUFFER_RED_SIZE = JS.gl_RENDERBUFFER_RED_SIZE + gl_RENDERBUFFER_GREEN_SIZE = JS.gl_RENDERBUFFER_GREEN_SIZE + gl_RENDERBUFFER_BLUE_SIZE = JS.gl_RENDERBUFFER_BLUE_SIZE + gl_RENDERBUFFER_ALPHA_SIZE = JS.gl_RENDERBUFFER_ALPHA_SIZE + gl_RENDERBUFFER_DEPTH_SIZE = JS.gl_RENDERBUFFER_DEPTH_SIZE + gl_RENDERBUFFER_STENCIL_SIZE = JS.gl_RENDERBUFFER_STENCIL_SIZE + gl_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE = JS.gl_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE + gl_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME = JS.gl_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME + gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL = JS.gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL + gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE = JS.gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE + gl_COLOR_ATTACHMENT0 = JS.gl_COLOR_ATTACHMENT0 + gl_DEPTH_ATTACHMENT = JS.gl_DEPTH_ATTACHMENT + gl_STENCIL_ATTACHMENT = JS.gl_STENCIL_ATTACHMENT + gl_NONE = JS.gl_NONE + gl_FRAMEBUFFER_COMPLETE = JS.gl_FRAMEBUFFER_COMPLETE + gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = JS.gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT + gl_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT = JS.gl_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT + gl_FRAMEBUFFER_INCOMPLETE_DIMENSIONS = JS.gl_FRAMEBUFFER_INCOMPLETE_DIMENSIONS + gl_FRAMEBUFFER_UNSUPPORTED = JS.gl_FRAMEBUFFER_UNSUPPORTED + gl_FRAMEBUFFER_BINDING = JS.gl_FRAMEBUFFER_BINDING + gl_RENDERBUFFER_BINDING = JS.gl_RENDERBUFFER_BINDING + gl_MAX_RENDERBUFFER_SIZE = JS.gl_MAX_RENDERBUFFER_SIZE + gl_INVALID_FRAMEBUFFER_OPERATION = JS.gl_INVALID_FRAMEBUFFER_OPERATION diff --git a/FWGL/Backend/JavaScript/Event.hs b/FWGL/Backend/JavaScript/Event.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/JavaScript/Event.hs @@ -0,0 +1,200 @@ +-- TODO: rewrite everything + +module FWGL.Backend.JavaScript.Event ( + InputEvent(..), + Source, + source, + addEvent, + addEvents, + events, + clear +) where + +import Control.Applicative +import Data.Char (toLower, toUpper) +import qualified Data.Hashable as H +import qualified Data.HashMap.Strict as H +import Data.IORef + +import GHCJS.Foreign +import GHCJS.Marshal +import GHCJS.Types + +import FWGL.Input + +type Event = InputEvent + +data Source = Source { + element :: JSRef (), + eventMap :: IORef (H.HashMap Event [EventData]) +} + +source :: [Event] -> JSRef a -> IO Source +source es j = do + s <- Source (castRef j) <$> newIORef H.empty + addEvents es s + return s + +events :: Source -> IO (H.HashMap Event [EventData]) +events (Source _ c) = readIORef c + +clear :: Source -> IO (H.HashMap Event [EventData]) +clear (Source _ c) = atomicModifyIORef' c $ \m -> (H.empty, m) + +addEvents :: [Event] -> Source -> IO () +addEvents es s = mapM_ (flip addEvent s) es + +addEvent :: Event -> Source -> IO () +addEvent e (Source j c) = asyncCallback1 NeverRetain handler >>= + addHandler j (toJSString $ eventName e) + where + prop p d = getProp p d >>= fromJSRef + handler d = do + eventData <- EventData + <$> (do w <- prop "clientWidth" j + h <- prop "clientHeight" j + return $ (,) <$> w <*> h) + <*> (do x <- prop "clientX" d + y <- prop "clientY" d + return $ (,) <$> x <*> y) + <*> ((getButton <$>) <$> prop "button" d) + <*> ((getKey <$>) <$> prop "keyCode" d) + modifyIORef c $ H.insertWith (flip (++)) e [ eventData ] + +eventName :: Event -> String +-- eventName (Other s) = s +-- eventName DoubleClick = "dblclick" +eventName s = map toLower . show $ s + +getButton :: Int -> MouseButton +getButton 0 = MouseLeft +getButton 1 = MouseMiddle +getButton 2 = MouseRight + +foreign import javascript unsafe "$1.addEventListener($2, $3)" + addHandler :: JSRef a -> JSString -> JSFun (JSRef b -> IO ()) -> IO () + +getKey :: Int -> Key +getKey 65 = KeyA +getKey 66 = KeyB +getKey 67 = KeyC +getKey 68 = KeyD +getKey 69 = KeyE +getKey 70 = KeyF +getKey 71 = KeyG +getKey 72 = KeyH +getKey 73 = KeyI +getKey 74 = KeyJ +getKey 75 = KeyK +getKey 76 = KeyL +getKey 77 = KeyM +getKey 78 = KeyN +getKey 79 = KeyO +getKey 80 = KeyP +getKey 81 = KeyQ +getKey 82 = KeyR +getKey 83 = KeyS +getKey 84 = KeyT +getKey 85 = KeyU +getKey 86 = KeyV +getKey 87 = KeyW +getKey 88 = KeyX +getKey 89 = KeyY +getKey 90 = KeyZ +getKey 97 = KeyA +getKey 98 = KeyB +getKey 99 = KeyC +getKey 100 = KeyD +getKey 101 = KeyE +getKey 102 = KeyF +getKey 103 = KeyG +getKey 104 = KeyH +getKey 105 = KeyI +getKey 106 = KeyJ +getKey 107 = KeyK +getKey 108 = KeyL +getKey 109 = KeyM +getKey 110 = KeyN +getKey 111 = KeyO +getKey 112 = KeyP +getKey 113 = KeyQ +getKey 114 = KeyR +getKey 115 = KeyS +getKey 116 = KeyT +getKey 117 = KeyU +getKey 118 = KeyV +getKey 119 = KeyW +getKey 120 = KeyX +getKey 121 = KeyY +getKey 122 = KeyZ +getKey 48 = Key0 +getKey 49 = Key1 +getKey 50 = Key2 +getKey 51 = Key3 +getKey 52 = Key4 +getKey 53 = Key5 +getKey 54 = Key6 +getKey 55 = Key7 +getKey 56 = Key8 +getKey 57 = Key9 +getKey 32 = KeySpace +getKey 13 = KeyEnter +getKey 9 = KeyTab +getKey 27 = KeyEsc +getKey 8 = KeyBackspace +getKey 16 = KeyShift +getKey 17 = KeyControl +getKey 18 = KeyAlt +getKey 20 = KeyCapsLock +getKey 144 = KeyNumLock +getKey 37 = KeyArrowLeft +getKey 38 = KeyArrowUp +getKey 39 = KeyArrowRight +getKey 40 = KeyArrowDown +getKey 45 = KeyIns +getKey 46 = KeyDel +getKey 36 = KeyHome +getKey 35 = KeyEnd +getKey 33 = KeyPgUp +getKey 34 = KeyPgDown +getKey 112 = KeyF1 +getKey 113 = KeyF2 +getKey 114 = KeyF3 +getKey 115 = KeyF4 +getKey 116 = KeyF5 +getKey 117 = KeyF6 +getKey 118 = KeyF7 +getKey 119 = KeyF8 +getKey 120 = KeyF9 +getKey 121 = KeyF10 +getKey 122 = KeyF11 +getKey 123 = KeyF12 +getKey 46 = KeyPadDel +getKey 45 = KeyPadIns +getKey 35 = KeyPadEnd +getKey 40 = KeyPadDown +getKey 34 = KeyPadPgDown +getKey 37 = KeyPadLeft +getKey 39 = KeyPadRight +getKey 36 = KeyPadHome +getKey 38 = KeyPadUp +getKey 33 = KeyPadPgUp +getKey 107 = KeyPadAdd +getKey 109 = KeyPadSub +getKey 106 = KeyPadMul +getKey 111 = KeyPadDiv +getKey 13 = KeyPadEnter +getKey 46 = KeyPadDot +getKey 48 = KeyPad0 +getKey 49 = KeyPad1 +getKey 50 = KeyPad2 +getKey 51 = KeyPad3 +getKey 52 = KeyPad4 +getKey 53 = KeyPad5 +getKey 54 = KeyPad6 +getKey 55 = KeyPad7 +getKey 56 = KeyPad8 +getKey 57 = KeyPad9 +getKey _ = KeyUnknown +-- TODO: letters, numbers +-- TODO: fix overlapping patterns diff --git a/FWGL/Backend/JavaScript/WebGL.hs b/FWGL/Backend/JavaScript/WebGL.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/JavaScript/WebGL.hs @@ -0,0 +1,5 @@ +module FWGL.Backend.JavaScript.WebGL (module W) where + +import FWGL.Backend.JavaScript.WebGL.Const as W +import FWGL.Backend.JavaScript.WebGL.Raw as W +import FWGL.Backend.JavaScript.WebGL.Types as W diff --git a/FWGL/Backend/JavaScript/WebGL/Const.hs b/FWGL/Backend/JavaScript/WebGL/Const.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/JavaScript/WebGL/Const.hs @@ -0,0 +1,886 @@ +module FWGL.Backend.JavaScript.WebGL.Const where + +gl_DEPTH_BUFFER_BIT :: Num a => a +gl_DEPTH_BUFFER_BIT = 0x00000100 + +gl_STENCIL_BUFFER_BIT :: Num a => a +gl_STENCIL_BUFFER_BIT = 0x00000400 + +gl_COLOR_BUFFER_BIT :: Num a => a +gl_COLOR_BUFFER_BIT = 0x00004000 + +gl_POINTS :: Num a => a +gl_POINTS = 0x0000 + +gl_LINES :: Num a => a +gl_LINES = 0x0001 + +gl_LINE_LOOP :: Num a => a +gl_LINE_LOOP = 0x0002 + +gl_LINE_STRIP :: Num a => a +gl_LINE_STRIP = 0x0003 + +gl_TRIANGLES :: Num a => a +gl_TRIANGLES = 0x0004 + +gl_TRIANGLE_STRIP :: Num a => a +gl_TRIANGLE_STRIP = 0x0005 + +gl_TRIANGLE_FAN :: Num a => a +gl_TRIANGLE_FAN = 0x0006 + +gl_ZERO :: Num a => a +gl_ZERO = 0 + +gl_ONE :: Num a => a +gl_ONE = 1 + +gl_SRC_COLOR :: Num a => a +gl_SRC_COLOR = 0x0300 + +gl_ONE_MINUS_SRC_COLOR :: Num a => a +gl_ONE_MINUS_SRC_COLOR = 0x0301 + +gl_SRC_ALPHA :: Num a => a +gl_SRC_ALPHA = 0x0302 + +gl_ONE_MINUS_SRC_ALPHA :: Num a => a +gl_ONE_MINUS_SRC_ALPHA = 0x0303 + +gl_DST_ALPHA :: Num a => a +gl_DST_ALPHA = 0x0304 + +gl_ONE_MINUS_DST_ALPHA :: Num a => a +gl_ONE_MINUS_DST_ALPHA = 0x0305 + +gl_DST_COLOR :: Num a => a +gl_DST_COLOR = 0x0306 + +gl_ONE_MINUS_DST_COLOR :: Num a => a +gl_ONE_MINUS_DST_COLOR = 0x0307 + +gl_SRC_ALPHA_SATURATE :: Num a => a +gl_SRC_ALPHA_SATURATE = 0x0308 + +gl_FUNC_ADD :: Num a => a +gl_FUNC_ADD = 0x8006 + +gl_BLEND_EQUATION :: Num a => a +gl_BLEND_EQUATION = 0x8009 + +gl_BLEND_EQUATION_RGB :: Num a => a +gl_BLEND_EQUATION_RGB = 0x8009 + +gl_BLEND_EQUATION_ALPHA :: Num a => a +gl_BLEND_EQUATION_ALPHA = 0x883D + +gl_FUNC_SUBTRACT :: Num a => a +gl_FUNC_SUBTRACT = 0x800A + +gl_FUNC_REVERSE_SUBTRACT :: Num a => a +gl_FUNC_REVERSE_SUBTRACT = 0x800B + +gl_BLEND_DST_RGB :: Num a => a +gl_BLEND_DST_RGB = 0x80C8 + +gl_BLEND_SRC_RGB :: Num a => a +gl_BLEND_SRC_RGB = 0x80C9 + +gl_BLEND_DST_ALPHA :: Num a => a +gl_BLEND_DST_ALPHA = 0x80CA + +gl_BLEND_SRC_ALPHA :: Num a => a +gl_BLEND_SRC_ALPHA = 0x80CB + +gl_CONSTANT_COLOR :: Num a => a +gl_CONSTANT_COLOR = 0x8001 + +gl_ONE_MINUS_CONSTANT_COLOR :: Num a => a +gl_ONE_MINUS_CONSTANT_COLOR = 0x8002 + +gl_CONSTANT_ALPHA :: Num a => a +gl_CONSTANT_ALPHA = 0x8003 + +gl_ONE_MINUS_CONSTANT_ALPHA :: Num a => a +gl_ONE_MINUS_CONSTANT_ALPHA = 0x8004 + +gl_BLEND_COLOR :: Num a => a +gl_BLEND_COLOR = 0x8005 + +gl_ARRAY_BUFFER :: Num a => a +gl_ARRAY_BUFFER = 0x8892 + +gl_ELEMENT_ARRAY_BUFFER :: Num a => a +gl_ELEMENT_ARRAY_BUFFER = 0x8893 + +gl_ARRAY_BUFFER_BINDING :: Num a => a +gl_ARRAY_BUFFER_BINDING = 0x8894 + +gl_ELEMENT_ARRAY_BUFFER_BINDING :: Num a => a +gl_ELEMENT_ARRAY_BUFFER_BINDING = 0x8895 + +gl_STREAM_DRAW :: Num a => a +gl_STREAM_DRAW = 0x88E0 + +gl_STATIC_DRAW :: Num a => a +gl_STATIC_DRAW = 0x88E4 + +gl_DYNAMIC_DRAW :: Num a => a +gl_DYNAMIC_DRAW = 0x88E8 + +gl_BUFFER_SIZE :: Num a => a +gl_BUFFER_SIZE = 0x8764 + +gl_BUFFER_USAGE :: Num a => a +gl_BUFFER_USAGE = 0x8765 + +gl_CURRENT_VERTEX_ATTRIB :: Num a => a +gl_CURRENT_VERTEX_ATTRIB = 0x8626 + +gl_FRONT :: Num a => a +gl_FRONT = 0x0404 + +gl_BACK :: Num a => a +gl_BACK = 0x0405 + +gl_FRONT_AND_BACK :: Num a => a +gl_FRONT_AND_BACK = 0x0408 + +gl_CULL_FACE :: Num a => a +gl_CULL_FACE = 0x0B44 + +gl_BLEND :: Num a => a +gl_BLEND = 0x0BE2 + +gl_DITHER :: Num a => a +gl_DITHER = 0x0BD0 + +gl_STENCIL_TEST :: Num a => a +gl_STENCIL_TEST = 0x0B90 + +gl_DEPTH_TEST :: Num a => a +gl_DEPTH_TEST = 0x0B71 + +gl_SCISSOR_TEST :: Num a => a +gl_SCISSOR_TEST = 0x0C11 + +gl_POLYGON_OFFSET_FILL :: Num a => a +gl_POLYGON_OFFSET_FILL = 0x8037 + +gl_SAMPLE_ALPHA_TO_COVERAGE :: Num a => a +gl_SAMPLE_ALPHA_TO_COVERAGE = 0x809E + +gl_SAMPLE_COVERAGE :: Num a => a +gl_SAMPLE_COVERAGE = 0x80A0 + +gl_NO_ERROR :: Num a => a +gl_NO_ERROR = 0 + +gl_INVALID_ENUM :: Num a => a +gl_INVALID_ENUM = 0x0500 + +gl_INVALID_VALUE :: Num a => a +gl_INVALID_VALUE = 0x0501 + +gl_INVALID_OPERATION :: Num a => a +gl_INVALID_OPERATION = 0x0502 + +gl_OUT_OF_MEMORY :: Num a => a +gl_OUT_OF_MEMORY = 0x0505 + +gl_CW :: Num a => a +gl_CW = 0x0900 + +gl_CCW :: Num a => a +gl_CCW = 0x0901 + +gl_LINE_WIDTH :: Num a => a +gl_LINE_WIDTH = 0x0B21 + +gl_ALIASED_POINT_SIZE_RANGE :: Num a => a +gl_ALIASED_POINT_SIZE_RANGE = 0x846D + +gl_ALIASED_LINE_WIDTH_RANGE :: Num a => a +gl_ALIASED_LINE_WIDTH_RANGE = 0x846E + +gl_CULL_FACE_MODE :: Num a => a +gl_CULL_FACE_MODE = 0x0B45 + +gl_FRONT_FACE :: Num a => a +gl_FRONT_FACE = 0x0B46 + +gl_DEPTH_RANGE :: Num a => a +gl_DEPTH_RANGE = 0x0B70 + +gl_DEPTH_WRITEMASK :: Num a => a +gl_DEPTH_WRITEMASK = 0x0B72 + +gl_DEPTH_CLEAR_VALUE :: Num a => a +gl_DEPTH_CLEAR_VALUE = 0x0B73 + +gl_DEPTH_FUNC :: Num a => a +gl_DEPTH_FUNC = 0x0B74 + +gl_STENCIL_CLEAR_VALUE :: Num a => a +gl_STENCIL_CLEAR_VALUE = 0x0B91 + +gl_STENCIL_FUNC :: Num a => a +gl_STENCIL_FUNC = 0x0B92 + +gl_STENCIL_FAIL :: Num a => a +gl_STENCIL_FAIL = 0x0B94 + +gl_STENCIL_PASS_DEPTH_FAIL :: Num a => a +gl_STENCIL_PASS_DEPTH_FAIL = 0x0B95 + +gl_STENCIL_PASS_DEPTH_PASS :: Num a => a +gl_STENCIL_PASS_DEPTH_PASS = 0x0B96 + +gl_STENCIL_REF :: Num a => a +gl_STENCIL_REF = 0x0B97 + +gl_STENCIL_VALUE_MASK :: Num a => a +gl_STENCIL_VALUE_MASK = 0x0B93 + +gl_STENCIL_WRITEMASK :: Num a => a +gl_STENCIL_WRITEMASK = 0x0B98 + +gl_STENCIL_BACK_FUNC :: Num a => a +gl_STENCIL_BACK_FUNC = 0x8800 + +gl_STENCIL_BACK_FAIL :: Num a => a +gl_STENCIL_BACK_FAIL = 0x8801 + +gl_STENCIL_BACK_PASS_DEPTH_FAIL :: Num a => a +gl_STENCIL_BACK_PASS_DEPTH_FAIL = 0x8802 + +gl_STENCIL_BACK_PASS_DEPTH_PASS :: Num a => a +gl_STENCIL_BACK_PASS_DEPTH_PASS = 0x8803 + +gl_STENCIL_BACK_REF :: Num a => a +gl_STENCIL_BACK_REF = 0x8CA3 + +gl_STENCIL_BACK_VALUE_MASK :: Num a => a +gl_STENCIL_BACK_VALUE_MASK = 0x8CA4 + +gl_STENCIL_BACK_WRITEMASK :: Num a => a +gl_STENCIL_BACK_WRITEMASK = 0x8CA5 + +gl_VIEWPORT :: Num a => a +gl_VIEWPORT = 0x0BA2 + +gl_SCISSOR_BOX :: Num a => a +gl_SCISSOR_BOX = 0x0C10 + +gl_COLOR_CLEAR_VALUE :: Num a => a +gl_COLOR_CLEAR_VALUE = 0x0C22 + +gl_COLOR_WRITEMASK :: Num a => a +gl_COLOR_WRITEMASK = 0x0C23 + +gl_UNPACK_ALIGNMENT :: Num a => a +gl_UNPACK_ALIGNMENT = 0x0CF5 + +gl_PACK_ALIGNMENT :: Num a => a +gl_PACK_ALIGNMENT = 0x0D05 + +gl_MAX_TEXTURE_SIZE :: Num a => a +gl_MAX_TEXTURE_SIZE = 0x0D33 + +gl_MAX_VIEWPORT_DIMS :: Num a => a +gl_MAX_VIEWPORT_DIMS = 0x0D3A + +gl_SUBPIXEL_BITS :: Num a => a +gl_SUBPIXEL_BITS = 0x0D50 + +gl_RED_BITS :: Num a => a +gl_RED_BITS = 0x0D52 + +gl_GREEN_BITS :: Num a => a +gl_GREEN_BITS = 0x0D53 + +gl_BLUE_BITS :: Num a => a +gl_BLUE_BITS = 0x0D54 + +gl_ALPHA_BITS :: Num a => a +gl_ALPHA_BITS = 0x0D55 + +gl_DEPTH_BITS :: Num a => a +gl_DEPTH_BITS = 0x0D56 + +gl_STENCIL_BITS :: Num a => a +gl_STENCIL_BITS = 0x0D57 + +gl_POLYGON_OFFSET_UNITS :: Num a => a +gl_POLYGON_OFFSET_UNITS = 0x2A00 + +gl_POLYGON_OFFSET_FACTOR :: Num a => a +gl_POLYGON_OFFSET_FACTOR = 0x8038 + +gl_TEXTURE_BINDING_2D :: Num a => a +gl_TEXTURE_BINDING_2D = 0x8069 + +gl_SAMPLE_BUFFERS :: Num a => a +gl_SAMPLE_BUFFERS = 0x80A8 + +gl_SAMPLES :: Num a => a +gl_SAMPLES = 0x80A9 + +gl_SAMPLE_COVERAGE_VALUE :: Num a => a +gl_SAMPLE_COVERAGE_VALUE = 0x80AA + +gl_SAMPLE_COVERAGE_INVERT :: Num a => a +gl_SAMPLE_COVERAGE_INVERT = 0x80AB + +gl_COMPRESSED_TEXTURE_FORMATS :: Num a => a +gl_COMPRESSED_TEXTURE_FORMATS = 0x86A3 + +gl_DONT_CARE :: Num a => a +gl_DONT_CARE = 0x1100 + +gl_FASTEST :: Num a => a +gl_FASTEST = 0x1101 + +gl_NICEST :: Num a => a +gl_NICEST = 0x1102 + +gl_GENERATE_MIPMAP_HINT :: Num a => a +gl_GENERATE_MIPMAP_HINT = 0x8192 + +gl_BYTE :: Num a => a +gl_BYTE = 0x1400 + +gl_UNSIGNED_BYTE :: Num a => a +gl_UNSIGNED_BYTE = 0x1401 + +gl_SHORT :: Num a => a +gl_SHORT = 0x1402 + +gl_UNSIGNED_SHORT :: Num a => a +gl_UNSIGNED_SHORT = 0x1403 + +gl_INT :: Num a => a +gl_INT = 0x1404 + +gl_UNSIGNED_INT :: Num a => a +gl_UNSIGNED_INT = 0x1405 + +gl_FLOAT :: Num a => a +gl_FLOAT = 0x1406 + +gl_DEPTH_COMPONENT :: Num a => a +gl_DEPTH_COMPONENT = 0x1902 + +gl_ALPHA :: Num a => a +gl_ALPHA = 0x1906 + +gl_RGB :: Num a => a +gl_RGB = 0x1907 + +gl_RGBA :: Num a => a +gl_RGBA = 0x1908 + +gl_LUMINANCE :: Num a => a +gl_LUMINANCE = 0x1909 + +gl_LUMINANCE_ALPHA :: Num a => a +gl_LUMINANCE_ALPHA = 0x190A + +gl_UNSIGNED_SHORT_4_4_4_4 :: Num a => a +gl_UNSIGNED_SHORT_4_4_4_4 = 0x8033 + +gl_UNSIGNED_SHORT_5_5_5_1 :: Num a => a +gl_UNSIGNED_SHORT_5_5_5_1 = 0x8034 + +gl_UNSIGNED_SHORT_5_6_5 :: Num a => a +gl_UNSIGNED_SHORT_5_6_5 = 0x8363 + +gl_FRAGMENT_SHADER :: Num a => a +gl_FRAGMENT_SHADER = 0x8B30 + +gl_VERTEX_SHADER :: Num a => a +gl_VERTEX_SHADER = 0x8B31 + +gl_MAX_VERTEX_ATTRIBS :: Num a => a +gl_MAX_VERTEX_ATTRIBS = 0x8869 + +gl_MAX_VERTEX_UNIFORM_VECTORS :: Num a => a +gl_MAX_VERTEX_UNIFORM_VECTORS = 0x8DFB + +gl_MAX_VARYING_VECTORS :: Num a => a +gl_MAX_VARYING_VECTORS = 0x8DFC + +gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS :: Num a => a +gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS = 0x8B4D + +gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS :: Num a => a +gl_MAX_VERTEX_TEXTURE_IMAGE_UNITS = 0x8B4C + +gl_MAX_TEXTURE_IMAGE_UNITS :: Num a => a +gl_MAX_TEXTURE_IMAGE_UNITS = 0x8872 + +gl_MAX_FRAGMENT_UNIFORM_VECTORS :: Num a => a +gl_MAX_FRAGMENT_UNIFORM_VECTORS = 0x8DFD + +gl_SHADER_TYPE :: Num a => a +gl_SHADER_TYPE = 0x8B4F + +gl_DELETE_STATUS :: Num a => a +gl_DELETE_STATUS = 0x8B80 + +gl_LINK_STATUS :: Num a => a +gl_LINK_STATUS = 0x8B82 + +gl_VALIDATE_STATUS :: Num a => a +gl_VALIDATE_STATUS = 0x8B83 + +gl_ATTACHED_SHADERS :: Num a => a +gl_ATTACHED_SHADERS = 0x8B85 + +gl_ACTIVE_UNIFORMS :: Num a => a +gl_ACTIVE_UNIFORMS = 0x8B86 + +gl_ACTIVE_ATTRIBUTES :: Num a => a +gl_ACTIVE_ATTRIBUTES = 0x8B89 + +gl_SHADING_LANGUAGE_VERSION :: Num a => a +gl_SHADING_LANGUAGE_VERSION = 0x8B8C + +gl_CURRENT_PROGRAM :: Num a => a +gl_CURRENT_PROGRAM = 0x8B8D + +gl_NEVER :: Num a => a +gl_NEVER = 0x0200 + +gl_LESS :: Num a => a +gl_LESS = 0x0201 + +gl_EQUAL :: Num a => a +gl_EQUAL = 0x0202 + +gl_LEQUAL :: Num a => a +gl_LEQUAL = 0x0203 + +gl_GREATER :: Num a => a +gl_GREATER = 0x0204 + +gl_NOTEQUAL :: Num a => a +gl_NOTEQUAL = 0x0205 + +gl_GEQUAL :: Num a => a +gl_GEQUAL = 0x0206 + +gl_ALWAYS :: Num a => a +gl_ALWAYS = 0x0207 + +gl_KEEP :: Num a => a +gl_KEEP = 0x1E00 + +gl_REPLACE :: Num a => a +gl_REPLACE = 0x1E01 + +gl_INCR :: Num a => a +gl_INCR = 0x1E02 + +gl_DECR :: Num a => a +gl_DECR = 0x1E03 + +gl_INVERT :: Num a => a +gl_INVERT = 0x150A + +gl_INCR_WRAP :: Num a => a +gl_INCR_WRAP = 0x8507 + +gl_DECR_WRAP :: Num a => a +gl_DECR_WRAP = 0x8508 + +gl_VENDOR :: Num a => a +gl_VENDOR = 0x1F00 + +gl_RENDERER :: Num a => a +gl_RENDERER = 0x1F01 + +gl_VERSION :: Num a => a +gl_VERSION = 0x1F02 + +gl_NEAREST :: Num a => a +gl_NEAREST = 0x2600 + +gl_LINEAR :: Num a => a +gl_LINEAR = 0x2601 + +gl_NEAREST_MIPMAP_NEAREST :: Num a => a +gl_NEAREST_MIPMAP_NEAREST = 0x2700 + +gl_LINEAR_MIPMAP_NEAREST :: Num a => a +gl_LINEAR_MIPMAP_NEAREST = 0x2701 + +gl_NEAREST_MIPMAP_LINEAR :: Num a => a +gl_NEAREST_MIPMAP_LINEAR = 0x2702 + +gl_LINEAR_MIPMAP_LINEAR :: Num a => a +gl_LINEAR_MIPMAP_LINEAR = 0x2703 + +gl_TEXTURE_MAG_FILTER :: Num a => a +gl_TEXTURE_MAG_FILTER = 0x2800 + +gl_TEXTURE_MIN_FILTER :: Num a => a +gl_TEXTURE_MIN_FILTER = 0x2801 + +gl_TEXTURE_WRAP_S :: Num a => a +gl_TEXTURE_WRAP_S = 0x2802 + +gl_TEXTURE_WRAP_T :: Num a => a +gl_TEXTURE_WRAP_T = 0x2803 + +gl_TEXTURE_2D :: Num a => a +gl_TEXTURE_2D = 0x0DE1 + +gl_TEXTURE :: Num a => a +gl_TEXTURE = 0x1702 + +gl_TEXTURE_CUBE_MAP :: Num a => a +gl_TEXTURE_CUBE_MAP = 0x8513 + +gl_TEXTURE_BINDING_CUBE_MAP :: Num a => a +gl_TEXTURE_BINDING_CUBE_MAP = 0x8514 + +gl_TEXTURE_CUBE_MAP_POSITIVE_X :: Num a => a +gl_TEXTURE_CUBE_MAP_POSITIVE_X = 0x8515 + +gl_TEXTURE_CUBE_MAP_NEGATIVE_X :: Num a => a +gl_TEXTURE_CUBE_MAP_NEGATIVE_X = 0x8516 + +gl_TEXTURE_CUBE_MAP_POSITIVE_Y :: Num a => a +gl_TEXTURE_CUBE_MAP_POSITIVE_Y = 0x8517 + +gl_TEXTURE_CUBE_MAP_NEGATIVE_Y :: Num a => a +gl_TEXTURE_CUBE_MAP_NEGATIVE_Y = 0x8518 + +gl_TEXTURE_CUBE_MAP_POSITIVE_Z :: Num a => a +gl_TEXTURE_CUBE_MAP_POSITIVE_Z = 0x8519 + +gl_TEXTURE_CUBE_MAP_NEGATIVE_Z :: Num a => a +gl_TEXTURE_CUBE_MAP_NEGATIVE_Z = 0x851A + +gl_MAX_CUBE_MAP_TEXTURE_SIZE :: Num a => a +gl_MAX_CUBE_MAP_TEXTURE_SIZE = 0x851C + +gl_TEXTURE0 :: Num a => a +gl_TEXTURE0 = 0x84C0 + +gl_TEXTURE1 :: Num a => a +gl_TEXTURE1 = 0x84C1 + +gl_TEXTURE2 :: Num a => a +gl_TEXTURE2 = 0x84C2 + +gl_TEXTURE3 :: Num a => a +gl_TEXTURE3 = 0x84C3 + +gl_TEXTURE4 :: Num a => a +gl_TEXTURE4 = 0x84C4 + +gl_TEXTURE5 :: Num a => a +gl_TEXTURE5 = 0x84C5 + +gl_TEXTURE6 :: Num a => a +gl_TEXTURE6 = 0x84C6 + +gl_TEXTURE7 :: Num a => a +gl_TEXTURE7 = 0x84C7 + +gl_TEXTURE8 :: Num a => a +gl_TEXTURE8 = 0x84C8 + +gl_TEXTURE9 :: Num a => a +gl_TEXTURE9 = 0x84C9 + +gl_TEXTURE10 :: Num a => a +gl_TEXTURE10 = 0x84CA + +gl_TEXTURE11 :: Num a => a +gl_TEXTURE11 = 0x84CB + +gl_TEXTURE12 :: Num a => a +gl_TEXTURE12 = 0x84CC + +gl_TEXTURE13 :: Num a => a +gl_TEXTURE13 = 0x84CD + +gl_TEXTURE14 :: Num a => a +gl_TEXTURE14 = 0x84CE + +gl_TEXTURE15 :: Num a => a +gl_TEXTURE15 = 0x84CF + +gl_TEXTURE16 :: Num a => a +gl_TEXTURE16 = 0x84D0 + +gl_TEXTURE17 :: Num a => a +gl_TEXTURE17 = 0x84D1 + +gl_TEXTURE18 :: Num a => a +gl_TEXTURE18 = 0x84D2 + +gl_TEXTURE19 :: Num a => a +gl_TEXTURE19 = 0x84D3 + +gl_TEXTURE20 :: Num a => a +gl_TEXTURE20 = 0x84D4 + +gl_TEXTURE21 :: Num a => a +gl_TEXTURE21 = 0x84D5 + +gl_TEXTURE22 :: Num a => a +gl_TEXTURE22 = 0x84D6 + +gl_TEXTURE23 :: Num a => a +gl_TEXTURE23 = 0x84D7 + +gl_TEXTURE24 :: Num a => a +gl_TEXTURE24 = 0x84D8 + +gl_TEXTURE25 :: Num a => a +gl_TEXTURE25 = 0x84D9 + +gl_TEXTURE26 :: Num a => a +gl_TEXTURE26 = 0x84DA + +gl_TEXTURE27 :: Num a => a +gl_TEXTURE27 = 0x84DB + +gl_TEXTURE28 :: Num a => a +gl_TEXTURE28 = 0x84DC + +gl_TEXTURE29 :: Num a => a +gl_TEXTURE29 = 0x84DD + +gl_TEXTURE30 :: Num a => a +gl_TEXTURE30 = 0x84DE + +gl_TEXTURE31 :: Num a => a +gl_TEXTURE31 = 0x84DF + +gl_ACTIVE_TEXTURE :: Num a => a +gl_ACTIVE_TEXTURE = 0x84E0 + +gl_REPEAT :: Num a => a +gl_REPEAT = 0x2901 + +gl_CLAMP_TO_EDGE :: Num a => a +gl_CLAMP_TO_EDGE = 0x812F + +gl_MIRRORED_REPEAT :: Num a => a +gl_MIRRORED_REPEAT = 0x8370 + +gl_FLOAT_VEC2 :: Num a => a +gl_FLOAT_VEC2 = 0x8B50 + +gl_FLOAT_VEC3 :: Num a => a +gl_FLOAT_VEC3 = 0x8B51 + +gl_FLOAT_VEC4 :: Num a => a +gl_FLOAT_VEC4 = 0x8B52 + +gl_INT_VEC2 :: Num a => a +gl_INT_VEC2 = 0x8B53 + +gl_INT_VEC3 :: Num a => a +gl_INT_VEC3 = 0x8B54 + +gl_INT_VEC4 :: Num a => a +gl_INT_VEC4 = 0x8B55 + +gl_BOOL :: Num a => a +gl_BOOL = 0x8B56 + +gl_BOOL_VEC2 :: Num a => a +gl_BOOL_VEC2 = 0x8B57 + +gl_BOOL_VEC3 :: Num a => a +gl_BOOL_VEC3 = 0x8B58 + +gl_BOOL_VEC4 :: Num a => a +gl_BOOL_VEC4 = 0x8B59 + +gl_FLOAT_MAT2 :: Num a => a +gl_FLOAT_MAT2 = 0x8B5A + +gl_FLOAT_MAT3 :: Num a => a +gl_FLOAT_MAT3 = 0x8B5B + +gl_FLOAT_MAT4 :: Num a => a +gl_FLOAT_MAT4 = 0x8B5C + +gl_SAMPLER_2D :: Num a => a +gl_SAMPLER_2D = 0x8B5E + +gl_SAMPLER_CUBE :: Num a => a +gl_SAMPLER_CUBE = 0x8B60 + +gl_VERTEX_ATTRIB_ARRAY_ENABLED :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_ENABLED = 0x8622 + +gl_VERTEX_ATTRIB_ARRAY_SIZE :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_SIZE = 0x8623 + +gl_VERTEX_ATTRIB_ARRAY_STRIDE :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_STRIDE = 0x8624 + +gl_VERTEX_ATTRIB_ARRAY_TYPE :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_TYPE = 0x8625 + +gl_VERTEX_ATTRIB_ARRAY_NORMALIZED :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_NORMALIZED = 0x886A + +gl_VERTEX_ATTRIB_ARRAY_POINTER :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_POINTER = 0x8645 + +gl_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING :: Num a => a +gl_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING = 0x889F + +gl_COMPILE_STATUS :: Num a => a +gl_COMPILE_STATUS = 0x8B81 + +gl_LOW_FLOAT :: Num a => a +gl_LOW_FLOAT = 0x8DF0 + +gl_MEDIUM_FLOAT :: Num a => a +gl_MEDIUM_FLOAT = 0x8DF1 + +gl_HIGH_FLOAT :: Num a => a +gl_HIGH_FLOAT = 0x8DF2 + +gl_LOW_INT :: Num a => a +gl_LOW_INT = 0x8DF3 + +gl_MEDIUM_INT :: Num a => a +gl_MEDIUM_INT = 0x8DF4 + +gl_HIGH_INT :: Num a => a +gl_HIGH_INT = 0x8DF5 + +gl_FRAMEBUFFER :: Num a => a +gl_FRAMEBUFFER = 0x8D40 + +gl_RENDERBUFFER :: Num a => a +gl_RENDERBUFFER = 0x8D41 + +gl_RGBA4 :: Num a => a +gl_RGBA4 = 0x8056 + +gl_RGB5_A1 :: Num a => a +gl_RGB5_A1 = 0x8057 + +gl_RGB565 :: Num a => a +gl_RGB565 = 0x8D62 + +gl_DEPTH_COMPONENT16 :: Num a => a +gl_DEPTH_COMPONENT16 = 0x81A5 + +gl_STENCIL_INDEX :: Num a => a +gl_STENCIL_INDEX = 0x1901 + +gl_STENCIL_INDEX8 :: Num a => a +gl_STENCIL_INDEX8 = 0x8D48 + +gl_DEPTH_STENCIL :: Num a => a +gl_DEPTH_STENCIL = 0x84F9 + +gl_RENDERBUFFER_WIDTH :: Num a => a +gl_RENDERBUFFER_WIDTH = 0x8D42 + +gl_RENDERBUFFER_HEIGHT :: Num a => a +gl_RENDERBUFFER_HEIGHT = 0x8D43 + +gl_RENDERBUFFER_INTERNAL_FORMAT :: Num a => a +gl_RENDERBUFFER_INTERNAL_FORMAT = 0x8D44 + +gl_RENDERBUFFER_RED_SIZE :: Num a => a +gl_RENDERBUFFER_RED_SIZE = 0x8D50 + +gl_RENDERBUFFER_GREEN_SIZE :: Num a => a +gl_RENDERBUFFER_GREEN_SIZE = 0x8D51 + +gl_RENDERBUFFER_BLUE_SIZE :: Num a => a +gl_RENDERBUFFER_BLUE_SIZE = 0x8D52 + +gl_RENDERBUFFER_ALPHA_SIZE :: Num a => a +gl_RENDERBUFFER_ALPHA_SIZE = 0x8D53 + +gl_RENDERBUFFER_DEPTH_SIZE :: Num a => a +gl_RENDERBUFFER_DEPTH_SIZE = 0x8D54 + +gl_RENDERBUFFER_STENCIL_SIZE :: Num a => a +gl_RENDERBUFFER_STENCIL_SIZE = 0x8D55 + +gl_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE :: Num a => a +gl_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE = 0x8CD0 + +gl_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME :: Num a => a +gl_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME = 0x8CD1 + +gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL :: Num a => a +gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL = 0x8CD2 + +gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE :: Num a => a +gl_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE = 0x8CD3 + +gl_COLOR_ATTACHMENT0 :: Num a => a +gl_COLOR_ATTACHMENT0 = 0x8CE0 + +gl_DEPTH_ATTACHMENT :: Num a => a +gl_DEPTH_ATTACHMENT = 0x8D00 + +gl_STENCIL_ATTACHMENT :: Num a => a +gl_STENCIL_ATTACHMENT = 0x8D20 + +gl_DEPTH_STENCIL_ATTACHMENT :: Num a => a +gl_DEPTH_STENCIL_ATTACHMENT = 0x821A + +gl_NONE :: Num a => a +gl_NONE = 0 + +gl_FRAMEBUFFER_COMPLETE :: Num a => a +gl_FRAMEBUFFER_COMPLETE = 0x8CD5 + +gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT :: Num a => a +gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = 0x8CD6 + +gl_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT :: Num a => a +gl_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT = 0x8CD7 + +gl_FRAMEBUFFER_INCOMPLETE_DIMENSIONS :: Num a => a +gl_FRAMEBUFFER_INCOMPLETE_DIMENSIONS = 0x8CD9 + +gl_FRAMEBUFFER_UNSUPPORTED :: Num a => a +gl_FRAMEBUFFER_UNSUPPORTED = 0x8CDD + +gl_FRAMEBUFFER_BINDING :: Num a => a +gl_FRAMEBUFFER_BINDING = 0x8CA6 + +gl_RENDERBUFFER_BINDING :: Num a => a +gl_RENDERBUFFER_BINDING = 0x8CA7 + +gl_MAX_RENDERBUFFER_SIZE :: Num a => a +gl_MAX_RENDERBUFFER_SIZE = 0x84E8 + +gl_INVALID_FRAMEBUFFER_OPERATION :: Num a => a +gl_INVALID_FRAMEBUFFER_OPERATION = 0x0506 + +gl_UNPACK_FLIP_Y_WEBGL :: Num a => a +gl_UNPACK_FLIP_Y_WEBGL = 0x9240 + +gl_UNPACK_PREMULTIPLY_ALPHA_WEBGL :: Num a => a +gl_UNPACK_PREMULTIPLY_ALPHA_WEBGL = 0x9241 + +gl_CONTEXT_LOST_WEBGL :: Num a => a +gl_CONTEXT_LOST_WEBGL = 0x9242 + +gl_UNPACK_COLORSPACE_CONVERSION_WEBGL :: Num a => a +gl_UNPACK_COLORSPACE_CONVERSION_WEBGL = 0x9243 + +gl_BROWSER_DEFAULT_WEBGL :: Num a => a +gl_BROWSER_DEFAULT_WEBGL = 0x9244 diff --git a/FWGL/Backend/JavaScript/WebGL/Raw.hs b/FWGL/Backend/JavaScript/WebGL/Raw.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/JavaScript/WebGL/Raw.hs @@ -0,0 +1,514 @@ +module FWGL.Backend.JavaScript.WebGL.Raw where + +import Data.Int +import Data.Word + +import GHCJS.Types + +import FWGL.Backend.JavaScript.WebGL.Types + +foreign import javascript unsafe "$1.activeTexture($2)" + glActiveTexture :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.attachShader($2, $3)" + glAttachShader :: Ctx -> Program -> Shader -> IO () + +foreign import javascript unsafe "$1.bindAttribLocation($2, $3, $4)" + glBindAttribLocation :: Ctx -> Program -> Word -> JSString -> IO () + +foreign import javascript unsafe "$1.bindBuffer($2, $3)" + glBindBuffer :: Ctx -> Word -> Buffer -> IO () + +foreign import javascript unsafe "$1.bindFramebuffer($2, $3)" + glBindFramebuffer :: Ctx -> Word -> FrameBuffer -> IO () + +foreign import javascript unsafe "$1.bindRenderbuffer($2, $3)" + glBindRenderbuffer :: Ctx -> Word -> RenderBuffer -> IO () + +foreign import javascript unsafe "$1.bindTexture($2, $3)" + glBindTexture :: Ctx -> Word -> Texture -> IO () + +foreign import javascript unsafe "$1.blendColor($2, $3, $4, $5)" + glBlendColor :: Ctx -> Float -> Float -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.blendEquation($2)" + glBlendEquation :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.blendEquationSeparate($2, $3)" + glBlendEquationSeparate :: Ctx -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.blendFunc($2, $3)" + glBlendFunc :: Ctx -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.blendFuncSeparate($2, $3, $4, $5)" + glBlendFuncSeparate :: Ctx -> Word -> Word -> Word -> Word -> IO () + +{- +foreign import javascript unsafe "$1.bufferData($2, $3, $4)" + glBufferData :: Ctx -> Word -> Word -> Word -> IO () +-} + +foreign import javascript unsafe "$1.bufferData($2, $3, $4)" + glBufferData :: Ctx -> Word -> ArrayBufferView -> Word -> IO () + +{- +foreign import javascript unsafe "$1.bufferData($2, $3, $4)" + glBufferData :: Ctx -> Word -> ArrayBuffer -> Word -> IO () +-} + +foreign import javascript unsafe "$1.bufferSubData($2, $3, $4)" + glBufferSubData :: Ctx -> Word -> Word -> ArrayBufferView -> IO () + +{- +foreign import javascript unsafe "$1.bufferSubData($2, $3, $4)" + glBufferSubData :: Ctx -> Word -> Word -> ArrayBuffer -> IO () +-} + +foreign import javascript unsafe "$1.checkFramebufferStatus($2)" + glCheckFramebufferStatus :: Ctx -> Word -> IO Word + +foreign import javascript unsafe "$1.clear($2)" + glClear :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.clearColor($2, $3, $4, $5)" + glClearColor :: Ctx -> Float -> Float -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.clearDepth($2)" + glClearDepth :: Ctx -> Float -> IO () + +foreign import javascript unsafe "$1.clearStencil($2)" + glClearStencil :: Ctx -> Int -> IO () + +foreign import javascript unsafe "$1.colorMask($2, $3, $4, $5)" + glColorMask :: Ctx -> Bool -> Bool -> Bool -> Bool -> IO () + +foreign import javascript unsafe "$1.compileShader($2)" + glCompileShader :: Ctx -> Shader -> IO () + +foreign import javascript unsafe "$1.compressedTexImage2D($2, $3, $4, $5, $6, $7, $8)" + glCompressedTexImage2D :: Ctx -> Word -> Int -> Word -> Int -> Int -> Int -> ArrayBufferView -> IO () + +foreign import javascript unsafe "$1.compressedTexSubImage2D($2, $3, $4, $5, $6, $7, $8, $9)" + glCompressedTexSubImage2D :: Ctx -> Word -> Int -> Int -> Int -> Int -> Int -> Word -> ArrayBufferView -> IO () + +foreign import javascript unsafe "$1.copyTexImage2D($2, $3, $4, $5, $6, $7, $8, $9)" + glCopyTexImage2D :: Ctx -> Word -> Int -> Word -> Int -> Int -> Int -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.copyTexSubImage2D($2, $3, $4, $5, $6, $7, $8, $9)" + glCopyTexSubImage2D :: Ctx -> Word -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.createBuffer()" + glCreateBuffer :: Ctx -> IO Buffer + +foreign import javascript unsafe "$1.createFramebuffer()" + glCreateFramebuffer :: Ctx -> IO FrameBuffer + +foreign import javascript unsafe "$1.createProgram()" + glCreateProgram :: Ctx -> IO Program + +foreign import javascript unsafe "$1.createRenderbuffer()" + glCreateRenderbuffer :: Ctx -> IO RenderBuffer + +foreign import javascript unsafe "$1.createShader($2)" + glCreateShader :: Ctx -> Word -> IO Shader + +foreign import javascript unsafe "$1.createTexture()" + glCreateTexture :: Ctx -> IO Texture + +foreign import javascript unsafe "$1.cullFace($2)" + glCullFace :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.deleteBuffer($2)" + glDeleteBuffer :: Ctx -> Buffer -> IO () + +foreign import javascript unsafe "$1.deleteFramebuffer($2)" + glDeleteFramebuffer :: Ctx -> FrameBuffer -> IO () + +foreign import javascript unsafe "$1.deleteProgram($2)" + glDeleteProgram :: Ctx -> Program -> IO () + +foreign import javascript unsafe "$1.deleteRenderbuffer($2)" + glDeleteRenderbuffer :: Ctx -> RenderBuffer -> IO () + +foreign import javascript unsafe "$1.deleteShader($2)" + glDeleteShader :: Ctx -> Shader -> IO () + +foreign import javascript unsafe "$1.deleteTexture($2)" + glDeleteTexture :: Ctx -> Texture -> IO () + +foreign import javascript unsafe "$1.depthFunc($2)" + glDepthFunc :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.depthMask($2)" + glDepthMask :: Ctx -> Bool -> IO () + +foreign import javascript unsafe "$1.depthRange($2, $3)" + glDepthRange :: Ctx -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.detachShader($2, $3)" + glDetachShader :: Ctx -> Program -> Shader -> IO () + +foreign import javascript unsafe "$1.disable($2)" + glDisable :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.disableVertexAttribArray($2)" + glDisableVertexAttribArray :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.drawArrays($2, $3, $4)" + glDrawArrays :: Ctx -> Word -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.drawElements($2, $3, $4, $5)" + glDrawElements :: Ctx -> Word -> Int -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.enable($2)" + glEnable :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.enableVertexAttribArray($2)" + glEnableVertexAttribArray :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.finish()" + glFinish :: Ctx -> IO () + +foreign import javascript unsafe "$1.flush()" + glFlush :: Ctx -> IO () + +foreign import javascript unsafe "$1.framebufferRenderbuffer($2, $3, $4, $5)" + glFramebufferRenderbuffer :: Ctx -> Word -> Word -> Word -> RenderBuffer -> IO () + +foreign import javascript unsafe "$1.framebufferTexture2D($2, $3, $4, $5, $6)" + glFramebufferTexture2D :: Ctx -> Word -> Word -> Word -> Texture -> Int -> IO () + +foreign import javascript unsafe "$1.frontFace($2)" + glFrontFace :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.generateMipmap($2)" + glGenerateMipmap :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.getActiveAttrib($2, $3)" + glGetActiveAttrib :: Ctx -> Program -> Word -> IO ActiveInfo + +foreign import javascript unsafe "$1.getActiveUniform($2, $3)" + glGetActiveUniform :: Ctx -> Program -> Word -> IO ActiveInfo + +{- +foreign import javascript unsafe "$1.getAttachedShaders($2)" + glGetAttachedShaders :: Ctx -> Program -> IO (Sequence Shader) +-} + +foreign import javascript unsafe "$1.getAttribLocation($2, $3)" + glGetAttribLocation :: Ctx -> Program -> JSString -> IO Int + +foreign import javascript unsafe "$1.getBufferParameter($2, $3)" + glGetBufferParameter :: Ctx -> Word -> Word -> IO (JSRef a) + +foreign import javascript unsafe "$1.getParameter($2)" + glGetParameter :: Ctx -> Word -> IO (JSRef a) + +foreign import javascript unsafe "$1.getError()" + glGetError :: Ctx -> IO Word + +foreign import javascript unsafe "$1.getFramebufferAttachmentParameter($2, $3)" + glGetFramebufferAttachmentParameter :: Ctx -> Word -> Word -> IO Word + +foreign import javascript unsafe "$1.getProgramInfoLog($2)" + glGetProgramInfoLog :: Ctx -> Program -> IO JSString + +foreign import javascript unsafe "$1.getRenderbufferParameter($2, $3)" + glGetRenderbufferParameter :: Ctx -> Word -> Word -> IO (JSRef a) + +foreign import javascript unsafe "$1.getShaderParameter($2, $3)" + glGetShaderParameter :: Ctx -> Shader -> Word -> IO (JSRef a) + +foreign import javascript unsafe "$1.getShaderPrecisionFormat($2, $3)" + glGetShaderPrecisionFormat :: Ctx -> Word -> Word -> IO ShaderPrecisionFormat + +foreign import javascript unsafe "$1.getShaderInfoLog($2)" + glGetShaderInfoLog :: Ctx -> Shader -> IO JSString + +foreign import javascript unsafe "$1.getShaderSource($2)" + glGetShaderSource :: Ctx -> Shader -> IO JSString + +foreign import javascript unsafe "$1.getTexParameter($2, $3)" + glGetTexParameter :: Ctx -> Word -> Word -> IO (JSRef a) + +foreign import javascript unsafe "$1.getUniform($2, $3)" + glGetUniform :: Ctx -> Program -> UniformLocation -> IO (JSRef a) + +foreign import javascript unsafe "$1.getUniformLocation($2, $3)" + glGetUniformLocation :: Ctx -> Program -> JSString -> IO UniformLocation + +foreign import javascript unsafe "$1.getVertexAttrib($2, $3)" + glGetVertexAttrib :: Ctx -> Word -> Word -> IO (JSRef a) + +foreign import javascript unsafe "$1.getVertexAttribOffset($2, $3)" + glGetVertexAttribOffset :: Ctx -> Word -> Word -> IO Word + +foreign import javascript unsafe "$1.hint($2, $3)" + glHint :: Ctx -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.isBuffer($2)" + glIsBuffer :: Ctx -> Buffer -> IO Bool + +foreign import javascript unsafe "$1.isEnabled($2)" + glIsEnabled :: Ctx -> Word -> IO Bool + +foreign import javascript unsafe "$1.isFramebuffer($2)" + glIsFramebuffer :: Ctx -> FrameBuffer -> IO Bool + +foreign import javascript unsafe "$1.isProgram($2)" + glIsProgram :: Ctx -> Program -> IO Bool + +foreign import javascript unsafe "$1.isRenderbuffer($2)" + glIsRenderbuffer :: Ctx -> RenderBuffer -> IO Bool + +foreign import javascript unsafe "$1.isShader($2)" + glIsShader :: Ctx -> Shader -> IO Bool + +foreign import javascript unsafe "$1.isTexture($2)" + glIsTexture :: Ctx -> Texture -> IO Bool + +foreign import javascript unsafe "$1.lineWidth($2)" + glLineWidth :: Ctx -> Float -> IO () + +foreign import javascript unsafe "$1.linkProgram($2)" + glLinkProgram :: Ctx -> Program -> IO () + +foreign import javascript unsafe "$1.pixelStorei($2, $3)" + glPixelStorei :: Ctx -> Word -> Int -> IO () + +foreign import javascript unsafe "$1.polygonOffset($2, $3)" + glPolygonOffset :: Ctx -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.readPixels($2, $3, $4, $5, $6, $7, $8)" + glReadPixels :: Ctx -> Int -> Int -> Int -> Int -> Word -> Word -> ArrayBufferView -> IO () + +foreign import javascript unsafe "$1.renderbufferStorage($2, $3, $4, $5)" + glRenderbufferStorage :: Ctx -> Word -> Word -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.sampleCoverage($2, $3)" + glSampleCoverage :: Ctx -> Float -> Bool -> IO () + +foreign import javascript unsafe "$1.scissor($2, $3, $4, $5)" + glScissor :: Ctx -> Int -> Int -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.shaderSource($2, $3)" + glShaderSource :: Ctx -> Shader -> JSString -> IO () + +foreign import javascript unsafe "$1.stencilFunc($2, $3, $4)" + glStencilFunc :: Ctx -> Word -> Int -> Word -> IO () + +foreign import javascript unsafe "$1.stencilFuncSeparate($2, $3, $4, $5)" + glStencilFuncSeparate :: Ctx -> Word -> Word -> Int -> Word -> IO () + +foreign import javascript unsafe "$1.stencilMask($2)" + glStencilMask :: Ctx -> Word -> IO () + +foreign import javascript unsafe "$1.stencilMaskSeparate($2, $3)" + glStencilMaskSeparate :: Ctx -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.stencilOp($2, $3, $4)" + glStencilOp :: Ctx -> Word -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.stencilOpSeparate($2, $3, $4, $5)" + glStencilOpSeparate :: Ctx -> Word -> Word -> Word -> Word -> IO () + +foreign import javascript unsafe "$1.texImage2D($2, $3, $4, $5, $6, $7, $8, $9, $10)" + glTexImage2DBuffer :: Ctx -> Word -> Int -> Int -> Int -> Int -> Int -> Word -> Word -> ArrayBufferView -> IO () + +foreign import javascript unsafe "$1.texImage2D($2, $3, $4, $5, $6, $7)" + glTexImage2DElement :: Ctx -> Word -> Int -> Int -> Word -> Word -> Image -> IO () + +{- +foreign import javascript unsafe "$1.texImage2D()" + glTexImage2D :: Ctx -> Word -> Int -> Word -> Word -> Word -> CanvasElement -> Void + +foreign import javascript unsafe "$1.texImage2D()" + glTexImage2D :: Ctx -> Word -> Int -> Word -> Word -> Word -> VideoElement -> Void +-} + +foreign import javascript unsafe "$1.texParameterf($2, $3, $4)" + glTexParameterf :: Ctx -> Word -> Word -> Float -> IO () + +foreign import javascript unsafe "$1.texParameteri($2, $3, $4)" + glTexParameteri :: Ctx -> Word -> Word -> Int -> IO () + +foreign import javascript unsafe "$1.texSubImage2D($2, $3, $4, $5, $6, $7, $8, $9, $10)" + glTexSubImage2D :: Ctx -> Word -> Int -> Int -> Int -> Int -> Int -> Word -> Word -> ArrayBufferView -> IO () + +{- + +foreign import javascript unsafe "$1.texSubImage2D()" + glTexSubImage2D :: Ctx -> Word -> Int -> Int -> Int -> Word -> Word -> CanvasElement -> Void + +foreign import javascript unsafe "$1.texSubImage2D()" + glTexSubImage2D :: Ctx -> Word -> Int -> Int -> Int -> Word -> Word -> VideoElement -> Void + +-} + +foreign import javascript unsafe "$1.uniform1f($2, $3)" + glUniform1f :: Ctx -> UniformLocation -> Float -> IO () + +foreign import javascript unsafe "$1.uniform1fv($2, $3)" + glUniform1fv :: Ctx -> UniformLocation -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform1fv($2 Sequence Float ->)" + glUniform1fv :: Ctx -> UniformLocation -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.uniform1i($2, $3)" + glUniform1i :: Ctx -> UniformLocation -> Int -> IO () + +foreign import javascript unsafe "$1.uniform1iv($2, $3)" + glUniform1iv :: Ctx -> UniformLocation -> Int32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform1iv($2 Sequence Int ->)" + glUniform1iv :: Ctx -> UniformLocation -> Sequence Int -> IO () +-} + +foreign import javascript unsafe "$1.uniform2f($2, $3, $4)" + glUniform2f :: Ctx -> UniformLocation -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.uniform2fv($2, $3)" + glUniform2fv :: Ctx -> UniformLocation -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform2fv($2 Sequence Float ->)" + glUniform2fv :: Ctx -> UniformLocation -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.uniform2i($2, $3, $4)" + glUniform2i :: Ctx -> UniformLocation -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.uniform2iv($2, $3)" + glUniform2iv :: Ctx -> UniformLocation -> Int32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform2iv($2 Sequence Int ->)" + glUniform2iv :: Ctx -> UniformLocation -> Sequence Int -> IO () +-} + +foreign import javascript unsafe "$1.uniform3f($2, $3, $4, $5)" + glUniform3f :: Ctx -> UniformLocation -> Float -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.uniform3fv($2, $3)" + glUniform3fv :: Ctx -> UniformLocation -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform3fv($2 Sequence Float ->)" + glUniform3fv :: Ctx -> UniformLocation -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.uniform3i($2, $3, $4, $5)" + glUniform3i :: Ctx -> UniformLocation -> Int -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.uniform3iv($2, $3)" + glUniform3iv :: Ctx -> UniformLocation -> Int32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform3iv($2 Sequence Int ->)" + glUniform3iv :: Ctx -> UniformLocation -> Sequence Int -> IO () +-} + +foreign import javascript unsafe "$1.uniform4f($2, $3, $4, $5, $6)" + glUniform4f :: Ctx -> UniformLocation -> Float -> Float -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.uniform4fv($2, $3)" + glUniform4fv :: Ctx -> UniformLocation -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform4fv($2 Sequence Float ->)" + glUniform4fv :: Ctx -> UniformLocation -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.uniform4i($2, $3, $4, $5, $6)" + glUniform4i :: Ctx -> UniformLocation -> Int -> Int -> Int -> Int -> IO () + +foreign import javascript unsafe "$1.uniform4iv($2, $3)" + glUniform4iv :: Ctx -> UniformLocation -> Int32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniform4iv($2 Sequence Int ->)" + glUniform4iv :: Ctx -> UniformLocation -> Sequence Int -> IO () +-} + +foreign import javascript unsafe "$1.uniformMatrix2fv($2, $3, $4)" + glUniformMatrix2fv :: Ctx -> UniformLocation -> Bool -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniformMatrix2fv($2, $3 Sequence Float ->)" + glUniformMatrix2fv :: Ctx -> UniformLocation -> Bool -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.uniformMatrix3fv($2, $3, $4)" + glUniformMatrix3fv :: Ctx -> UniformLocation -> Bool -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniformMatrix3fv($2, $3 Sequence Float ->)" + glUniformMatrix3fv :: Ctx -> UniformLocation -> Bool -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.uniformMatrix4fv($2, $3, $4)" + glUniformMatrix4fv :: Ctx -> UniformLocation -> Bool -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.uniformMatrix4fv($2, $3 Sequence Float ->)" + glUniformMatrix4fv :: Ctx -> UniformLocation -> Bool -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.useProgram($2)" + glUseProgram :: Ctx -> Program -> IO () + +foreign import javascript unsafe "$1.validateProgram($2)" + glValidateProgram :: Ctx -> Program -> IO () + +foreign import javascript unsafe "$1.vertexAttrib1f($2, $3)" + glVertexAttrib1f :: Ctx -> Word -> Float -> IO () + +foreign import javascript unsafe "$1.vertexAttrib1fv($2, $3)" + glVertexAttrib1fv :: Ctx -> Word -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.vertexAttrib1fv($2 Sequence Float ->)" + glVertexAttrib1fv :: Ctx -> Word -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.vertexAttrib2f($2, $3, $4)" + glVertexAttrib2f :: Ctx -> Word -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.vertexAttrib2fv($2, $3)" + glVertexAttrib2fv :: Ctx -> Word -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.vertexAttrib2fv($2 Sequence Float ->)" + glVertexAttrib2fv :: Ctx -> Word -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.vertexAttrib3f($2, $3, $4, $5)" + glVertexAttrib3f :: Ctx -> Word -> Float -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.vertexAttrib3fv($2, $3)" + glVertexAttrib3fv :: Ctx -> Word -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.vertexAttrib3fv($2 Sequence Float ->)" + glVertexAttrib3fv :: Ctx -> Word -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.vertexAttrib4f($2, $3, $4, $5, $6)" + glVertexAttrib4f :: Ctx -> Word -> Float -> Float -> Float -> Float -> IO () + +foreign import javascript unsafe "$1.vertexAttrib4fv($2, $3)" + glVertexAttrib4fv :: Ctx -> Word -> Float32Array -> IO () + +{- +foreign import javascript unsafe "$1.vertexAttrib4fv($2 Sequence Float ->)" + vertexAttrib4fv :: Ctx -> Word -> Sequence Float -> IO () +-} + +foreign import javascript unsafe "$1.vertexAttribPointer($2, $3, $4, $5, $6, $7)" + glVertexAttribPointer :: Ctx -> Word -> Int -> Word -> Bool -> Int -> Word -> IO () + +foreign import javascript unsafe "$1.viewport($2, $3, $4, $5)" + glViewport :: Ctx -> Int -> Int -> Int -> Int -> IO () diff --git a/FWGL/Backend/JavaScript/WebGL/Types.hs b/FWGL/Backend/JavaScript/WebGL/Types.hs new file mode 100644 --- /dev/null +++ b/FWGL/Backend/JavaScript/WebGL/Types.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +module FWGL.Backend.JavaScript.WebGL.Types ( + Ctx, + Image, + Float32Array, + Int32Array, + Uint16Array, + Program, + Shader, + Buffer, + FrameBuffer, + RenderBuffer, + Texture, + UniformLocation, + ActiveInfo, + ShaderPrecisionFormat, + ArrayBufferView, + getCtx, + float32Array, + int32Array, + uint16Array, + uint8Array, + float32View, + int32View, + uint16View, + uint8View, + toJSArray, + listToJSArray, + noBuffer, + noTexture +) where + +import Data.Int (Int32) +import Data.Word (Word8, Word16) +import GHCJS.Marshal +import GHCJS.Foreign +import GHCJS.Types + +data Ctx_ +type Ctx = JSRef Ctx_ + +data Image_ +type Image = JSRef Image_ + +data Float32Array_ +type Float32Array = JSRef Float32Array_ + +data Int32Array_ +type Int32Array = JSRef Int32Array_ + +data Uint16Array_ +type Uint16Array = JSRef Uint16Array_ + +data Uint8Array_ +type Uint8Array = JSRef Uint8Array_ + +data Program_ +type Program = JSRef Program_ + +data Shader_ +type Shader = JSRef Shader_ + +data Buffer_ +type Buffer = JSRef Buffer_ + +data FrameBuffer_ +type FrameBuffer = JSRef FrameBuffer_ + +data RenderBuffer_ +type RenderBuffer = JSRef RenderBuffer_ + +data Texture_ +type Texture = JSRef Texture_ + +data UniformLocation_ +type UniformLocation = JSRef UniformLocation_ + +data ActiveInfo_ +type ActiveInfo = JSRef ActiveInfo_ + +data ShaderPrecisionFormat_ +type ShaderPrecisionFormat = JSRef ShaderPrecisionFormat_ + +data ArrayBufferView_ +type ArrayBufferView = JSRef ArrayBufferView_ + +noBuffer :: Buffer +noBuffer = jsNull + +noTexture :: Texture +noTexture = jsNull + +float32View :: JSArray Float -> IO ArrayBufferView +float32View = fmap castRef . float32Array + +int32View :: JSArray Int32 -> IO ArrayBufferView +int32View = fmap castRef . int32Array + +uint16View :: JSArray Word16 -> IO ArrayBufferView +uint16View = fmap castRef . uint16Array + +uint8View :: JSArray Word8 -> IO ArrayBufferView +uint8View = fmap castRef . uint8Array + +toJSArray :: ToJSRef a => (v -> Maybe (a, v)) -> v -> IO (JSArray a) +toJSArray next iv = newArray >>= iterPush iv + where iterPush v arr = case next v of + Just (x, v') -> do xRef <- toJSRef x + pushArray xRef arr + iterPush v' arr + Nothing -> return arr + +listToJSArray :: ToJSRef a => [a] -> IO (JSArray a) +listToJSArray = toJSArray deconstr + where deconstr (x : xs) = Just (x, xs) + deconstr [] = Nothing + +foreign import javascript unsafe "$r = new Float32Array($1);" + float32Array :: JSArray Float -> IO Float32Array + +foreign import javascript unsafe "$r = new Int32Array($1);" + int32Array :: JSArray Int32 -> IO Int32Array + +foreign import javascript unsafe "$r = new Uint16Array($1);" + uint16Array :: JSArray Word16 -> IO Uint16Array + +foreign import javascript unsafe "$r = new Uint8Array($1);" + uint8Array :: JSArray Word8 -> IO Uint8Array + +foreign import javascript unsafe "$r = $1.getContext(\"webgl\");" + getCtx :: JSRef a -> IO Ctx diff --git a/FWGL/Geometry.hs b/FWGL/Geometry.hs new file mode 100644 --- /dev/null +++ b/FWGL/Geometry.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, + MultiParamTypeClasses #-} + +module FWGL.Geometry ( + AttrList(..), + Geometry(..), + Geometry2, + Geometry3, + GPUGeometry(..), + mkGeometry, + mkGeometry2, + mkGeometry3, + castGeometry, + facesToArrays, + arraysToElements, + triangulate +) where + +import Control.Applicative +import Control.Monad.ST +import qualified Data.Hashable as H +import qualified Data.HashMap.Strict as H +import Data.Foldable (Foldable, forM_) +import Data.STRef +import qualified Data.Vector.Storable as V +import Data.Word (Word16, Word) +import Unsafe.Coerce + +import FWGL.Internal.GL +import FWGL.Internal.Resource +import FWGL.Shader.CPU +import FWGL.Shader.Default2D (Position2) +import FWGL.Shader.Default3D (Position3, Normal3) +import qualified FWGL.Shader.Default2D as D2 +import qualified FWGL.Shader.Default3D as D3 +import FWGL.Shader.GLSL (attributeName) +import FWGL.Vector + +data AttrList (is :: [*]) where + AttrListNil :: AttrList '[] + AttrListCons :: (H.Hashable c, AttributeCPU c g) + => g -> [c] -> AttrList gs -> AttrList (g ': gs) + +-- ^ A set of attributes and indices. +data Geometry (is :: [*]) = Geometry (AttrList is) [Word16] Int + +data GPUGeometry = GPUGeometry { + attributeBuffers :: [(String, Buffer, GLUInt -> GL ())], + elementBuffer :: Buffer, + elementCount :: Int +} + +type Geometry3 = '[Position3, D3.UV, Normal3] +type Geometry2 = '[Position2, D2.UV] + +instance H.Hashable (AttrList is) where + hashWithSalt salt AttrListNil = salt + hashWithSalt salt (AttrListCons _ i is) = H.hashWithSalt salt (i, is) + +instance H.Hashable (Geometry is) where + hashWithSalt salt (Geometry _ _ h) = H.hashWithSalt salt h + +instance Eq (Geometry is) where + (Geometry _ _ h) == (Geometry _ _ h') = h == h' + +-- | Create a 3D 'Geometry'. The first three lists should have the same length. +mkGeometry3 :: GLES + => [V3] -- ^ List of vertices. + -> [V2] -- ^ List of UV coordinates. + -> [V3] -- ^ List of normals. + -> [Word16] -- ^ Triangles expressed as triples of indices to the + -- three lists above. + -> Geometry Geometry3 +mkGeometry3 v u n = mkGeometry (AttrListCons (undefined :: Position3) v $ + AttrListCons (undefined :: D3.UV) u $ + AttrListCons (undefined :: Normal3) n + AttrListNil) + +-- | Create a 2D 'Geometry'. The first two lists should have the same length. +mkGeometry2 :: GLES + => [V2] -- ^ List of vertices. + -> [V2] -- ^ List of UV coordinates. + -> [Word16] -- ^ Triangles expressed as triples of indices to the + -- two lists above. + -> Geometry Geometry2 +mkGeometry2 v u = mkGeometry (AttrListCons (undefined :: Position2) v $ + AttrListCons (undefined :: D2.UV) u + AttrListNil) + +-- | Create a custom 'Geometry'. +mkGeometry :: GLES => AttrList is -> [Word16] -> Geometry is +mkGeometry al e = Geometry al e $ H.hash al + +castGeometry :: Geometry is -> Geometry is' +castGeometry = unsafeCoerce + +instance GLES => Resource (Geometry i) GPUGeometry GL where + -- TODO: err check + loadResource i f = loadGeometry i $ f . Right + unloadResource _ = deleteGPUGeometry + +loadGeometry :: GLES => Geometry i -> (GPUGeometry -> GL ()) -> GL () +loadGeometry (Geometry al es _) = asyncGL $ + GPUGeometry <$> loadAttrList al + <*> (liftIO (encodeUShorts es) >>= + loadBuffer gl_ELEMENT_ARRAY_BUFFER) + <*> pure (length es) + +loadAttrList :: GLES => AttrList is -> GL [(String, Buffer, GLUInt -> GL ())] +loadAttrList AttrListNil = return [] +loadAttrList (AttrListCons g c al) = (:) <$> loadAttribute g c + <*> loadAttrList al + where loadAttribute g c = do arr <- encodeAttribute g c + buf <- loadBuffer gl_ARRAY_BUFFER arr + return (attributeName g, buf, setAttribute g) + +deleteGPUGeometry :: GLES => GPUGeometry -> GL () +deleteGPUGeometry (GPUGeometry abs eb _) = mapM_ (\(_, buf, _) -> deleteBuffer buf) abs + >> deleteBuffer eb + +-- TODO: move +loadBuffer :: GLES => GLEnum -> Array -> GL Buffer +loadBuffer ty bufData = + do buffer <- createBuffer + bindBuffer ty buffer + bufferData ty bufData gl_STATIC_DRAW + bindBuffer ty noBuffer + return buffer + + +-- TODO: use dlist +arraysToElements :: (Foldable f, GLES) => f (V3, V2, V3) -> Geometry Geometry3 +arraysToElements arrays = runST $ + do vs <- newSTRef [] + us <- newSTRef [] + ns <- newSTRef [] + es <- newSTRef [] + triples <- newSTRef H.empty + len <- newSTRef 0 + + forM_ arrays $ \ t@(v, u, n) -> readSTRef triples >>= \ ts -> + case H.lookup t ts of + Just idx -> modifySTRef es (idx :) + Nothing -> do idx <- readSTRef len + writeSTRef len $ idx + 1 + writeSTRef triples $ H.insert t idx ts + modifySTRef vs (v :) + modifySTRef us (u :) + modifySTRef ns (n :) + modifySTRef es (idx :) + + mkGeometry3 <$> (reverse <$> readSTRef vs) + <*> (reverse <$> readSTRef us) + <*> (reverse <$> readSTRef ns) + <*> (reverse <$> readSTRef es) + +facesToArrays :: V.Vector V3 -> V.Vector V2 -> V.Vector V3 + -> [[(Int, Int, Int)]] -> [(V3, V2, V3)] +facesToArrays ovs ous ons = (>>= toIndex . triangulate) + where toIndex = (>>= \(v1, v2, v3) -> [ getVertex v1 + , getVertex v2 + , getVertex v3 ]) + getVertex (v, u, n) = (ovs V.! v, ous V.! u, ons V.! n) + +triangulate :: [a] -> [(a, a, a)] +triangulate [] = error "triangulate: empty face" +triangulate (_ : []) = error "triangulate: can't triangulate a point" +triangulate (_ : _ : []) = error "triangulate: can't triangulate an edge" +triangulate (x : y : z : []) = [(x, y, z)] +triangulate (x : y : z : w : []) = [(x, y, z), (x, z, w)] +triangulate _ = error "triangulate: can't triangulate >4 faces" diff --git a/FWGL/Geometry/OBJ.hs b/FWGL/Geometry/OBJ.hs new file mode 100644 --- /dev/null +++ b/FWGL/Geometry/OBJ.hs @@ -0,0 +1,79 @@ +module FWGL.Geometry.OBJ where + +import Control.Applicative +import Control.Monad (when) +import Control.Monad.ST +import qualified Data.Vector.Storable as V +import Data.STRef + +import FWGL.Backend (GLES) +import FWGL.Internal.STVectorLen +import FWGL.Geometry +import FWGL.Vector + +data OBJModel = OBJModel { + objVertices :: V.Vector V3, + objUVCoords :: V.Vector V2, + objNormals :: V.Vector V3, + objFaces :: [[(Int, Int, Int)]] +} deriving (Show) + +loadOBJ :: GLES => FilePath -> IO OBJModel +loadOBJ = fmap parseOBJ . readFile -- TODO: substitute with ajax + +parseOBJ :: GLES => String -> OBJModel +parseOBJ file = runST $ + do vs <- new + us <- new + ns <- new + fs <- newSTRef [] + + flip mapM_ (lines file) $ \ l -> case l of + ('v' : ' ' : v3) -> cons (parseV3 v3) vs + ('v' : 't' : ' ' : v2) -> cons (parseV2 v2) us + ('v' : 'n' : ' ' : v3) -> cons (parseV3 v3) ns + ('f' : ' ' : f) -> modifySTRef fs (parseFace f :) + _ -> return () + + usLen <- readSTRef $ snd us + nsLen <- readSTRef $ snd ns + + when (usLen <= 0) $ cons (V2 0 0) us + when (nsLen <= 0) $ cons (V3 0 0 0) ns + + OBJModel <$> freeze vs + <*> freeze us + <*> freeze ns + <*> readSTRef fs + + where split s e str = iter str "" [] + where iter (x : xs) cur fnd | x == s = iter xs "" $ + reverse cur : fnd + | x /= e = iter xs (x : cur) fnd + iter _ [] fnd = fnd + iter _ cur fnd = reverse cur : fnd + parseV3 str = case split ' ' '#' str of + (z : y : x : _) -> V3 (parseFloat x) + (parseFloat y) + (parseFloat z) + _ -> error "parseOBJ: invalid vertex/normal" + parseV2 str = case split ' ' '#' str of + (y : x : _) -> V2 (parseFloat x) (parseFloat y) + _ -> error "parseOBJ: invalid uv coordinate" + parseFace = map parseElement . reverse . split ' ' '#' + + parseElement str = case split '/' ' ' str of + (n : t : v : _) -> ( parseInt v - 1 + , parseInt t - 1 + , parseInt n - 1 ) + _ -> error "parseOBJ: invalid element" + + parseInt [] = 1 + parseInt s = read s + + parseFloat [] = 0 + parseFloat s = read s + +geometryOBJ :: GLES => OBJModel -> Geometry Geometry3 +geometryOBJ (OBJModel vs us ns fs) = + arraysToElements $ facesToArrays vs us ns fs diff --git a/FWGL/Graphics/Color.hs b/FWGL/Graphics/Color.hs new file mode 100644 --- /dev/null +++ b/FWGL/Graphics/Color.hs @@ -0,0 +1,50 @@ +module FWGL.Graphics.Color where + +import Control.Applicative +import Data.Hashable +import Data.Word (Word8) +import Foreign.Ptr (castPtr) +import Foreign.Storable + +-- | An RGBA 32-bit color. +data Color = Color !Word8 !Word8 !Word8 !Word8 deriving (Eq, Show) + +instance Hashable Color where + hashWithSalt salt (Color r g b a) = hashWithSalt salt (r, g, b, a) + +instance Storable Color where + sizeOf _ = 4 * sizeOf (undefined :: Word8) + alignment _ = alignment (undefined :: Word8) + peek p = Color <$> peekElemOff bp 0 <*> peekElemOff bp 1 + <*> peekElemOff bp 2 <*> peekElemOff bp 3 + where bp = castPtr p + poke p (Color r g b a) = do pokeElemOff bp 0 r + pokeElemOff bp 1 g + pokeElemOff bp 2 b + pokeElemOff bp 3 a + where bp = castPtr p + +-- | Create a 'Color' with alpha set to 255. +visible :: Word8 -> Word8 -> Word8 -> Color +visible r g b = Color r g b 255 + +white :: Color +white = Color 255 255 255 255 + +black :: Color +black = Color 0 0 0 255 + +transparent :: Color +transparent = Color 0 0 0 0 + +red :: Color +red = Color 255 0 0 255 + +green :: Color +green = Color 0 255 0 255 + +blue :: Color +blue = Color 0 255 255 255 + +yellow :: Color +yellow = Color 255 255 0 255 diff --git a/FWGL/Graphics/Custom.hs b/FWGL/Graphics/Custom.hs new file mode 100644 --- /dev/null +++ b/FWGL/Graphics/Custom.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE TypeOperators, DataKinds, ConstraintKinds, + TypeFamilies, FlexibleContexts #-} + +module FWGL.Graphics.Custom ( + module FWGL.Vector, + Layer, + Object, + AttrList(..), + Geometry, + Texture, + Color(..), + (~~), + program, + nothing, + static, + global, + globalDraw, + globalTexture, + globalTexSize, + layer, + unsafeJoin, + mkGeometry, + mkTexture, + textureURL, + textureFile, + colorTex +) where + +import Control.Applicative +import Data.Typeable +import FRP.Yampa +import FWGL.Backend (BackendIO, GLES) +import FWGL.Geometry +import FWGL.Graphics.Color +import FWGL.Graphics.Draw +import FWGL.Graphics.Types hiding (program) +import FWGL.Internal.GL (GLES, ActiveTexture) +import FWGL.Internal.TList +import FWGL.Shader.CPU +import FWGL.Shader.Program +import FWGL.Texture +import FWGL.Vector + +-- | An empty custom object. +nothing :: Object '[] '[] +nothing = ObjectEmpty + +-- | A custom object with a specified 'Geometry'. +static :: Geometry i -> Object '[] i +static = ObjectMesh . StaticGeom + +-- | Sets a global (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 + +-- | Sets a global (uniform) of an object using a 'Texture'. +globalTexture :: (BackendIO, Typeable g, UniformCPU ActiveTexture g) + => g -> Texture -> Object gs is -> Object (g ': gs) is +globalTexture g c = globalDraw g $ textureUniform c + +-- | Sets a global (uniform) of an object using the dimensions of a 'Texture'. +globalTexSize :: (BackendIO, Typeable g, UniformCPU c g) => g -> Texture + -> ((Int, Int) -> c) -> Object gs is -> Object (g ': gs) is +globalTexSize g t fc = globalDraw g $ fc <$> textureSize t + +-- | Sets a global (uniform) of an object using the 'Draw' monad. +globalDraw :: (Typeable g, UniformCPU c g) => g -> Draw c + -> Object gs is -> Object (g ': gs) is +globalDraw = ObjectGlobal + +-- | Join two objects. +(~~) :: (Equal gs gs', Equal is is') + => Object gs is -> Object gs' is' + -> Object (Union gs gs') (Union is is') +(~~) = ObjectAppend + +-- | Join two objects, even if they don't provide the same variables. +unsafeJoin :: (Equal gs'' (Union gs gs'), Equal is'' (Union is is')) + => Object gs is -> Object gs' is' -> Object gs'' is'' +unsafeJoin = ObjectAppend + +-- | Associate an object with a program. +layer :: (Subset oi pi, Subset og pg) + => Program pg pi -> Object og oi -> Layer +layer = Layer + +-- | Generate a 1x1 texture. +colorTex :: GLES => Color -> Texture +colorTex c = mkTexture 1 1 [ c ] diff --git a/FWGL/Graphics/D2.hs b/FWGL/Graphics/D2.hs new file mode 100644 --- /dev/null +++ b/FWGL/Graphics/D2.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, ConstraintKinds, TypeOperators, + TypeFamilies #-} + +{-| Simplified 2D graphics system. -} +module FWGL.Graphics.D2 ( + -- * Elements + Element, + rect, + image, + depth, + sprite, + -- ** Geometry + Geometry, + geom, + mkGeometry2, + -- * Textures + module FWGL.Graphics.Color, + C.textureURL, + C.textureFile, + C.colorTex, + mkTexture, + -- * Transformations + V2(..), + pos, + rot, + scale, + scaleV, + -- * Layers + Layer, + -- ** Element layers + elements, + view, + -- ** Object layers + layer, + layerPrg, + -- * Custom 2D objects + Object, + object, + object1, + (C.~~), + -- ** Globals + C.global, + C.globalTexture, + C.globalTexSize, + viewObject, + DefaultUniforms2D, + Image(..), + Depth(..), + Transform2(..), + View2(..), + -- * 3D matrices + V3(..), + M3(..), + mat3, + mul3, + -- ** Transformation matrices + idMat3, + transMat3, + rotMat3, + scaleMat3 +) where + +import Control.Applicative +import FWGL.Backend hiding (Texture, Image, Program) +import FWGL.Geometry +import qualified FWGL.Graphics.Custom as C +import FWGL.Graphics.Color +import FWGL.Graphics.Draw +import FWGL.Graphics.Shapes +import FWGL.Graphics.Types +import FWGL.Internal.TList +import FWGL.Shader.Default2D (Image, Depth, Transform2, View2) +import FWGL.Shader.Program +import FWGL.Texture +import FWGL.Vector + +-- | A 2D object with a 'Texture', a depth and a transformation. +data Element = Element Float Texture (Draw M3) (Geometry Geometry2) + +-- | A rectangle with a specified 'Texture' and size. +rect :: GLES => V2 -> Texture -> Element +rect v t = Element 0 t (return idMat3) $ rectGeometry v + +-- | An element with a specified 'Geometry' and 'Texture'. +geom :: Texture -> Geometry Geometry2 -> Element +geom t = Element 0 t $ return idMat3 + +-- | A rectangle with the aspect ratio adapted to its texture. +image :: BackendIO + => Float -- ^ Width. + -> Texture -> Element +image s t = Element 0 t ((\(w, h) -> scaleMat3 (V2 1 $ h /w)) <$> textureSize t) + (rectGeometry $ V2 s s) + +-- | Set the depth of an element. +depth :: Float -> Element -> Element +depth d (Element _ t m g) = Element d t m g + +-- | A rectangle with the size and aspect ratio adapted to the screen. You +-- have to use the 'FWGL.Utils.screenScale' view matrix. +sprite :: BackendIO => Texture -> Element +sprite t = Element 0 t ((\(w, h) -> scaleMat3 $ V2 w h) <$> textureSize t) + (rectGeometry $ V2 1 1) + +-- | Create a graphical 'Object' from a list of 'Element's and a view matrix. +object :: BackendIO => M3 -> [Element] -> Object DefaultUniforms2D Geometry2 +object m = viewObject m . foldl acc ObjectEmpty + where acc o e = o C.~~ object1 e + +-- | Create a graphical 'Object' from a single 'Element'. This lets you set your +-- own globals individually. If the shader uses the view matrix 'View2' (e.g. +-- the default 2D shader), you have to set it with 'viewObject'. +object1 :: BackendIO => Element -> Object '[Image, Depth, Transform2] Geometry2 +object1 (Element d t m g) = C.globalTexture (undefined :: Image) t $ + C.global (undefined :: Depth) d $ + C.globalDraw (undefined :: Transform2) m $ + C.static g + +-- | Create a standard 'Layer' from a list of 'Element's. +elements :: BackendIO => [Element] -> Layer +elements = layer . object idMat3 + +-- | Create a 'Layer' from a view matrix and a list of 'Element's. +view :: BackendIO => M3 -> [Element] -> Layer +view m = layer . object m + +-- | Set the value of the view matrix of a 2D 'Object'. +viewObject :: BackendIO => M3 -> Object gs Geometry2 + -> Object (View2 ': gs) Geometry2 +viewObject = C.global (undefined :: View2) + +-- | Create a 'Layer' from a 2D 'Object', using the default shader. +layer :: BackendIO => Object DefaultUniforms2D Geometry2 -> Layer +layer = layerPrg defaultProgram2D + +-- | Create a 'Layer' from a 2D 'Object', using a custom shader. +layerPrg :: (BackendIO, Subset og pg) => Program pg Geometry2 + -> Object og Geometry2 -> Layer +layerPrg = C.layer + +-- | Translate an 'Element'. +pos :: V2 -> Element -> Element +pos v = transform $ transMat3 v + +-- | Rotate an 'Element'. +rot :: Float -> Element -> Element +rot a = transform $ rotMat3 a + +-- | Scale an 'Element'. +scale :: Float -> Element -> Element +scale f = transform $ scaleMat3 (V2 f f) + +-- | Scale an 'Element' in two dimensions. +scaleV :: V2 -> Element -> Element +scaleV v = transform $ scaleMat3 v + +-- | Transform an 'Element'. +transform :: M3 -> Element -> Element +transform m' (Element d t m g) = Element d t (mul3 <$> m <*> pure m') g diff --git a/FWGL/Graphics/Draw.hs b/FWGL/Graphics/Draw.hs new file mode 100644 --- /dev/null +++ b/FWGL/Graphics/Draw.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances, + FlexibleInstances, MultiParamTypeClasses #-} + +module FWGL.Graphics.Draw ( + Draw, + DrawState, + execDraw, + drawInit, + drawBegin, + drawLayer, + textureUniform, + textureSize, + setProgram, + resize +) where + +import FWGL.Geometry +import FWGL.Graphics.Shapes +import FWGL.Graphics.Types +import FWGL.Backend.IO +import FWGL.Internal.GL hiding (Texture, Program, UniformLocation) +import FWGL.Internal.Resource +import FWGL.Shader.CPU +import FWGL.Shader.GLSL +import FWGL.Shader.Program hiding (program) +import FWGL.Texture +import FWGL.Vector + +import qualified Data.HashMap.Strict as H +import Data.Typeable +import Data.Word (Word) +import Control.Applicative +import Control.Monad (when) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +drawInit :: (BackendIO, GLES) => Int -> Int -> GL DrawState +drawInit w h = do enable gl_DEPTH_TEST + clearColor 0.0 0.0 0.0 1.0 + depthFunc gl_LESS + resize w h + return DrawState { program = Nothing + , loadedProgram = Nothing + , programs = newGLResMap + , gpuMeshes = newGLResMap + , uniforms = newGLResMap + , textures = newGLResMap } + where newGLResMap :: Resource i r GL => ResMap i r + newGLResMap = newResMap + +execDraw :: Draw () -> DrawState -> GL DrawState +execDraw (Draw a) = execStateT a + +resize :: GLES => Int -> Int -> GL () +resize w h = viewport 0 0 (fromIntegral w) (fromIntegral h) + +drawBegin :: GLES => Draw () +drawBegin = gl $ clear gl_COLOR_BUFFER_BIT + +drawLayer :: (GLES, BackendIO) => Layer -> Draw () +drawLayer (Layer prg obj) = setProgram prg >> drawObject obj + +drawObject :: (GLES, BackendIO) => Object gs is -> Draw () +drawObject ObjectEmpty = return () +drawObject (ObjectMesh m) = drawMesh m +drawObject (ObjectGlobal g c o) = c >>= uniform g >> drawObject o +drawObject (ObjectAppend o o') = drawObject o >> drawObject o' + +drawMesh :: GLES => Mesh is -> Draw () +drawMesh Empty = return () +drawMesh Cube = drawMesh (StaticGeom cubeGeometry) +drawMesh (StaticGeom g) = withRes_ (getGPUGeometry $ castGeometry g) + drawGPUGeometry +drawMesh (DynamicGeom _ _) = error "drawMesh DynamicGeom: unsupported" +-- drawMesh (DynamicGeom d g) = delete {- removeResource -} d >> drawMesh (StaticGeom g) + +uniform :: (GLES, Typeable g, UniformCPU c g) => g -> c -> Draw () +uniform g c = withRes_ (getUniform g) + $ \(UniformLocation l) -> gl $ setUniform l g c + +textureUniform :: (GLES, BackendIO) => Texture -> Draw ActiveTexture +textureUniform tex = do withRes_ (getTexture tex) + $ \(LoadedTexture _ _ wtex) -> + gl $ do activeTexture gl_TEXTURE0 + bindTexture gl_TEXTURE_2D wtex + return $ ActiveTexture 0 + +textureSize :: (GLES, BackendIO, Num a) => Texture -> Draw (a, a) +textureSize tex = withRes (getTexture tex) (return (0, 0)) + $ \(LoadedTexture w h _) -> return ( fromIntegral w + , fromIntegral h) + +setProgram :: GLES => Program g i -> Draw () +setProgram p = do current <- program <$> Draw get + when (current /= Just (castProgram p)) $ + withRes_ (getProgram $ castProgram p) $ + \lp@(LoadedProgram glp _ _) -> do + Draw . modify $ \s -> s { + program = Just $ castProgram p, + loadedProgram = Just lp + } + gl $ useProgram glp + +withRes_ :: Draw (ResStatus a) -> (a -> Draw ()) -> Draw () +withRes_ drs = withRes drs $ return () + +withRes :: Draw (ResStatus a) -> Draw b -> (a -> Draw b) -> Draw b +withRes drs u l = drs >>= \rs -> case rs of + Loaded r -> l r + _ -> u + +getUniform :: (Typeable a, GLES) => a -> Draw (ResStatus UniformLocation) +getUniform g = do mprg <- loadedProgram <$> Draw get + case mprg of + Just prg -> + getDrawResource gl uniforms + (\ m s -> s { uniforms = m }) + (prg, globalName g) + Nothing -> return $ Error "No loaded program." + +getGPUGeometry :: GLES => Geometry '[] -> Draw (ResStatus GPUGeometry) +getGPUGeometry = getDrawResource gl gpuMeshes (\ m s -> s { gpuMeshes = m }) + +getTexture :: (GLES, BackendIO) => Texture -> Draw (ResStatus LoadedTexture) +getTexture = getDrawResource gl textures (\ m s -> s { textures = m }) + +getProgram :: GLES => Program '[] '[] -> Draw (ResStatus LoadedProgram) +getProgram = getDrawResource gl programs (\ m s -> s { programs = m }) + +getDrawResource :: Resource i r m + => (m (ResStatus r, ResMap i r) + -> Draw (ResStatus r, ResMap i r)) + -> (DrawState -> ResMap i r) + -> (ResMap i r -> DrawState -> DrawState) + -> i + -> Draw (ResStatus r) +getDrawResource lft mg ms i = do + s <- Draw get + (r, map) <- lft . getResource i $ mg s + Draw . put $ ms map s + return r + +drawGPUGeometry :: GLES => GPUGeometry -> Draw () +drawGPUGeometry (GPUGeometry abs eb ec) = + loadedProgram <$> Draw get >>= \mlp -> case mlp of + Nothing -> return () + Just (LoadedProgram _ locs _) -> gl $ do + enabledLocs <- mapM (\(nm, buf, setAttr) -> + let loc = locs H.! nm in + do bindBuffer gl_ARRAY_BUFFER + buf + enableVertexAttribArray $ + fromIntegral loc + setAttr $ fromIntegral loc + return loc + ) abs + + bindBuffer gl_ELEMENT_ARRAY_BUFFER eb + drawElements gl_TRIANGLES (fromIntegral ec) + gl_UNSIGNED_SHORT nullGLPtr + bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer + + mapM_ (disableVertexAttribArray . fromIntegral) + enabledLocs + bindBuffer gl_ARRAY_BUFFER noBuffer + +instance GLES => Resource (LoadedProgram, String) UniformLocation GL where + loadResource (LoadedProgram prg _ _, g) f = + do loc <- getUniformLocation prg $ toGLString g + f . Right $ UniformLocation loc + unloadResource _ _ = return () + +gl :: GL a -> Draw a +gl = Draw . lift diff --git a/FWGL/Graphics/Shapes.hs b/FWGL/Graphics/Shapes.hs new file mode 100644 --- /dev/null +++ b/FWGL/Graphics/Shapes.hs @@ -0,0 +1,106 @@ +module FWGL.Graphics.Shapes where + +import FWGL.Geometry +import FWGL.Graphics.Types +import FWGL.Internal.GL (GLES) +import FWGL.Vector + +rectGeometry :: GLES => V2 -> Geometry Geometry2 +rectGeometry (V2 w h) = mkGeometry2 [ V2 (-hw) (-hh) + , V2 hw (-hh) + , V2 hw hh + , V2 (-hw) hh ] + [ V2 0 0 + , V2 1 0 + , V2 1 1 + , V2 0 1 ] + [ 0, 1, 2, 0, 3, 2 ] + where (hw, hh) = (w / 2, h / 2) + +cubeGeometry :: GLES => Geometry Geometry3 +cubeGeometry = + mkGeometry3 + [ V3 1.0 1.0 (-0.999999), + V3 1.0 (-1.0) (-1.0), + V3 (-1.0) 1.0 (-1.0), + V3 (-1.0) (-1.0) 1.0, + V3 (-1.0) 1.0 1.0, + V3 (-1.0) (-1.0) (-1.0), + V3 (-1.0) (-1.0) 1.0, + V3 1.0 (-1.0) 1.0, + V3 (-1.0) 1.0 1.0, + V3 1.0 (-1.0) 1.0, + V3 1.0 (-1.0) (-1.0), + V3 0.999999 1.0 1.000001, + V3 1.0 1.0 (-0.999999), + V3 (-1.0) 1.0 (-1.0), + V3 0.999999 1.0 1.000001, + V3 1.0 (-1.0) (-1.0), + V3 1.0 (-1.0) 1.0, + V3 (-1.0) (-1.0) (-1.0), + V3 (-1.0) (-1.0) (-1.0), + V3 (-1.0) 1.0 (-1.0), + V3 0.999999 1.0 1.000001, + V3 1.0 1.0 (-0.999999), + V3 (-1.0) 1.0 1.0, + V3 (-1.0) (-1.0) 1.0 ] + [ V2 0.9999 1.0e-4, + V2 0.9999 0.9999, + V2 1.0e-4 1.0e-4, + V2 1.0e-4 0.9999, + V2 1.0e-4 1.0e-4, + V2 0.9999 0.9999, + V2 1.0e-4 1.0e-4, + V2 0.9999 1.0e-4, + V2 1.0e-4 0.9999, + V2 1.0e-4 1.0e-4, + V2 0.9999 1.0e-4, + V2 1.0e-4 0.9999, + V2 0.9999 0.9999, + V2 1.0e-4 0.9999, + V2 0.9999 1.0e-4, + V2 0.9999 0.9999, + V2 1.0e-4 0.9999, + V2 0.9999 1.0e-4, + V2 1.0e-4 0.9999, + V2 0.9999 1.0e-4, + V2 0.9999 0.9999, + V2 0.9999 0.9999, + V2 1.0e-4 1.0e-4, + V2 1.0e-4 1.0e-4 ] + [ V3 0.0 0.0 (-1.0), + V3 0.0 0.0 (-1.0), + V3 0.0 0.0 (-1.0), + V3 (-1.0) (-0.0) (-0.0), + V3 (-1.0) (-0.0) (-0.0), + V3 (-1.0) (-0.0) (-0.0), + V3 (-0.0) (-0.0) 1.0, + V3 (-0.0) (-0.0) 1.0, + V3 (-0.0) (-0.0) 1.0, + V3 1.0 (-0.0) 0.0, + V3 1.0 (-0.0) 0.0, + V3 1.0 (-0.0) 0.0, + V3 0.0 1.0 0.0, + V3 0.0 1.0 0.0, + V3 0.0 1.0 0.0, + V3 0.0 (-1.0) 0.0, + V3 0.0 (-1.0) 0.0, + V3 0.0 (-1.0) 0.0, + V3 0.0 0.0 (-1.0), + V3 (-1.0) (-0.0) (-0.0), + V3 (-0.0) (-0.0) 1.0, + V3 1.0 (-0.0) 0.0, + V3 0.0 1.0 0.0, + V3 0.0 (-1.0) 0.0 ] + [ 0, 1, 2, + 3, 4, 5, + 6, 7, 8, + 9, 10, 11, + 12, 13, 14, + 15, 16, 17, + 1, 18, 2, + 4, 19, 5, + 7, 20, 8, + 10, 21, 11, + 13, 22, 14, + 16, 23, 17 ] diff --git a/FWGL/Graphics/Types.hs b/FWGL/Graphics/Types.hs new file mode 100644 --- /dev/null +++ b/FWGL/Graphics/Types.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators, + ExistentialQuantification, GeneralizedNewtypeDeriving #-} + +module FWGL.Graphics.Types ( + Draw(..), + DrawState(..), + UniformLocation(..), + Geometry(..), + Mesh(..), + Light(..), + Object(..), + Layer(..) +) where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Trans.State +import Data.Typeable +import FWGL.Geometry +import FWGL.Internal.GL hiding (Program, Texture, UniformLocation) +import qualified FWGL.Internal.GL as GL +import FWGL.Internal.TList +import FWGL.Internal.Resource +import FWGL.Shader.CPU +import FWGL.Shader.Program +import FWGL.Texture +import FWGL.Vector + +newtype UniformLocation = UniformLocation GL.UniformLocation + +data DrawState = DrawState { + program :: Maybe (Program '[] '[]), + loadedProgram :: Maybe LoadedProgram, + programs :: ResMap (Program '[] '[]) LoadedProgram, + uniforms :: ResMap (LoadedProgram, String) UniformLocation, + gpuMeshes :: ResMap (Geometry '[]) GPUGeometry, + textures :: ResMap Texture LoadedTexture +} + +newtype Draw a = Draw { unDraw :: StateT DrawState GL a } + deriving (Functor, Applicative, Monad, MonadIO) + +-- | A static or dinamic geometry. +data Mesh is where + Empty :: Mesh '[] + Cube :: Mesh Geometry3 + 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. +data Object (gs :: [*]) (is :: [*]) where + ObjectEmpty :: Object gs is + ObjectMesh :: Mesh is -> Object gs is + ObjectGlobal :: (Typeable g, UniformCPU c g) => g -> Draw c + -> 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. +data Layer = forall oi pi og pg. (Subset oi pi, Subset og pg) + => Layer (Program pg pi) (Object og oi) diff --git a/FWGL/Input.hs b/FWGL/Input.hs new file mode 100644 --- /dev/null +++ b/FWGL/Input.hs @@ -0,0 +1,118 @@ +module FWGL.Input ( + module FWGL.Key, + Input(..), + InputEvent(..), + EventData(..), + keyUp, + keyDown, + key, + mouseDown, + mouseUp, + mouse, + click, + pointer, + resize, + size +) where + +import Data.Maybe +import Data.Hashable +import qualified Data.HashMap.Strict as H +import FWGL.Key +import FRP.Yampa + +-- | An event. +data InputEvent = KeyUp | KeyDown | MouseUp | MouseDown | MouseMove | Resize + deriving (Show, Eq, Enum) + +-- | The data carried by an event. +data EventData = EventData { + dataFramebufferSize :: Maybe (Int, Int), + dataPointer :: Maybe (Int, Int), + dataButton :: Maybe MouseButton, + dataKey :: Maybe Key +} + +-- | The general input. +data Input = Input { + inputEvents :: H.HashMap InputEvent [EventData] +} + +instance Hashable InputEvent where + hashWithSalt salt = hashWithSalt salt . fromEnum + +-- | Keyboard release. +keyUp :: Key -> SF Input (Event ()) +keyUp k = evEdge KeyUp $ isKey k + +-- | Keyboard press. +keyDown :: Key -> SF Input (Event ()) +keyDown k = evEdge KeyDown $ isKey k + +-- | Keyboard down. +key :: Key -> SF Input (Event ()) +key k = sscan upDown NoEvent <<< keyUp k &&& keyDown k + +-- | Mouse press. +mouseDown :: MouseButton -> SF Input (Event (Int, Int)) +mouseDown b = evPointer MouseDown $ \d -> dataButton d == Just b + +-- | Mouse release. +mouseUp :: MouseButton -> SF Input (Event (Int, Int)) +mouseUp b = evPointer MouseUp $ \d -> dataButton d == Just b + +-- | Mouse down. +mouse :: MouseButton -> SF Input (Event (Int, Int)) +mouse b = sscan upDown NoEvent <<< mouseUp b &&& mouseDown b + +-- | Left click. +click :: SF Input (Event (Int, Int)) +click = mouseDown MouseLeft + +-- | Pointer location in pixels. +pointer :: SF Input (Int, Int) +pointer = evPointer MouseMove (const True) >>> hold (0, 0) + +-- | Window/framebuffer/canvas/etc. resize. +resize :: SF Input (Event (Int, Int)) +resize = evSearch Resize (isJust . dataFramebufferSize) >>^ + fmap (fromJust . dataFramebufferSize) + +-- | Window/framebuffer/canvas size. +size :: SF Input (Int, Int) +size = resize >>> hold (0, 0) + +{- keyDownLimited :: KeyCode a => Double -> a -> SF Input (Event ()) + +keyLimited :: KeyCode a => Double -> a -> SF Input (Event ()) -} + +upDown :: Event a -> (Event a, Event a) -> Event a +upDown _ (_, Event x) = Event x +upDown (Event _) (Event _, _) = NoEvent +upDown s _ = s + +isKey :: Key -> EventData -> Bool +isKey k ed = case dataKey ed of + Just k' -> k == k' + Nothing -> False + +evSearch :: InputEvent -> (EventData -> Bool) -> SF Input (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 ev bP = evSearch ev bP >>> arr isEvent >>> edge + +evPointer :: InputEvent -> (EventData -> Bool) -> SF Input (Event (Int, Int)) +evPointer ev bP = evSearch ev bP >>> + arr (\ e -> case e of + Event ed -> case dataPointer ed of + Just (x, y) -> Event (x, y) + _ -> NoEvent + NoEvent -> NoEvent + ) + +eventHead :: [a] -> Event a +eventHead [] = NoEvent +eventHead (x : _) = Event x diff --git a/FWGL/Internal/GL.hs b/FWGL/Internal/GL.hs new file mode 100644 --- /dev/null +++ b/FWGL/Internal/GL.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module FWGL.Internal.GL ( + GL, + ActiveTexture(..), + module FWGL.Backend.GLES, + liftIO, + evalGL, + forkGL, + asyncGL, + getCtx, + activeTexture, + attachShader, + bindAttribLocation, + bindBuffer, + bindFramebuffer, + bindRenderbuffer, + bindTexture, + blendColor, + blendEquation, + blendEquationSeparate, + blendFunc, + blendFuncSeparate, + bufferData, + bufferSubData, + checkFramebufferStatus, + clear, + clearColor, + clearDepth, + clearStencil, + colorMask, + compileShader, + compressedTexImage2D, + compressedTexSubImage2D, + copyTexImage2D, + copyTexSubImage2D, + createBuffer, + createFramebuffer, + createProgram, + createRenderbuffer, + createShader, + createTexture, + cullFace, + deleteBuffer, + deleteFramebuffer, + deleteProgram, + deleteRenderbuffer, + deleteShader, + deleteTexture, + depthFunc, + depthMask, + depthRange, + detachShader, + disable, + disableVertexAttribArray, + drawArrays, + drawElements, + enable, + enableVertexAttribArray, + finish, + flush, + framebufferRenderbuffer, + framebufferTexture2D, + frontFace, + generateMipmap, + getAttribLocation, + getError, + getProgramInfoLog, + -- getShaderPrecisionFormat, + getShaderInfoLog, + getShaderSource, + getUniformLocation, + hint, + isBuffer, + isEnabled, + isFramebuffer, + isProgram, + isRenderbuffer, + isShader, + isTexture, + lineWidth, + linkProgram, + pixelStorei, + polygonOffset, + readPixels, + renderbufferStorage, + sampleCoverage, + scissor, + shaderSource, + stencilFunc, + stencilFuncSeparate, + stencilMask, + stencilMaskSeparate, + stencilOp, + stencilOpSeparate, + texImage2DBuffer, + texImage2DImage, + texParameterf, + texParameteri, + texSubImage2D, + uniform1f, + uniform1fv, + uniform1i, + uniform1iv, + uniform2f, + uniform2fv, + uniform2i, + uniform2iv, + uniform3f, + uniform3fv, + uniform3i, + uniform3iv, + uniform4f, + uniform4fv, + uniform4i, + uniform4iv, + uniformMatrix2fv, + uniformMatrix3fv, + uniformMatrix4fv, + useProgram, + validateProgram, + vertexAttrib1f, + vertexAttrib1fv, + vertexAttrib2f, + vertexAttrib2fv, + vertexAttrib3f, + vertexAttrib3fv, + vertexAttrib4f, + vertexAttrib4fv, + vertexAttribPointer, + viewport +) where + +import Control.Applicative +import Control.Concurrent +import Control.Monad.IO.Class +import Control.Monad.Trans.State +import Data.Word +import FWGL.Backend.GLES + +-- TODO: context loss +newtype GL a = GL (StateT Ctx IO a) + deriving (Functor, Applicative, Monad, MonadIO) + +newtype ActiveTexture = ActiveTexture Word + +evalGL :: GL a -> Ctx -> IO a +evalGL (GL m) = evalStateT m + +forkGL :: GLES => GL () -> GL ThreadId +forkGL a = getCtx >>= \ctx -> liftIO . forkIO $ evalGL a ctx + +asyncGL :: GLES => GL a -> (a -> GL ()) -> GL () +asyncGL r f = forkGL (r >>= f) >> return () + +getCtx :: GLES => GL Ctx +getCtx = GL get + +activeTexture :: GLES => GLEnum -> GL () +activeTexture a = GL get >>= \ctx -> liftIO $ glActiveTexture ctx a + +attachShader :: GLES => Program -> Shader -> GL () +attachShader a b = GL get >>= \ctx -> liftIO $ glAttachShader ctx a b + +bindAttribLocation :: GLES => Program -> GLUInt -> GLString -> GL () +bindAttribLocation a b c = GL get >>= \ctx -> liftIO $ glBindAttribLocation ctx a b c + +bindBuffer :: GLES => GLEnum -> Buffer -> GL () +bindBuffer a b = GL get >>= \ctx -> liftIO $ glBindBuffer ctx a b + +bindFramebuffer :: GLES => GLEnum -> FrameBuffer -> GL () +bindFramebuffer a b = GL get >>= \ctx -> liftIO $ glBindFramebuffer ctx a b + +bindRenderbuffer :: GLES => GLEnum -> RenderBuffer -> GL () +bindRenderbuffer a b = GL get >>= \ctx -> liftIO $ glBindRenderbuffer ctx a b + +bindTexture :: GLES => GLEnum -> Texture -> GL () +bindTexture a b = GL get >>= \ctx -> liftIO $ glBindTexture ctx a b + +blendColor :: GLES => Float -> Float -> Float -> Float -> GL () +blendColor a b c d = GL get >>= \ctx -> liftIO $ glBlendColor ctx a b c d + +blendEquation :: GLES => GLEnum -> GL () +blendEquation a = GL get >>= \ctx -> liftIO $ glBlendEquation ctx a + +blendEquationSeparate :: GLES => GLEnum -> GLEnum -> GL () +blendEquationSeparate a b = GL get >>= \ctx -> liftIO $ glBlendEquationSeparate ctx a b + +blendFunc :: GLES => GLEnum -> GLEnum -> GL () +blendFunc a b = GL get >>= \ctx -> liftIO $ glBlendFunc ctx a b + +blendFuncSeparate :: GLES => GLEnum -> GLEnum -> GLEnum -> GLEnum -> GL () +blendFuncSeparate a b c d = GL get >>= \ctx -> liftIO $ glBlendFuncSeparate ctx a b c d + +bufferData :: GLES => GLEnum -> Array -> GLEnum -> GL () +bufferData a b c = GL get >>= \ctx -> liftIO $ glBufferData ctx a b c + +bufferSubData :: GLES => GLEnum -> GLPtrDiff -> Array -> GL () +bufferSubData a b c = GL get >>= \ctx -> liftIO $ glBufferSubData ctx a b c + +checkFramebufferStatus :: GLES => GLEnum -> GL GLEnum +checkFramebufferStatus a = GL get >>= \ctx -> liftIO $ glCheckFramebufferStatus ctx a + +clear :: GLES => GLEnum -> GL () +clear a = GL get >>= \ctx -> liftIO $ glClear ctx a + +clearColor :: GLES => Float -> Float -> Float -> Float -> GL () +clearColor a b c d = GL get >>= \ctx -> liftIO $ glClearColor ctx a b c d + +clearDepth :: GLES => Float -> GL () +clearDepth a = GL get >>= \ctx -> liftIO $ glClearDepth ctx a + +clearStencil :: GLES => GLInt -> GL () +clearStencil a = GL get >>= \ctx -> liftIO $ glClearStencil ctx a + +colorMask :: GLES => GLBool -> GLBool -> GLBool -> GLBool -> GL () +colorMask a b c d = GL get >>= \ctx -> liftIO $ glColorMask ctx a b c d + +compileShader :: GLES => Shader -> GL () +compileShader a = GL get >>= \ctx -> liftIO $ glCompileShader ctx a + +compressedTexImage2D :: GLES => GLEnum -> GLInt -> GLEnum -> GLSize -> GLSize -> GLInt -> Array -> GL () +compressedTexImage2D a b c d e f g = GL get >>= \ctx -> liftIO $ glCompressedTexImage2D ctx a b c d e f g + +compressedTexSubImage2D :: GLES => GLEnum -> GLInt -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> Array -> GL () +compressedTexSubImage2D a b c d e f g h = GL get >>= \ctx -> liftIO $ glCompressedTexSubImage2D ctx a b c d e f g h + +copyTexImage2D :: GLES => GLEnum -> GLInt -> GLEnum -> GLInt -> GLInt -> GLSize -> GLSize -> GLInt -> GL () +copyTexImage2D a b c d e f g h = GL get >>= \ctx -> liftIO $ glCopyTexImage2D ctx a b c d e f g h + +copyTexSubImage2D :: GLES => GLEnum -> GLInt -> GLInt -> GLInt -> GLInt -> GLInt -> GLSize -> GLSize -> GL () +copyTexSubImage2D a b c d e f g h = GL get >>= \ctx -> liftIO $ glCopyTexSubImage2D ctx a b c d e f g h + +createBuffer :: GLES => GL Buffer +createBuffer = GL get >>= liftIO . glCreateBuffer + +createFramebuffer :: GLES => GL FrameBuffer +createFramebuffer = GL get >>= liftIO . glCreateFramebuffer + +createProgram :: GLES => GL Program +createProgram = GL get >>= liftIO . glCreateProgram + +createRenderbuffer :: GLES => GL RenderBuffer +createRenderbuffer = GL get >>= liftIO . glCreateRenderbuffer + +createShader :: GLES => GLEnum -> GL Shader +createShader a = GL get >>= \ctx -> liftIO $ glCreateShader ctx a + +createTexture :: GLES => GL Texture +createTexture = GL get >>= liftIO . glCreateTexture + +cullFace :: GLES => GLEnum -> GL () +cullFace a = GL get >>= \ctx -> liftIO $ glCullFace ctx a + +deleteBuffer :: GLES => Buffer -> GL () +deleteBuffer a = GL get >>= \ctx -> liftIO $ glDeleteBuffer ctx a + +deleteFramebuffer :: GLES => FrameBuffer -> GL () +deleteFramebuffer a = GL get >>= \ctx -> liftIO $ glDeleteFramebuffer ctx a + +deleteProgram :: GLES => Program -> GL () +deleteProgram a = GL get >>= \ctx -> liftIO $ glDeleteProgram ctx a + +deleteRenderbuffer :: GLES => RenderBuffer -> GL () +deleteRenderbuffer a = GL get >>= \ctx -> liftIO $ glDeleteRenderbuffer ctx a + +deleteShader :: GLES => Shader -> GL () +deleteShader a = GL get >>= \ctx -> liftIO $ glDeleteShader ctx a + +deleteTexture :: GLES => Texture -> GL () +deleteTexture a = GL get >>= \ctx -> liftIO $ glDeleteTexture ctx a + +depthFunc :: GLES => GLEnum -> GL () +depthFunc a = GL get >>= \ctx -> liftIO $ glDepthFunc ctx a + +depthMask :: GLES => GLBool -> GL () +depthMask a = GL get >>= \ctx -> liftIO $ glDepthMask ctx a + +depthRange :: GLES => Float -> Float -> GL () +depthRange a b = GL get >>= \ctx -> liftIO $ glDepthRange ctx a b + +detachShader :: GLES => Program -> Shader -> GL () +detachShader a b = GL get >>= \ctx -> liftIO $ glDetachShader ctx a b + +disable :: GLES => GLEnum -> GL () +disable a = GL get >>= \ctx -> liftIO $ glDisable ctx a + +disableVertexAttribArray :: GLES => GLUInt -> GL () +disableVertexAttribArray a = GL get >>= \ctx -> liftIO $ glDisableVertexAttribArray ctx a + +drawArrays :: GLES => GLEnum -> GLInt -> GLSize -> GL () +drawArrays a b c = GL get >>= \ctx -> liftIO $ glDrawArrays ctx a b c + +drawElements :: GLES => GLEnum -> GLSize -> GLEnum -> GLPtr -> GL () +drawElements a b c d = GL get >>= \ctx -> liftIO $ glDrawElements ctx a b c d + +enable :: GLES => GLEnum -> GL () +enable a = GL get >>= \ctx -> liftIO $ glEnable ctx a + +enableVertexAttribArray :: GLES => GLUInt -> GL () +enableVertexAttribArray a = GL get >>= \ctx -> liftIO $ glEnableVertexAttribArray ctx a + +finish :: GLES => GL () +finish = GL get >>= liftIO . glFinish + +flush :: GLES => GL () +flush = GL get >>= liftIO . glFlush + +framebufferRenderbuffer :: GLES => GLEnum -> GLEnum -> GLEnum -> RenderBuffer -> GL () +framebufferRenderbuffer a b c d = GL get >>= \ctx -> liftIO $ glFramebufferRenderbuffer ctx a b c d + +framebufferTexture2D :: GLES => GLEnum -> GLEnum -> GLEnum -> Texture -> GLInt -> GL () +framebufferTexture2D a b c d e = GL get >>= \ctx -> liftIO $ glFramebufferTexture2D ctx a b c d e + +frontFace :: GLES => GLEnum -> GL () +frontFace a = GL get >>= \ctx -> liftIO $ glFrontFace ctx a + +generateMipmap :: GLES => GLEnum -> GL () +generateMipmap a = GL get >>= \ctx -> liftIO $ glGenerateMipmap ctx a + +-- glGetActiveAttrib :: GLES => Program -> GLEnum -> GL ActiveInfo +-- getActiveAttrib a b = GL get >>= \ctx -> liftIO $ glGetActiveAttrib ctx a b + +-- glGetActiveUniform :: GLES => Program -> GLEnum -> GL ActiveInfo +-- getActiveUniform a b = GL get >>= \ctx -> liftIO $ glGetActiveUniform ctx a b + +getAttribLocation :: GLES => Program -> GLString -> GL GLInt +getAttribLocation a b = GL get >>= \ctx -> liftIO $ glGetAttribLocation ctx a b + +-- glGetBufferParameter :: GLES => Word -> Word -> GL (JSRef a) +-- getBufferParameter a b = GL get >>= \ctx -> liftIO $ glGetBufferParameter ctx a b + +-- glGetParameter :: GLES => Word -> GL (JSRef a) +-- getParameter a = GL get >>= \ctx -> liftIO $ glGetParameter ctx a + +getError :: GLES => GL GLEnum +getError = GL get >>= liftIO . glGetError + +-- glGetFramebufferAttachmentParameter :: GLES => GLEnum -> GLEnum -> GL Word +-- getFramebufferAttachmentParameter a b = GL get >>= \ctx -> liftIO $ glGetFramebufferAttachmentParameter ctx a b + +getProgramInfoLog :: GLES => Program -> GL GLString +getProgramInfoLog a = GL get >>= \ctx -> liftIO $ glGetProgramInfoLog ctx a + +-- glGetRenderbufferParameter :: GLES => Word -> Word -> GL (JSRef a) +-- getRenderbufferParameter a b = GL get >>= \ctx -> liftIO $ glGetRenderbufferParameter ctx a b + +-- glGetShaderParameter :: GLES => Shader -> Word -> GL (JSRef a) +-- getShaderParameter a b = GL get >>= \ctx -> liftIO $ glGetShaderParameter ctx a b + +-- getShaderPrecisionFormat :: GLES => GLEnum -> GLEnum -> GL ShaderPrecisionFormat +-- getShaderPrecisionFormat a b = GL get >>= \ctx -> liftIO $ glGetShaderPrecisionFormat ctx a b + +getShaderInfoLog :: GLES => Shader -> GL GLString +getShaderInfoLog a = GL get >>= \ctx -> liftIO $ glGetShaderInfoLog ctx a + +getShaderSource :: GLES => Shader -> GL GLString +getShaderSource a = GL get >>= \ctx -> liftIO $ glGetShaderSource ctx a + +-- glGetTexParameter :: GLES => Word -> Word -> GL (JSRef a) +-- getTexParameter a b = GL get >>= \ctx -> liftIO $ glGetTexParameter ctx a b + +-- glGetUniform :: GLES => Program -> UniformLocation -> GL (JSRef a) +-- getUniform a b = GL get >>= \ctx -> liftIO $ glGetUniform ctx a b + +getUniformLocation :: GLES => Program -> GLString -> GL UniformLocation +getUniformLocation a b = GL get >>= \ctx -> liftIO $ glGetUniformLocation ctx a b + +-- glGetVertexAttrib :: GLES => Word -> Word -> GL (JSRef a) +-- getVertexAttrib a b = GL get >>= \ctx -> liftIO $ glGetVertexAttrib ctx a b + +-- glGetVertexAttribOffset :: GLES => Word -> GLEnum -> GL Word +-- getVertexAttribOffset a b = GL get >>= \ctx -> liftIO $ glGetVertexAttribOffset ctx a b + +hint :: GLES => GLEnum -> GLEnum -> GL () +hint a b = GL get >>= \ctx -> liftIO $ glHint ctx a b + +isBuffer :: GLES => Buffer -> GL GLBool +isBuffer a = GL get >>= \ctx -> liftIO $ glIsBuffer ctx a + +isEnabled :: GLES => GLEnum -> GL GLBool +isEnabled a = GL get >>= \ctx -> liftIO $ glIsEnabled ctx a + +isFramebuffer :: GLES => FrameBuffer -> GL GLBool +isFramebuffer a = GL get >>= \ctx -> liftIO $ glIsFramebuffer ctx a + +isProgram :: GLES => Program -> GL GLBool +isProgram a = GL get >>= \ctx -> liftIO $ glIsProgram ctx a + +isRenderbuffer :: GLES => RenderBuffer -> GL GLBool +isRenderbuffer a = GL get >>= \ctx -> liftIO $ glIsRenderbuffer ctx a + +isShader :: GLES => Shader -> GL GLBool +isShader a = GL get >>= \ctx -> liftIO $ glIsShader ctx a + +isTexture :: GLES => Texture -> GL GLBool +isTexture a = GL get >>= \ctx -> liftIO $ glIsTexture ctx a + +lineWidth :: GLES => Float -> GL () +lineWidth a = GL get >>= \ctx -> liftIO $ glLineWidth ctx a + +linkProgram :: GLES => Program -> GL () +linkProgram a = GL get >>= \ctx -> liftIO $ glLinkProgram ctx a + +pixelStorei :: GLES => GLEnum -> GLInt -> GL () +pixelStorei a b = GL get >>= \ctx -> liftIO $ glPixelStorei ctx a b + +polygonOffset :: GLES => Float -> Float -> GL () +polygonOffset a b = GL get >>= \ctx -> liftIO $ glPolygonOffset ctx a b + +readPixels :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> Array -> GL () +readPixels a b c d e f g = GL get >>= \ctx -> liftIO $ glReadPixels ctx a b c d e f g + +renderbufferStorage :: GLES => GLEnum -> GLEnum -> GLSize -> GLSize -> GL () +renderbufferStorage a b c d = GL get >>= \ctx -> liftIO $ glRenderbufferStorage ctx a b c d + +sampleCoverage :: GLES => Float -> GLBool -> GL () +sampleCoverage a b = GL get >>= \ctx -> liftIO $ glSampleCoverage ctx a b + +scissor :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GL () +scissor a b c d = GL get >>= \ctx -> liftIO $ glScissor ctx a b c d + +shaderSource :: GLES => Shader -> GLString -> GL () +shaderSource a b = GL get >>= \ctx -> liftIO $ glShaderSource ctx a b + +stencilFunc :: GLES => GLEnum -> GLInt -> GLUInt -> GL () +stencilFunc a b c = GL get >>= \ctx -> liftIO $ glStencilFunc ctx a b c + +stencilFuncSeparate :: GLES => GLEnum -> GLEnum -> GLInt -> GLUInt -> GL () +stencilFuncSeparate a b c d = GL get >>= \ctx -> liftIO $ glStencilFuncSeparate ctx a b c d + +stencilMask :: GLES => GLUInt -> GL () +stencilMask a = GL get >>= \ctx -> liftIO $ glStencilMask ctx a + +stencilMaskSeparate :: GLES => GLEnum -> GLUInt -> GL () +stencilMaskSeparate a b = GL get >>= \ctx -> liftIO $ glStencilMaskSeparate ctx a b + +stencilOp :: GLES => GLEnum -> GLEnum -> GLEnum -> GL () +stencilOp a b c = GL get >>= \ctx -> liftIO $ glStencilOp ctx a b c + +stencilOpSeparate :: GLES => GLEnum -> GLEnum -> GLEnum -> GLEnum -> GL () +stencilOpSeparate a b c d = GL get >>= \ctx -> liftIO $ glStencilOpSeparate ctx a b c d + +texImage2DBuffer :: GLES => GLEnum -> GLInt -> GLInt -> GLSize -> GLSize -> GLInt -> GLEnum -> GLEnum -> Array -> GL () +texImage2DBuffer a b c d e f g h i = GL get >>= \ctx -> liftIO $ glTexImage2DBuffer ctx a b c d e f g h i + +texImage2DImage :: GLES => GLEnum -> GLInt -> GLInt -> GLEnum -> GLEnum -> Image -> GL () +texImage2DImage a b c d e f = GL get >>= \ctx -> liftIO $ glTexImage2DImage ctx a b c d e f + +texParameterf :: GLES => GLEnum -> GLEnum -> Float -> GL () +texParameterf a b c = GL get >>= \ctx -> liftIO $ glTexParameterf ctx a b c + +texParameteri :: GLES => GLEnum -> GLEnum -> GLInt -> GL () +texParameteri a b c = GL get >>= \ctx -> liftIO $ glTexParameteri ctx a b c + +texSubImage2D :: GLES => GLEnum -> GLInt -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> Array -> GL () +texSubImage2D a b c d e f g h i = GL get >>= \ctx -> liftIO $ glTexSubImage2D ctx a b c d e f g h i + +uniform1f :: GLES => UniformLocation -> Float -> GL () +uniform1f a b = GL get >>= \ctx -> liftIO $ glUniform1f ctx a b + +uniform1fv :: GLES => UniformLocation -> Float32Array -> GL () +uniform1fv a b = GL get >>= \ctx -> liftIO $ glUniform1fv ctx a b + +uniform1i :: GLES => UniformLocation -> GLInt -> GL () +uniform1i a b = GL get >>= \ctx -> liftIO $ glUniform1i ctx a b + +uniform1iv :: GLES => UniformLocation -> Int32Array -> GL () +uniform1iv a b = GL get >>= \ctx -> liftIO $ glUniform1iv ctx a b + +uniform2f :: GLES => UniformLocation -> Float -> Float -> GL () +uniform2f a b c = GL get >>= \ctx -> liftIO $ glUniform2f ctx a b c + +uniform2fv :: GLES => UniformLocation -> Float32Array -> GL () +uniform2fv a b = GL get >>= \ctx -> liftIO $ glUniform2fv ctx a b + +uniform2i :: GLES => UniformLocation -> GLInt -> GLInt -> GL () +uniform2i a b c = GL get >>= \ctx -> liftIO $ glUniform2i ctx a b c + +uniform2iv :: GLES => UniformLocation -> Int32Array -> GL () +uniform2iv a b = GL get >>= \ctx -> liftIO $ glUniform2iv ctx a b + +uniform3f :: GLES => UniformLocation -> Float -> Float -> Float -> GL () +uniform3f a b c d = GL get >>= \ctx -> liftIO $ glUniform3f ctx a b c d + +uniform3fv :: GLES => UniformLocation -> Float32Array -> GL () +uniform3fv a b = GL get >>= \ctx -> liftIO $ glUniform3fv ctx a b + +uniform3i :: GLES => UniformLocation -> GLInt -> GLInt -> GLInt -> GL () +uniform3i a b c d = GL get >>= \ctx -> liftIO $ glUniform3i ctx a b c d + +uniform3iv :: GLES => UniformLocation -> Int32Array -> GL () +uniform3iv a b = GL get >>= \ctx -> liftIO $ glUniform3iv ctx a b + +uniform4f :: GLES => UniformLocation -> Float -> Float -> Float -> Float -> GL () +uniform4f a b c d e = GL get >>= \ctx -> liftIO $ glUniform4f ctx a b c d e + +uniform4fv :: GLES => UniformLocation -> Float32Array -> GL () +uniform4fv a b = GL get >>= \ctx -> liftIO $ glUniform4fv ctx a b + +uniform4i :: GLES => UniformLocation -> GLInt -> GLInt -> GLInt -> GLInt -> GL () +uniform4i a b c d e = GL get >>= \ctx -> liftIO $ glUniform4i ctx a b c d e + +uniform4iv :: GLES => UniformLocation -> Int32Array -> GL () +uniform4iv a b = GL get >>= \ctx -> liftIO $ glUniform4iv ctx a b + +uniformMatrix2fv :: GLES => UniformLocation -> GLBool -> Float32Array -> GL () +uniformMatrix2fv a b c = GL get >>= \ctx -> liftIO $ glUniformMatrix2fv ctx a b c + +uniformMatrix3fv :: GLES => UniformLocation -> GLBool -> Float32Array -> GL () +uniformMatrix3fv a b c = GL get >>= \ctx -> liftIO $ glUniformMatrix3fv ctx a b c + +uniformMatrix4fv :: GLES => UniformLocation -> GLBool -> Float32Array -> GL () +uniformMatrix4fv a b c = GL get >>= \ctx -> liftIO $ glUniformMatrix4fv ctx a b c + +useProgram :: GLES => Program -> GL () +useProgram a = GL get >>= \ctx -> liftIO $ glUseProgram ctx a + +validateProgram :: GLES => Program -> GL () +validateProgram a = GL get >>= \ctx -> liftIO $ glValidateProgram ctx a + +vertexAttrib1f :: GLES => GLUInt -> Float -> GL () +vertexAttrib1f a b = GL get >>= \ctx -> liftIO $ glVertexAttrib1f ctx a b + +vertexAttrib1fv :: GLES => GLUInt -> Float32Array -> GL () +vertexAttrib1fv a b = GL get >>= \ctx -> liftIO $ glVertexAttrib1fv ctx a b + +vertexAttrib2f :: GLES => GLUInt -> Float -> Float -> GL () +vertexAttrib2f a b c = GL get >>= \ctx -> liftIO $ glVertexAttrib2f ctx a b c + +vertexAttrib2fv :: GLES => GLUInt -> Float32Array -> GL () +vertexAttrib2fv a b = GL get >>= \ctx -> liftIO $ glVertexAttrib2fv ctx a b + +vertexAttrib3f :: GLES => GLUInt -> Float -> Float -> Float -> GL () +vertexAttrib3f a b c d = GL get >>= \ctx -> liftIO $ glVertexAttrib3f ctx a b c d + +vertexAttrib3fv :: GLES => GLUInt -> Float32Array -> GL () +vertexAttrib3fv a b = GL get >>= \ctx -> liftIO $ glVertexAttrib3fv ctx a b + +vertexAttrib4f :: GLES => GLUInt -> Float -> Float -> Float -> Float -> GL () +vertexAttrib4f a b c d e = GL get >>= \ctx -> liftIO $ glVertexAttrib4f ctx a b c d e + +vertexAttrib4fv :: GLES => GLUInt -> Float32Array -> GL () +vertexAttrib4fv a b = GL get >>= \ctx -> liftIO $ glVertexAttrib4fv ctx a b + +vertexAttribPointer :: GLES => GLUInt -> GLInt -> GLEnum -> GLBool -> GLSize -> GLPtr -> GL () +vertexAttribPointer a b c d e f = GL get >>= \ctx -> liftIO $ glVertexAttribPointer ctx a b c d e f + +viewport :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GL () +viewport a b c d = GL get >>= \ctx -> liftIO $ glViewport ctx a b c d diff --git a/FWGL/Internal/Resource.hs b/FWGL/Internal/Resource.hs new file mode 100644 --- /dev/null +++ b/FWGL/Internal/Resource.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, + FunctionalDependencies #-} + +module FWGL.Internal.Resource ( + ResMap, + ResStatus(..), + Resource(..), + newResMap, + addResource, + getResource, + removeResource +) where + +import Control.Applicative +import Control.Monad.IO.Class +import Data.IORef +import Data.Functor +import qualified Data.HashMap.Strict as H +import Data.Hashable + +data ResMap i r = forall m. Resource i r m => + ResMap (H.HashMap i (IORef (ResStatus r))) + +data ResStatus r = Loaded r | Unloaded | Loading | Error String + +class (Hashable i, Eq i, Applicative m, MonadIO m) => + Resource i r m | i -> r m where + loadResource :: i -> (Either String r -> m ()) -> m () + unloadResource :: i -> r -> m () + +newResMap :: Resource i r m => ResMap i r +newResMap = ResMap H.empty + +addResource :: Resource i r m => i -> ResMap i r -> m (ResMap i r) +addResource i m = snd <$> getResource i m + +checkResource :: Resource i r m => i -> ResMap i r -> m (ResStatus r) +checkResource i (ResMap map) = case H.lookup i map of + Just ref -> liftIO $ readIORef ref + Nothing -> return $ Unloaded + +getResource :: Resource i r m => i -> ResMap i r -> m (ResStatus r, ResMap i r) +getResource i rmap@(ResMap map) = + do status <- checkResource i rmap + case status of + Unloaded -> + do ref <- liftIO $ newIORef Loading + loadResource i $ \e -> case e of + Left s -> liftIO . writeIORef ref $ Error s + Right r -> liftIO . writeIORef ref $ Loaded r + status' <- liftIO $ readIORef ref + return (status', ResMap $ H.insert i ref map) + _ -> return (status, rmap) + +removeResource :: Resource i r m => i -> ResMap i r -> m (ResMap i r) +removeResource i rmap@(ResMap map) = + do status <- checkResource i rmap + case status of + Loaded r -> unloadResource i r + Loading -> return () --- XXX + _ -> return () + return . ResMap $ H.delete i map diff --git a/FWGL/Internal/STVectorLen.hs b/FWGL/Internal/STVectorLen.hs new file mode 100644 --- /dev/null +++ b/FWGL/Internal/STVectorLen.hs @@ -0,0 +1,31 @@ +module FWGL.Internal.STVectorLen where + +import Control.Applicative +import Control.Monad (when) +import Control.Monad.ST +import Data.STRef +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +type STVectorLen s a = (STRef s (M.STVector s a), STRef s Int) + +new :: V.Storable a => ST s (STVectorLen s a) +new = (,) <$> (M.new 256 >>= newSTRef) <*> newSTRef 0 + +(!) :: V.Storable a => STVectorLen s a -> Int -> ST s a +(!) (vRef, _) i = readSTRef vRef >>= flip M.read i + +cons :: V.Storable a => a -> STVectorLen s a -> ST s () +cons x (vRef, lenRef) = do len <- readSTRef lenRef + v <- readSTRef vRef + let maxLen = M.length v + when (len >= maxLen) $ + M.grow v (maxLen * 2) >>= writeSTRef vRef + v' <- readSTRef vRef + M.write v' len x + writeSTRef lenRef $ len + 1 + +freeze :: V.Storable a => STVectorLen s a -> ST s (V.Vector a) +freeze (vRef, lenRef) = do v <- readSTRef vRef >>= V.freeze + len <- readSTRef lenRef + return $ V.slice 0 len v diff --git a/FWGL/Internal/TList.hs b/FWGL/Internal/TList.hs new file mode 100644 --- /dev/null +++ b/FWGL/Internal/TList.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies, + TypeOperators, UndecidableInstances, FlexibleContexts, + FlexibleInstances, ConstraintKinds, PolyKinds #-} + +module FWGL.Internal.TList where + +class Subset (xs :: [*]) (ys :: [*]) +instance Subset '[] ys +instance (Subset '[x] ys, Subset xs ys) => Subset (x ': xs) ys +-- BUG: Subset x x? + +-- class Equal (xs :: [*]) (ys :: [*]) +-- instance (Subset xs ys, Subset ys xs) => Equal xs ys +type Equal xs ys = (Subset xs ys, Subset ys xs) + +type Member x xs = Subset '[x] xs + +type NotMember x xs = IsMember x xs ~ False + +type family IsMember x (xs :: [*]) :: Bool where + IsMember x '[] = False + IsMember x (x ': xs) = True + IsMember y (x ': xs) = IsMember y xs + +type family Remove x (xs :: [*]) where + Remove x '[] = '[] + Remove x (x ': xs) = Remove x xs + Remove x (y ': xs) = y ': Remove x xs + +type family Difference (xs :: [*]) (ys :: [*]) where + Difference xs '[] = xs + Difference xs (y ': ys) = Difference (Remove y xs) ys + +type family Append (xs :: [*]) (ys :: [*]) where + Append '[] ys = ys + Append (x ': xs) ys = x ': Append xs ys + +type family Insert y (xs :: [*]) where + Insert y '[] = '[y] + Insert y (y ': xs) = y ': xs + Insert y (x ': xs) = x ': Insert y xs + +type family Union (xs :: [*]) (ys :: [*]) where + Union '[] ys = ys + Union (x ': xs) ys = Union xs (Insert x ys) + +type family TypeEq (x :: k) (y :: k) :: Bool where + TypeEq x x = True + TypeEq x y = False diff --git a/FWGL/Key.hs b/FWGL/Key.hs new file mode 100644 --- /dev/null +++ b/FWGL/Key.hs @@ -0,0 +1,103 @@ +module FWGL.Key where + +-- | A mouse button. +data MouseButton = MouseLeft | MouseMiddle | MouseRight deriving (Eq, Show) + +-- | A keyboard key. +data Key = + KeyA + | KeyB + | KeyC + | KeyD + | KeyE + | KeyF + | KeyG + | KeyH + | KeyI + | KeyJ + | KeyK + | KeyL + | KeyM + | KeyN + | KeyO + | KeyP + | KeyQ + | KeyR + | KeyS + | KeyT + | KeyU + | KeyV + | KeyW + | KeyX + | KeyY + | KeyZ + | Key0 + | Key1 + | Key2 + | Key3 + | Key4 + | Key5 + | Key6 + | Key7 + | Key8 + | Key9 + | KeySpace + | KeyEnter + | KeyTab + | KeyEsc + | KeyBackspace + | KeyShift + | KeyControl + | KeyAlt + | KeyCapsLock + | KeyNumLock + | KeyArrowLeft + | KeyArrowUp + | KeyArrowRight + | KeyArrowDown + | KeyIns + | KeyDel + | KeyHome + | KeyEnd + | KeyPgUp + | KeyPgDown + | KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyPadDel + | KeyPadIns + | KeyPadEnd + | KeyPadDown + | KeyPadPgDown + | KeyPadLeft + | KeyPadRight + | KeyPadHome + | KeyPadUp + | KeyPadPgUp + | KeyPadAdd + | KeyPadSub + | KeyPadMul + | KeyPadDiv + | KeyPadEnter + | KeyPadDot + | KeyPad0 + | KeyPad1 + | KeyPad2 + | KeyPad3 + | KeyPad4 + | KeyPad5 + | KeyPad6 + | KeyPad7 + | KeyPad8 + | KeyPad9 + | KeyUnknown + deriving (Eq, Show) diff --git a/FWGL/Shader.hs b/FWGL/Shader.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts, RankNTypes #-} + +module FWGL.Shader ( + Shader, + VertexShader, + FragmentShader, + Typeable, + AllTypeable, + ShaderType, + UniformCPU, + AttributeCPU, + Float, + Sampler2D, + V2(..), + V3(..), + V4(..), + M2(..), + M3(..), + M4(..), + CFloat, + CSampler2D, + CV2, + CV3, + CV4, + CM2, + CM3, + CM4, + negate, + fromInteger, + fromRational, + (*), + (/), + (+), + (-), + (^), + (&&), + (||), + (==), + (>=), + (<=), + (<), + (>), + abs, + sign, + sqrt, + texture2D, + (>>=), + (>>), + fail, + return, + get, + global, + put, + putVertex, + putFragment, + (.), + id, + const, + flip, + ($) +) where + +import Data.Typeable (Typeable) +import qualified FWGL.Internal.GL as CPU +import FWGL.Shader.CPU (UniformCPU, AttributeCPU) +import FWGL.Shader.Language +import FWGL.Shader.Monad hiding (Shader) +import FWGL.Shader.Stages +import qualified FWGL.Vector as CPU +import Prelude ((.), id, const, flip, ($)) +import qualified Prelude as CPU + +type Shader g i o a = PartialShader g i o a + +type CFloat = CPU.Float +type CSampler2D = CPU.ActiveTexture +type CV2 = CPU.V2 +type CV3 = CPU.V3 +type CV4 = CPU.V4 +type CM2 = CPU.M2 +type CM3 = CPU.M3 +type CM4 = CPU.M4 diff --git a/FWGL/Shader/CPU.hs b/FWGL/Shader/CPU.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/CPU.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies #-} + +-- FWGL.Shader.Variables? (+ loadUniform, loadAttribute, inputName, etc.) +module FWGL.Shader.CPU where + +import Data.Word (Word) +import Data.Typeable +import qualified FWGL.Shader.Language as GPU +import FWGL.Internal.GL as CPU +import qualified FWGL.Vector as CPU +import Prelude as CPU + +class Typeable g => UniformCPU c g | g -> c where + setUniform :: UniformLocation -> g -> c -> GL () + +class Typeable g => AttributeCPU c g | g -> c where + encodeAttribute :: g -> [c] -> GL Array + setAttribute :: g -> GLUInt -> GL () + +instance GLES => UniformCPU CPU.Float GPU.Float where + setUniform l _ v = uniform1f l v + +instance GLES => AttributeCPU CPU.Float GPU.Float where + encodeAttribute _ a = liftIO $ encodeFloats a + setAttribute _ i = attr i 1 + +-- TODO +instance GLES => UniformCPU CPU.ActiveTexture GPU.Sampler2D where + setUniform l _ (CPU.ActiveTexture v) = uniform1i l $ fromIntegral v + +instance GLES => UniformCPU CPU.V2 GPU.V2 where + setUniform l _ (CPU.V2 x y) = uniform2f l x y + +instance GLES => AttributeCPU CPU.V2 GPU.V2 where + encodeAttribute _ a = liftIO $ encodeV2s a + setAttribute _ i = attr i 2 + +instance GLES => UniformCPU CPU.V3 GPU.V3 where + setUniform l _ (CPU.V3 x y z) = uniform3f l x y z + +instance GLES => AttributeCPU CPU.V3 GPU.V3 where + encodeAttribute _ a = liftIO $ encodeV3s a + setAttribute _ i = attr i 3 + +instance GLES => UniformCPU CPU.V4 GPU.V4 where + setUniform l _ (CPU.V4 x y z w) = uniform4f l x y z w + +instance GLES => AttributeCPU CPU.V4 GPU.V4 where + encodeAttribute _ a = liftIO $ encodeV4s a + setAttribute _ i = attr i 4 + +instance GLES => UniformCPU CPU.M2 GPU.M2 where + setUniform l _ m = liftIO (encodeM2 m) >>= uniformMatrix2fv l false + +instance GLES => UniformCPU CPU.M3 GPU.M3 where + setUniform l _ m = liftIO (encodeM3 m) >>= uniformMatrix3fv l false + +instance GLES => UniformCPU CPU.M4 GPU.M4 where + setUniform l _ m = liftIO (encodeM4 m) >>= uniformMatrix4fv l false + +attr :: GLES => GLUInt -> GLInt -> GL () +attr i s = vertexAttribPointer i s gl_FLOAT false 0 nullGLPtr diff --git a/FWGL/Shader/Default2D.hs b/FWGL/Shader/Default2D.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/Default2D.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DataKinds, + FlexibleContexts, RebindableSyntax, TypeFamilies #-} + +module FWGL.Shader.Default2D where + +import FWGL.Shader + +type Uniforms = '[View2, Image, Depth, Transform2] +type Attributes = '[Position2, UV] + +-- | An uniform that represents the texture used in the default 2D shader. +newtype Image = Image Sampler2D + deriving (Typeable, ShaderType, UniformCPU CSampler2D) + +-- | An uniform that represents the depth used in the default 2D shader. +newtype Depth = Depth Float + deriving (Typeable, ShaderType, UniformCPU CFloat) + +-- | An uniform that represents the transformation matrix used in the default +-- 2D shader. +newtype Transform2 = Transform2 M3 + deriving (Typeable, ShaderType, UniformCPU CM3) + +-- | An uniform that represents the view matrix used in the default 2D shader. +newtype View2 = View2 M3 + deriving (Typeable, ShaderType, UniformCPU CM3) + +newtype Position2 = Position2 V2 + deriving (Typeable, ShaderType, AttributeCPU CV2) + +newtype UV = UV V2 + deriving (Typeable, ShaderType, AttributeCPU CV2) + +vertexShader :: VertexShader '[Transform2, View2, Depth] + '[Position2, UV] '[UV] +vertexShader = do (Position2 (V2 x y)) <- get + uv@(UV _) <- get + Transform2 trans <- global + View2 view <- global + Depth z <- global + let V3 x' y' _ = view * trans * (V3 x y 1) + putVertex $ V4 x' y' z 1 + put uv + -- BUG + +fragmentShader :: FragmentShader '[Image] '[UV] +fragmentShader = do Image sampler <- global + UV (V2 s t) <- get + putFragment $ texture2D sampler (V2 s $ 1 - t) diff --git a/FWGL/Shader/Default3D.hs b/FWGL/Shader/Default3D.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/Default3D.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DataKinds, + FlexibleContexts, RebindableSyntax, TypeFamilies #-} + +module FWGL.Shader.Default3D where + +import FWGL.Shader.CPU +import FWGL.Shader +import qualified FWGL.Vector + +type Uniforms = '[Transform3, View3, Texture2] +type Attributes = '[Position3, UV, Normal3] + +newtype Texture2 = Texture2 Sampler2D + deriving (Typeable, ShaderType, UniformCPU CSampler2D) + +newtype Transform3 = Transform3 M4 + deriving (Typeable, ShaderType, UniformCPU CM4) + +newtype View3 = View3 M4 + deriving (Typeable, ShaderType, UniformCPU CM4) + +newtype Position3 = Position3 V3 + deriving (Typeable, ShaderType, AttributeCPU CV3) + +newtype Normal3 = Normal3 V3 + deriving (Typeable, ShaderType, AttributeCPU CV3) + +newtype UV = UV V2 + deriving (Typeable, ShaderType, AttributeCPU CV2) + +vertexShader :: VertexShader '[ Transform3, View3 ] + '[ Position3, UV, Normal3 ] + '[ UV ] +vertexShader = do v <- applyMatrices + get >>= \x@(UV _) -> put x + (Normal3 _) <- get + putVertex v + +applyMatrices :: Shader '[ Transform3, View3 ] + '[ Position3 ] + '[] + V4 +applyMatrices = do View3 viewMatrix <- global + Transform3 modelMatrix <- global + Position3 (V3 x y z) <- get + return $ + viewMatrix * modelMatrix * V4 x y z 1.0 + +fragmentShader :: FragmentShader '[ Texture2 ] [ UV, Normal3 ] +fragmentShader = do Texture2 sampler <- global + UV (V2 s t) <- get + putFragment . + texture2D sampler $ V2 s (1 - t) diff --git a/FWGL/Shader/GLSL.hs b/FWGL/Shader/GLSL.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/GLSL.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts #-} + +module FWGL.Shader.GLSL ( + vertexToGLSLAttr, + vertexToGLSL, + fragmentToGLSL, + shaderToGLSL, + exprToGLSL, + globalName, + attributeName +) where + +import Data.Typeable +import FWGL.Shader.Monad (Shader(..)) +import FWGL.Shader.Language (Expr(..), ShaderType(..)) +import FWGL.Shader.Stages (VertexShader, FragmentShader) + +type ShaderVars = ( [(String, String)] + , [(String, String, Int)] + , [(String, String, Expr)]) + +vertexToGLSLAttr :: VertexShader g i o -> (String, [(String, Int)]) +vertexToGLSLAttr v = + let r@(_, is, _) = snd $ reduce False v + in ( shaderToGLSL "" "attribute" "varying" + r [("hvVertexShaderOutput", "gl_Position")] + , map (\(t, n, s) -> (n, s)) is) + +vertexToGLSL :: VertexShader g i o -> String +vertexToGLSL = fst . vertexToGLSLAttr + +fragmentToGLSL :: FragmentShader g i -> String +fragmentToGLSL v = shaderToGLSL "precision mediump float;" + "varying" "" + (snd $ reduce True v) + [("hvFragmentShaderOutput", "gl_FragColor")] + +shaderToGLSL :: String -> String -> String -> ShaderVars -> [(String, String)] -> String +shaderToGLSL header ins outs (gs, is, os) predec = + header ++ + concatMap (var "uniform") gs ++ + concatMap (\(t, n, _) -> var ins (t, n)) is ++ + concatMap (\(t, n, _) -> if any ((== n) . fst) predec + then [] + else var outs (t, n) + ) os ++ + "void main(){" ++ + concatMap (\(_, n, e) -> replace n predec ++ "=" ++ + exprToGLSL e ++ ";") os ++ "}" + where var qual (ty, nm) = qual ++ " " ++ ty ++ " " ++ nm ++ ";" + replace x xs = case filter ((== x) . fst) xs of + ((_, y) : []) -> y + _ -> x + +reduce :: Bool -> Shader g i o a -> (a, ShaderVars) +reduce _ (Pure x) = (x, ([], [], [])) +reduce b (Bind s f) = case reduce b s of + (x, (gs, is, os)) -> case reduce b $ f x of + (y, (gs', is', os')) -> + (y, (gs ++ gs', is ++ is', os ++ os')) +reduce _ (Global :: Shader g i o a) = (fromExpr $ Read nm, ([(ty, nm)], [], [])) + where (ty, nm) = globalTypeAndName (undefined :: a) +reduce isFragment (Get :: Shader g i o a) = + (fromExpr $ Read nm, ([], [(ty, nm, size (undefined :: a))], [])) + where (ty, nm) = (if isFragment + then varyingTypeAndName + else attributeTypeAndName) (undefined :: a) +reduce _ (Put x) = ((), ([], [], [(ty, nm, toExpr x)])) + where (ty, nm) = varyingTypeAndName x + +exprToGLSL :: Expr -> String +exprToGLSL Nil = "" +exprToGLSL (Read s) = s +exprToGLSL (Op1 s e) = "(" ++ s ++ exprToGLSL e ++ ")" +exprToGLSL (Op2 s x y) = "(" ++ exprToGLSL x ++ s ++ exprToGLSL y ++ ")" +exprToGLSL (Apply s es) = s ++ "(" ++ tail (es >>= (',' :) . exprToGLSL) ++ ")" +exprToGLSL (X x) = exprToGLSL x ++ ".x" +exprToGLSL (Y x) = exprToGLSL x ++ ".y" +exprToGLSL (Z x) = exprToGLSL x ++ ".z" +exprToGLSL (W x) = exprToGLSL x ++ ".w" +exprToGLSL (Literal s) = s + +globalTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String) +globalTypeAndName t = (typeName t, globalName t) + +varyingTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String) +varyingTypeAndName t = (typeName t, varyingName t) + +attributeTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String) +attributeTypeAndName t = (typeName t, attributeName t) + +variableName :: Typeable t => t -> String +variableName = tyConName . typeRepTyCon . typeOf + +globalName :: Typeable t => t -> String +globalName = ("hg" ++) . variableName + +varyingName :: Typeable t => t -> String +varyingName = ("hv" ++) . variableName + +attributeName :: Typeable t => t -> String +attributeName = ("ha" ++) . variableName diff --git a/FWGL/Shader/Language.hs b/FWGL/Shader/Language.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/Language.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, FunctionalDependencies #-} + +module FWGL.Shader.Language ( + ShaderType(..), + Expr(..), + Float(..), + Sampler2D(..), + V2(..), + V3(..), + V4(..), + M2(..), + M3(..), + M4(..), + -- (==), (>=, >, ..), ifThenElse + fromRational, + fromInteger, + negate, + (*), + (/), + (+), + (-), + (^), + (&&), + (||), + (==), + (>=), + (<=), + (<), + (>), + abs, + sign, + texture2D, + sqrt, +) where + +import Data.Typeable +import Prelude (String, (.), ($)) +import qualified Prelude +import Text.Printf + +data Expr = Nil | Read String | Op1 String Expr | Op2 String Expr Expr + | Apply String [Expr] | X Expr | Y Expr | Z Expr | W Expr + | Literal String deriving (Prelude.Eq) + +newtype Bool = Bool Expr deriving Typeable +newtype Float = Float Expr deriving Typeable +newtype Sampler2D = Sampler2D Expr deriving Typeable +-- | NB: These are different types from 'FWGL.Vector.V2', 'FWGL.Vector.V3', etc. +data V2 = V2 Float Float deriving (Typeable) +data V3 = V3 Float Float Float deriving (Typeable) +data V4 = V4 Float Float Float Float deriving (Typeable) +data M2 = M2 V2 V2 deriving (Typeable) +data M3 = M3 V3 V3 V3 deriving (Typeable) +data M4 = M4 V4 V4 V4 V4 deriving (Typeable) + +infix 4 =! +(=!) :: Prelude.Eq a => a -> a -> Prelude.Bool +(=!) = (Prelude.==) + +infixr 3 &&! +(&&!) :: Prelude.Bool -> Prelude.Bool -> Prelude.Bool +(&&!) = (Prelude.&&) + +class ShaderType t where + toExpr :: t -> Expr + + fromExpr :: Expr -> t + + typeName :: t -> String + + size :: t -> Prelude.Int + +instance ShaderType Bool where + toExpr (Bool e) = e + + fromExpr = Bool + + typeName _ = "bool" + + size _ = 1 + +instance ShaderType Float where + toExpr (Float e) = e + + fromExpr = Float + + typeName _ = "float" + + size _ = 1 + +instance ShaderType Sampler2D where + toExpr (Sampler2D e) = e + + fromExpr = Sampler2D + + typeName _ = "sampler2D" + + size _ = 1 + +instance ShaderType V2 where + toExpr (V2 (Float (X v)) (Float (Y v'))) | v =! v' = v + toExpr (V2 (Float x) (Float y)) = Apply "vec2" [x, y] + + fromExpr v = V2 (Float (X v)) (Float (Y v)) + + typeName _ = "vec2" + + size _ = 1 + +instance ShaderType V3 where + toExpr (V3 (Float (X v)) (Float (Y v')) (Float (Z v''))) + | v =! v' &&! v' =! v'' = v + toExpr (V3 (Float x) (Float y) (Float z)) = Apply "vec3" [x, y, z] + + fromExpr v = V3 (Float (X v)) (Float (Y v)) (Float (Z v)) + + typeName _ = "vec3" + + size _ = 1 + +instance ShaderType V4 where + toExpr (V4 (Float (X v)) (Float (Y v1)) (Float (Z v2)) (Float (W v3))) + | v =! v1 &&! v1 =! v2 &&! v2 =! v3 = v + toExpr (V4 (Float x) (Float y) (Float z) (Float w)) = + Apply "vec4" [x, y, z, w] + + fromExpr v = V4 (Float (X v)) (Float (Y v)) (Float (Z v)) (Float (W v)) + + typeName _ = "vec4" + + size _ = 1 + +instance ShaderType M2 where + toExpr (M2 (V2 (Float (X (X m))) (Float (X (Y m1)))) + (V2 (Float (Y (X m2))) (Float (Y (Y m3))))) + | m =! m1 &&! m1 =! m2 &&! m2 =! m3 = m + toExpr (M2 (V2 (Float xx) (Float xy)) + (V2 (Float yx) (Float yy))) + = Apply "mat2" [xx, yx, xy, yy] + + fromExpr m = M2 (V2 (Float (X (X m))) (Float (Y (X m)))) + (V2 (Float (Y (X m))) (Float (Y (Y m)))) + + typeName _ = "mat2" + + size _ = 2 + +instance ShaderType M3 where + toExpr (M3 (V3 (Float (X (X m))) + (Float (X (Y m1))) + (Float (X (Z m2)))) + (V3 (Float (Y (X m3))) + (Float (Y (Y m4))) + (Float (Y (Z m5)))) + (V3 (Float (Z (X m6))) + (Float (Z (Y m7))) + (Float (Z (Z m8))))) + | m =! m1 &&! m1 =! m2 &&! m2 =! m3 &&! m3 =! m4 &&! + m4 =! m5 &&! m5 =! m6 &&! m6 =! m7 &&! m7 =! m8 = m + toExpr (M3 (V3 (Float xx) (Float xy) (Float xz)) + (V3 (Float yx) (Float yy) (Float yz)) + (V3 (Float zx) (Float zy) (Float zz))) + = Apply "mat3" [xx, yx, zx, xy, yy, zy, xz, yz, zz] + + fromExpr m = M3 (V3 (Float (X (X m))) + (Float (X (Y m))) + (Float (X (Z m)))) + (V3 (Float (Y (X m))) + (Float (Y (Y m))) + (Float (Y (Z m)))) + (V3 (Float (Z (X m))) + (Float (Z (Y m))) + (Float (Z (Z m)))) + + typeName _ = "mat3" + + size _ = 3 + +instance ShaderType M4 where + toExpr (M4 (V4 (Float (X (X m))) + (Float (X (Y m1))) + (Float (X (Z m2))) + (Float (X (W m3)))) + (V4 (Float (Y (X m4))) + (Float (Y (Y m5))) + (Float (Y (Z m6))) + (Float (Y (W m7)))) + (V4 (Float (Z (X m8))) + (Float (Z (Y m9))) + (Float (Z (Z m10))) + (Float (Z (W m11)))) + (V4 (Float (W (X m12))) + (Float (W (Y m13))) + (Float (W (Z m14))) + (Float (W (W m15))))) + | m =! m1 &&! m1 =! m2 &&! m2 =! m3 &&! m3 =! m4 &&! + m4 =! m5 &&! m5 =! m6 &&! m6 =! m7 &&! m7 =! m8 &&! + m8 =! m9 &&! m9 =! m10 &&! m10 =! m11 &&! m11 =! m12 &&! + m12 =! m13 &&! m13 =! m14 &&! m14 =! m15 = m + toExpr (M4 (V4 (Float xx) (Float xy) (Float xz) (Float xw)) + (V4 (Float yx) (Float yy) (Float yz) (Float yw)) + (V4 (Float zx) (Float zy) (Float zz) (Float zw)) + (V4 (Float wx) (Float wy) (Float wz) (Float ww))) + = Apply "mat4" [ xx, yx, zx, wx + , xy, yy, zy, wy + , xz, yz, zz, wz + , xw, yw, zw, ww ] + + fromExpr m = M4 (V4 (Float (X (X m))) + (Float (X (Y m))) + (Float (X (Z m))) + (Float (X (W m)))) + (V4 (Float (Y (X m))) + (Float (Y (Y m))) + (Float (Y (Z m))) + (Float (Y (W m)))) + (V4 (Float (Z (X m))) + (Float (Z (Y m))) + (Float (Z (Z m))) + (Float (Z (W m)))) + (V4 (Float (W (X m))) + (Float (W (Y m))) + (Float (W (Z m))) + (Float (W (W m)))) + + typeName _ = "mat4" + + size _ = 4 + +class Vector a +instance Vector V2 +instance Vector V3 +instance Vector V4 + +class Matrix a +instance Matrix M2 +instance Matrix M3 +instance Matrix M4 + +class Mul a b c | a b -> c +instance Mul Float Float Float +instance Mul V2 V2 V2 +instance Mul V3 V3 V3 +instance Mul V4 V4 V4 +instance Mul V2 Float V2 +instance Mul V3 Float V3 +instance Mul V4 Float V4 +instance Mul Float V2 V2 +instance Mul Float V3 V3 +instance Mul Float V4 V4 +instance Mul M2 M2 M2 +instance Mul M3 M3 M3 +instance Mul M4 M4 M4 +instance Mul M2 Float M2 +instance Mul M3 Float M3 +instance Mul M4 Float M4 +instance Mul Float M2 M2 +instance Mul Float M3 M3 +instance Mul Float M4 M4 +instance Mul M2 V2 V2 +instance Mul M3 V3 V3 +instance Mul M4 V4 V4 +instance Mul V2 M2 V2 +instance Mul V3 M3 V3 +instance Mul V4 M4 V4 + +infixl 7 * +(*) :: (Mul a b c, ShaderType a, ShaderType b, ShaderType c) => a -> b -> c +x * y = fromExpr $ Op2 "*" (toExpr x) (toExpr y) + +infixl 7 / +(/) :: (Mul a b c, ShaderType a, ShaderType b, ShaderType c) => a -> b -> c +x / y = fromExpr $ Op2 "/" (toExpr x) (toExpr y) + +class Sum a +instance Sum Float +instance Sum V2 +instance Sum V3 +instance Sum V4 +instance Sum M2 +instance Sum M3 +instance Sum M4 + +infixl 6 + +(+) :: (Sum a, ShaderType a) => a -> a -> a +x + y = fromExpr $ Op2 "+" (toExpr x) (toExpr y) + +infixl 6 - +(-) :: (Sum a, ShaderType a) => a -> a -> a +x - y = fromExpr $ Op2 "-" (toExpr x) (toExpr y) + +infixr 8 ^ +-- TODO: type-unsafe? +(^) :: (ShaderType a, ShaderType b) => a -> b -> a +x ^ y = fromExpr $ Apply "pow" [toExpr x, toExpr y] + +infixr 3 && +(&&) :: Bool -> Bool -> Bool +x && y = fromExpr $ Op2 "&&" (toExpr x) (toExpr y) + +infixr 2 || +(||) :: Bool -> Bool -> Bool +x || y = fromExpr $ Op2 "||" (toExpr x) (toExpr y) + +infix 4 == +(==) :: ShaderType a => a -> a -> Bool +x == y = fromExpr $ Op2 "==" (toExpr x) (toExpr y) + +infix 4 /= +(/=) :: ShaderType a => a -> a -> Bool +x /= y = fromExpr $ Op2 "!=" (toExpr x) (toExpr y) + +infix 4 >= +(>=) :: ShaderType a => a -> a -> Bool +x >= y = fromExpr $ Op2 ">=" (toExpr x) (toExpr y) + +infix 4 <= +(<=) :: ShaderType a => a -> a -> Bool +x <= y = fromExpr $ Op2 "<=" (toExpr x) (toExpr y) + +infix 4 < +(<) :: ShaderType a => a -> a -> Bool +x < y = fromExpr $ Op2 "<" (toExpr x) (toExpr y) + +infix 4 > +(>) :: ShaderType a => a -> a -> Bool +x > y = fromExpr $ Op2 ">" (toExpr x) (toExpr y) + +negate :: Float -> Float +negate (Float e) = Float $ Op1 "-" e + +fromInteger :: Prelude.Integer -> Float -- Integer +fromInteger = fromRational . Prelude.fromIntegral + +fromRational :: Prelude.Rational -> Float +fromRational = Float . Literal + . (printf "%f" :: Prelude.Float -> String) + . Prelude.fromRational + +abs :: Float -> Float +abs (Float e) = Float $ Apply "abs" [e] + +sign :: Float -> Float +sign (Float e) = Float $ Apply "sign" [e] + +-- TODO: add functions, ifThenElse, etc. + +sqrt :: Float -> Float +sqrt (Float e) = Float $ Apply "sqrt" [e] + +texture2D :: Sampler2D -> V2 -> V4 +texture2D (Sampler2D s) v = fromExpr $ Apply "texture2D" [s, toExpr v] diff --git a/FWGL/Shader/Monad.hs b/FWGL/Shader/Monad.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/Monad.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators, + RankNTypes, FlexibleContexts #-} + +module FWGL.Shader.Monad ( + Shader(..), + PartialShader, + Member, + AllTypeable, + Subset, + Equal, + Union, + Insert, + return, + get, + global, + put, + (>>), + (>>=), + fail +) where + +import Data.Typeable +import FWGL.Internal.TList +import FWGL.Shader.Language (ShaderType) +import Prelude (String, error) + +data Shader g i o a where + Pure :: a -> Shader g i o a + Bind :: Shader g' i' o' b + -> (b -> Shader g'' i'' o'' a) + -> Shader g i o a + Get :: (Member a i, Typeable a, ShaderType a) => Shader g i o a + Global :: (Member a g, Typeable a, ShaderType a) => Shader g i o a + -- Put :: (Typeable a, ShaderType a) => a -> Shader g i (a ': o) () + Put :: (Member a o, Typeable a, ShaderType a) => a -> Shader g i o () + +type PartialShader g i o a = + (Subset o o', Subset g g', Subset i i', Subset i' i) + => Shader g' i' o' a + +-- TODO: Shader è una monade e un funtore, non c'è bisogno di rebindare la +-- sintassi +return :: a -> Shader g i o a +return = Pure + +get :: (Member a i, Typeable a, ShaderType a) => Shader g i o a +get = Get + +global :: (Member a g, Typeable a, ShaderType a) => Shader g i o a +global = Global + +put :: (Member a o, Typeable a, ShaderType a) => a -> Shader g i o () +put = Put + +fail :: String -> Shader g i o a +fail = error + +(>>=) :: Shader g i o a -> (a -> Shader g i o b) -> Shader g i o b +(>>=) = Bind + +(>>) :: Shader g i o a -> Shader g i o b -> Shader g i o b +x >> y = x >>= \_ -> y + +class AllTypeable (xs :: [*]) +instance AllTypeable '[] +instance (Typeable x, AllTypeable xs) => AllTypeable (x ': xs) diff --git a/FWGL/Shader/Program.hs b/FWGL/Shader/Program.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/Program.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, + FunctionalDependencies, KindSignatures, DataKinds, + RankNTypes, FlexibleInstances, ScopedTypeVariables, + TypeOperators, ImpredicativeTypes, TypeSynonymInstances #-} + +module FWGL.Shader.Program ( + LoadedProgram(..), + Program, + program, + loadProgram, + castProgram, + DefaultUniforms2D, + DefaultAttributes2D, + DefaultUniforms3D, + DefaultAttributes3D, + defaultProgram3D, + defaultProgram2D +) where + +import Data.Hashable +import qualified Data.HashMap.Strict as H +import Data.Word (Word) +import qualified FWGL.Shader.Default2D as Default2D +import qualified FWGL.Shader.Default3D as Default3D +import FWGL.Shader.GLSL +import FWGL.Shader.Monad (Subset, Union, Insert) +import FWGL.Shader.Stages +import FWGL.Internal.GL hiding (Program) +import qualified FWGL.Internal.GL as GL +import FWGL.Internal.Resource +import Unsafe.Coerce + +-- | A vertex shader associated with a compatible fragment shader. +data Program (gs :: [*]) (is :: [*]) = + Program (String, [(String, Int)]) String Int + +data LoadedProgram = LoadedProgram !GL.Program (H.HashMap String Int) Int + + +-- | The uniforms used in the default 3D program. +type DefaultUniforms3D = Default3D.Uniforms + +-- | The attributes used in the default 3D program. +type DefaultAttributes3D = Default3D.Attributes + +-- | The uniforms used in the default 2D program. +type DefaultUniforms2D = Default2D.Uniforms + +-- | The attributes used in the default 2D program. +type DefaultAttributes2D = Default2D.Attributes + +instance Hashable (Program gs is) where + hashWithSalt salt (Program _ _ h) = hashWithSalt salt h + +instance Eq (Program gs is) where + (Program _ _ h) == (Program _ _ h') = h == h' + +instance Hashable LoadedProgram where + hashWithSalt salt (LoadedProgram _ _ h) = hashWithSalt salt h + +instance Eq LoadedProgram where + (LoadedProgram _ _ h) == (LoadedProgram _ _ h') = h == h' + +instance GLES => Resource (Program g i) LoadedProgram GL where + -- TODO: err check + loadResource i f = loadProgram i $ f . Right + unloadResource _ (LoadedProgram p _ _) = deleteProgram p + +castProgram :: Program gs is -> Program gs' is' +-- castProgram (Program v f h) = Program v f h +castProgram = unsafeCoerce + +-- | Create a 'Program' from the shaders. +program :: (Subset gs' gs, Subset gs'' gs, Subset os' os) + => VertexShader gs' is os -> FragmentShader gs'' os' + -> Program gs is +program vs fs = let (vss, attrs) = vertexToGLSLAttr vs + fss = fragmentToGLSL fs + in Program (vss, attrs) fss (hash (vss, fss)) + +defaultProgram3D :: Program DefaultUniforms3D DefaultAttributes3D +defaultProgram3D = program Default3D.vertexShader Default3D.fragmentShader + +defaultProgram2D :: Program DefaultUniforms2D DefaultAttributes2D +defaultProgram2D = program Default2D.vertexShader Default2D.fragmentShader + +loadProgram :: GLES => Program g i -> (LoadedProgram -> GL ()) -> GL () +loadProgram (Program (vss, attrs) fss h) = asyncGL $ do + glp <- createProgram + + vs <- loadSource gl_VERTEX_SHADER vss + fs <- loadSource gl_FRAGMENT_SHADER fss + attachShader glp vs + attachShader glp fs + + locs <- bindAttribs glp 0 attrs [] + linkProgram glp + + -- TODO: ?? + {- + detachShader glp vs + detachShader glp fs + -} + + return $ LoadedProgram glp (H.fromList locs) h + + where bindAttribs _ _ [] r = return r + bindAttribs glp i ((nm, sz) : xs) r = + bindAttribLocation glp (fromIntegral i) (toGLString nm) + >> bindAttribs glp (i + sz) xs ((nm, i) : r) + +loadSource :: GLES => GLEnum -> String -> GL Shader +loadSource ty src = + do shader <- createShader ty + shaderSource shader $ toGLString src + compileShader shader + return shader diff --git a/FWGL/Shader/Stages.hs b/FWGL/Shader/Stages.hs new file mode 100644 --- /dev/null +++ b/FWGL/Shader/Stages.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeOperators, DataKinds, GeneralizedNewtypeDeriving, + DeriveDataTypeable, RankNTypes, FlexibleContexts #-} + +module FWGL.Shader.Stages ( + VertexShader, + FragmentShader, + putVertex, + putFragment +) where + +import Data.Typeable + +import FWGL.Shader.Language +import FWGL.Shader.Monad + +type VertexShader g i o = Shader g i (VertexShaderOutput ': o) () +type FragmentShader g i = Shader g i (FragmentShaderOutput ': '[]) () + +newtype VertexShaderOutput = VSO V4 deriving (Typeable, ShaderType) +newtype FragmentShaderOutput = FSO V4 deriving (Typeable, ShaderType) + +putVertex :: Member VertexShaderOutput o => V4 -> Shader g i o () +-- putVertex :: V4 -> Shader '[] '[] (VertexShaderOutput ': '[]) () +putVertex = put . VSO + +putFragment :: Member FragmentShaderOutput o => V4 -> Shader g i o () +-- putFragment :: V4 -> Shader '[] '[] (FragmentShaderOutput ': '[]) () +putFragment = put . FSO diff --git a/FWGL/Texture.hs b/FWGL/Texture.hs new file mode 100644 --- /dev/null +++ b/FWGL/Texture.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module FWGL.Texture ( + Texture(..), + LoadedTexture(..), + mkTexture, + textureURL, + textureFile, + textureHash +) where + +import Data.Hashable + +import FWGL.Backend.GLES (GLES) +import FWGL.Backend.IO +import FWGL.Graphics.Color +import FWGL.Internal.GL hiding (Texture) +import qualified FWGL.Internal.GL as GL +import FWGL.Internal.Resource + +-- | A texture. +data Texture = TexturePixels [Color] GLSize GLSize Int + | TextureURL String Int + +data LoadedTexture = LoadedTexture GLSize GLSize GL.Texture + +-- | Creates a 'Texture' from a list of pixels. +mkTexture :: GLES + => Int -- ^ Width. + -> Int -- ^ Height. + -> [Color] -- ^ List of pixels + -> Texture +mkTexture w h ps = TexturePixels ps (fromIntegral w) (fromIntegral h) $ hash ps + +-- | Creates a 'Texture' from an URL (JavaScript only). +textureURL :: String -- ^ URL + -> Texture +textureURL url = TextureURL url $ hash url + +-- | Creates a 'Texture' from a file (Desktop only). +textureFile :: String -> Texture +textureFile = textureURL + +textureHash :: Texture -> Int +textureHash (TexturePixels _ _ _ h) = h +textureHash (TextureURL _ h) = h + +instance Hashable Texture where + hashWithSalt salt tex = hashWithSalt salt $ textureHash tex + +instance Eq Texture where + (TexturePixels _ _ _ h) == (TexturePixels _ _ _ h') = h == h' + (TextureURL _ h) == (TextureURL _ h') = h == h' + _ == _ = False + +instance (BackendIO, GLES) => Resource Texture LoadedTexture GL where + loadResource i f = loadTexture i $ f . Right -- TODO: err check + unloadResource _ (LoadedTexture _ _ t) = deleteTexture t + +loadTexture :: (BackendIO, GLES) => Texture -> (LoadedTexture -> GL ()) -> GL () +loadTexture tex f = + case tex of + (TexturePixels ps w h _) -> flip asyncGL f $ + do t <- setup + arr <- liftIO $ encodeColors ps + texImage2DBuffer gl_TEXTURE_2D 0 + (fromIntegral gl_RGBA) + w h 0 + gl_RGBA + gl_UNSIGNED_BYTE + arr + return $ LoadedTexture (fromIntegral w) + (fromIntegral h) + t + (TextureURL url _) -> + do ctx <- getCtx + liftIO $ loadImage url $ \(img, w, h) -> + flip evalGL ctx $ do + t <- setup + texImage2DImage gl_TEXTURE_2D 0 + (fromIntegral gl_RGBA) + gl_RGBA + gl_UNSIGNED_BYTE + img + f $ LoadedTexture (fromIntegral w) + (fromIntegral h) + t + where setup = do -- XXX + t <- createTexture + bindTexture gl_TEXTURE_2D t + param gl_TEXTURE_MAG_FILTER gl_LINEAR + param gl_TEXTURE_MIN_FILTER gl_LINEAR + param gl_TEXTURE_WRAP_S gl_REPEAT + param gl_TEXTURE_WRAP_T gl_REPEAT + return t + param :: GLEnum -> GLEnum -> GL () + param p v = texParameteri gl_TEXTURE_2D p $ fromIntegral v + diff --git a/FWGL/Utils.hs b/FWGL/Utils.hs new file mode 100644 --- /dev/null +++ b/FWGL/Utils.hs @@ -0,0 +1,55 @@ +module FWGL.Utils ( + screenScale +) where + +import FRP.Yampa +import FWGL.Input +import FWGL.Graphics.Custom + +-- | 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)) + +-- | Like 'dynamic', but instead of comparing the two objects it checks the +-- event with the new object. +dynamicE :: Object g i -- ^ Initial 'Object'. + -> SF (Event (Object g i)) (Object g i) +dynamicE = dynamicG $ flip const + +-- | Automatically deallocate the previous mesh from the GPU when it changes. +dynamic :: SF (Object g i) (Object g i) +dynamic = undefined +{- +dynamic = + dynamicG (\ o n -> if objectGeometry o == objectGeometry n + then Event n + else NoEvent + ) nothing +-} + +dynamicG :: (Object g i -> a -> Event (Object g i)) -> (Object g i) -> SF a (Object g i) +dynamicG = undefined +{- +dynamicG f i = flip sscan i $ \ oldObj inp -> + case f oldObj inp of + Event (SolidObject (Solid (StaticGeom newG) mat tex)) -> + SolidObject ( + Solid (DynamicGeom (objectGeometry oldObj) + newG) + mat + tex + ) + NoEvent -> case oldObj of + SolidObject ( + Solid (DynamicGeom _ new) mat t + ) -> SolidObject ( + Solid (StaticGeom new) + mat + t + ) + _ -> oldObj + _ -> error "dynamicG: not a Geometry." +-} + diff --git a/FWGL/Vector.hs b/FWGL/Vector.hs new file mode 100644 --- /dev/null +++ b/FWGL/Vector.hs @@ -0,0 +1,286 @@ +module FWGL.Vector ( + V2(..), + V3(..), + V4(..), + M2(..), + M3(..), + M4(..), + vec2, + vec3, + vec4, + mat2, + mat3, + mul3, + mat4, + mul4, + transpose4, + idMat4, + transMat4, + rotXMat4, + rotYMat4, + rotZMat4, + rotAAMat4, + scaleMat4, + idMat3, + transMat3, + rotMat3, + scaleMat3 +) where + +import Control.Applicative +import Data.Hashable +import Foreign.Storable +import Foreign.Ptr (castPtr) + +-- | Two-dimensional vector. +data V2 = V2 !Float !Float deriving (Show, Eq) + +-- | Three-dimensional vector. +data V3 = V3 !Float !Float !Float deriving (Show, Eq) + +-- | Four-dimensional vector. +data V4 = V4 !Float !Float !Float !Float deriving (Show, Eq) + +-- | 2x2 matrix. +data M2 = M2 !V2 !V2 deriving (Show, Eq) + +-- | 3x3 matrix. +data M3 = M3 !V3 !V3 !V3 deriving (Show, Eq) + +-- | 4x4 matrix. +data M4 = M4 !V4 !V4 !V4 !V4 deriving (Show, Eq) + +instance Hashable V2 where + hashWithSalt s (V2 x y) = hashWithSalt s (x, y) + +instance Hashable V3 where + hashWithSalt s (V3 x y z) = hashWithSalt s (x, y, z) + +instance Hashable V4 where + hashWithSalt s (V4 x y z w) = hashWithSalt s (x, y, z, w) + +instance Storable V2 where + sizeOf _ = 2 * sizeOf (undefined :: Float) + alignment _ = alignment (undefined :: Float) + peek ptr = V2 <$> peek (castPtr ptr) + <*> peekElemOff (castPtr ptr) 1 + poke ptr (V2 x y) = poke (castPtr ptr) x >> pokeElemOff (castPtr ptr) 1 y + +instance Storable V3 where + sizeOf _ = 3 * sizeOf (undefined :: Float) + alignment _ = alignment (undefined :: Float) + peek ptr = V3 <$> peek (castPtr ptr) + <*> peekElemOff (castPtr ptr) 1 + <*> peekElemOff (castPtr ptr) 2 + poke ptr (V3 x y z) = zipWithM_ (pokeElemOff $ castPtr ptr) + [0 .. 2] [x, y, z] +instance Storable V4 where + sizeOf _ = 4 * sizeOf (undefined :: Float) + alignment _ = alignment (undefined :: Float) + peek ptr = V4 <$> peek (castPtr ptr) + <*> peekElemOff (castPtr ptr) 1 + <*> peekElemOff (castPtr ptr) 2 + <*> peekElemOff (castPtr ptr) 3 + poke ptr (V4 x y z w) = zipWithM_ (pokeElemOff $ castPtr ptr) + [0 .. 3] [x, y, z, w] + +-- | Create a two-dimensional vector. +vec2 :: (Float, Float) -> V2 +vec2 = uncurry V2 + +-- | Create a three-dimensional vector. +vec3 :: (Float, Float, Float) -> V3 +vec3 (x, y, z) = V3 x y z + +-- | Create a four-dimensional vector. +vec4 :: (Float, Float, Float, Float) -> V4 +vec4 (x, y, z, w) = V4 x y z w + +-- | Create a 2x2 matrix. +mat2 :: ( Float, Float + , Float, Float ) -> M2 +mat2 (a, a', b, b') = M2 (V2 a a') (V2 b b') + +-- | Create a 3x3 matrix. +mat3 :: ( Float, Float, Float + , Float, Float, Float + , Float, Float, Float ) -> M3 +mat3 (a1, a2, a3, b1, b2, b3, c1, c2, c3) = + M3 (V3 a1 a2 a3) + (V3 b1 b2 b3) + (V3 c1 c2 c3) + +mat4from3 :: ( Float, Float, Float + , Float, Float, Float + , Float, Float, Float ) -> M4 +mat4from3 (a1, a2, a3, b1, b2, b3, c1, c2, c3) = + M4 (V4 a1 a2 a3 0) + (V4 b1 b2 b3 0) + (V4 c1 c2 c3 0) + (V4 0 0 0 1) + +mat3from2 :: (Float, Float, Float, Float) -> M3 +mat3from2 (a1, a2, b1, b2) = M3 (V3 a1 a2 0) + (V3 b1 b2 0) + (V3 0 0 1) + +-- | Create a 4x4 matrix. +mat4 :: ( Float, Float, Float, Float + , Float, Float, Float, Float + , Float, Float, Float, Float + , Float, Float, Float, Float ) -> M4 +mat4 (a1, a2, a3, a4, b1, b2, b3, b4, c1, c2, c3, c4, d1, d2, d3, d4) = + M4 (V4 a1 a2 a3 a4) + (V4 b1 b2 b3 b4) + (V4 c1 c2 c3 c4) + (V4 d1 d2 d3 d4) + +-- | 3x3 matrix multiplication. +mul3 :: M3 -> M3 -> M3 +mul3 (M3 (V3 a11 a12 a13) + (V3 a21 a22 a23) + (V3 a31 a32 a33)) + (M3 (V3 b11 b12 b13) + (V3 b21 b22 b23) + (V3 b31 b32 b33)) = + mat3 ( + a11 * b11 + a12 * b21 + a13 * b31, + a11 * b12 + a12 * b22 + a13 * b32, + a11 * b13 + a12 * b23 + a13 * b33, + + a21 * b11 + a22 * b21 + a23 * b31, + a21 * b12 + a22 * b22 + a23 * b32, + a21 * b13 + a22 * b23 + a23 * b33, + + a31 * b11 + a32 * b21 + a33 * b31, + a31 * b12 + a32 * b22 + a33 * b32, + a31 * b13 + a32 * b23 + a33 * b33 + ) + + +-- | 4x4 matrix multiplication. +mul4 :: M4 -> M4 -> M4 +mul4 (M4 (V4 _1 _2 _3 _4) + (V4 _5 _6 _7 _8) + (V4 _9 _a _b _c) + (V4 _d _e _f _g)) + (M4 (V4 a b c d) + (V4 e f g h) + (V4 i j k l) + (V4 m n o p)) = + mat4 ( + _1 * a + _2 * e + _3 * i + _4 * m, + _1 * b + _2 * f + _3 * j + _4 * n, + _1 * c + _2 * g + _3 * k + _4 * o, + _1 * d + _2 * h + _3 * l + _4 * p, + + _5 * a + _6 * e + _7 * i + _8 * m, + _5 * b + _6 * f + _7 * j + _8 * n, + _5 * c + _6 * g + _7 * k + _8 * o, + _5 * d + _6 * h + _7 * l + _8 * p, + + _9 * a + _a * e + _b * i + _c * m, + _9 * b + _a * f + _b * j + _c * n, + _9 * c + _a * g + _b * k + _c * o, + _9 * d + _a * h + _b * l + _c * p, + + _d * a + _e * e + _f * i + _g * m, + _d * b + _e * f + _f * j + _g * n, + _d * c + _e * g + _f * k + _g * o, + _d * d + _e * h + _f * l + _g * p + ) + +-- | Transpose a 4x4 matrix. +transpose4 :: M4 -> M4 +transpose4 (M4 (V4 a1 a2 a3 a4) + (V4 b1 b2 b3 b4) + (V4 c1 c2 c3 c4) + (V4 d1 d2 d3 d4)) = M4 (V4 a1 b1 c1 d1) + (V4 a2 b2 c2 d2) + (V4 a3 b3 c3 d3) + (V4 a4 b4 c4 d4) + +-- | 4x4 identity matrix. +idMat4 :: M4 +idMat4 = mat4from3 ( 1, 0, 0 + , 0, 1, 0 + , 0, 0, 1 ) + +-- | 4x4 translation matrix. +transMat4 :: V3 -> M4 +transMat4 (V3 x y z) = mat4 ( 1, 0, 0, 0 + , 0, 1, 0, 0 + , 0, 0, 1, 0 + , x, y, z, 1 ) + +-- | 4x4 rotation matrix (X axis). +rotXMat4 :: Float -> M4 +rotXMat4 a = mat4from3 ( 1, 0, 0 + , 0, cos a, - sin a + , 0, sin a, cos a ) + +-- | 4x4 rotation matrix (Y axis). +rotYMat4 :: Float -> M4 +rotYMat4 a = mat4from3 ( cos a, 0, sin a + , 0, 1, 0 + , - sin a, 0, cos a ) + +-- | 4x4 rotation matrix (Z axis). +rotZMat4 :: Float -> M4 +rotZMat4 a = mat4from3 ( cos a, - sin a, 0 + , sin a, cos a, 0 + , 0, 0, 1 ) + +-- | 4x4 rotation matrix. +rotAAMat4 :: V3 -- ^ Axis. + -> Float -- ^ Angle + -> M4 +rotAAMat4 v = quatToMat4 . rotAAQuat v + +-- | Rotation quaternion. +rotAAQuat :: V3 -> Float -> V4 +rotAAQuat (V3 x y z) a = V4 (x * s) (y * s) (z * s) (cos $ a / 2) + where s = sin $ a / 2 + +-- | 4x4 scale matrix. +scaleMat4 :: V3 -> M4 +scaleMat4 (V3 x y z) = mat4from3 ( x, 0, 0 + , 0, y, 0 + , 0, 0, z ) + +-- | 4x4 perspective matrix. +perspectiveMat4 :: Float -> Float -> Float -> Float -> M4 +perspectiveMat4 f n fov ar = + mat4 ( s / ar , 0 , 0 , 0 + , 0 , s , 0 , 0 + , 0 , 0 , (f + n) / (n - f) , (2 * f * n) / (n - f) + , 0 , 0 , - 1 , 0) + where s = 1 / tan (fov * pi / 360) + +-- | Quaternion to 4x4 matrix. +quatToMat4 :: V4 -> M4 +quatToMat4 (V4 x y z w) = mat4from3 ( + 1 - 2 * y ^ 2 - 2 * z ^ 2, 2 * x * y - 2 * z * w, 2 * x * z + 2 * y * w, + 2 * x * y + 2 * z * w, 1 - 2 * x ^ 2 - 2 * z ^ 2, 2 * y * z - 2 * x * w, + 2 * x * z - 2 * y * w, 2 * y * z + 2 * x * w, 1 - 2 * x ^ 2 - 2 * y ^ 2) + +-- | The identity 3x3 matrix. +idMat3 :: M3 +idMat3 = mat3from2 (1, 0, 0, 1) + +-- | 3x3 translation matrix. +transMat3 :: V2 -> M3 +transMat3 (V2 x y) = mat3 ( 1, 0, 0 + , 0, 1, 0 + , x, y, 1 ) + +-- | 3x3 rotation matrix. +rotMat3 :: Float -> M3 +rotMat3 a = mat3from2 (cos a, sin a, - sin a, cos a) + +-- | 3x3 scale matrix. +scaleMat3 :: V2 -> M3 +scaleMat3 (V2 x y) = mat3from2 (x, 0, 0, y) + +zipWithM_ :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ f xs = sequence_ . zipWith f xs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014-2015, Luca Prezzavento + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Luca "ZioCrocifisso" Prezzavento nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fwgl.cabal b/fwgl.cabal new file mode 100644 --- /dev/null +++ b/fwgl.cabal @@ -0,0 +1,22 @@ +name: fwgl +version: 0.1.0.0 +synopsis: FRP 2D/3D game engine +description: FRP 2D/3D game engine (work in progress) +homepage: https://github.com/ZioCrocifisso/FWGL +license: BSD3 +license-file: LICENSE +author: Luca "ZioCrocifisso" Prezzavento +maintainer: ziocroc@hotmail.it +category: Game +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: FWGL, FWGL.Shader, FWGL.Geometry, FWGL.Utils, FWGL.Vector, FWGL.Texture, FWGL.Audio, FWGL.Key, FWGL.Backend, FWGL.Input, FWGL.Graphics.Draw, FWGL.Graphics.D2, FWGL.Graphics.Types, FWGL.Graphics.Color, FWGL.Graphics.Custom, FWGL.Graphics.Shapes, FWGL.Internal.GL, FWGL.Internal.TList, FWGL.Geometry.OBJ, FWGL.Shader.GLSL, FWGL.Shader.Stages, FWGL.Shader.Program, FWGL.Shader.CPU, FWGL.Shader.Default3D, FWGL.Shader.Monad, FWGL.Shader.Language, FWGL.Shader.Default2D, FWGL.Backend.JavaScript + -- , FWGL.Backend.OpenGL.GL32, FWGL.Backend.OpenGL.Common, FWGL.Backend.OpenGL.GLES20, FWGL.Backend.GLFW.GL32, FWGL.Backend.GLFW.Common, FWGL.Backend.GLFW.GLES20, FWGL.Graphics.D3, + other-modules: FWGL.Internal.STVectorLen, FWGL.Internal.Resource, FWGL.Backend.JavaScript.WebGL, FWGL.Backend.JavaScript.Event, FWGL.Backend.JavaScript.WebGL.Const, FWGL.Backend.JavaScript.WebGL.Types, FWGL.Backend.JavaScript.WebGL.Raw, FWGL.Backend.GLES, FWGL.Backend.IO + other-extensions: FlexibleContexts, RankNTypes, GADTs, TypeOperators, KindSignatures, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, ConstraintKinds, TypeFamilies, ExistentialQuantification, GeneralizedNewtypeDeriving, PolyKinds, UndecidableInstances, ScopedTypeVariables, OverlappingInstances, FunctionalDependencies, DeriveDataTypeable, ImpredicativeTypes, RebindableSyntax, NullaryTypeClasses, Arrows + build-depends: base >=4.7 && <4.8, Yampa >=0.9 && <0.10, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.11, transformers, ghcjs-base + -- , gl >=0.6 && <0.7, JuicyPixels >=3.2 && <3.3, GLFW-b >=1.4 && <1.5, random >=1.1 && <1.2 + hs-source-dirs: . + default-language: Haskell2010