├── .gitignore ├── README.md ├── bsconfig.json ├── build.ninja ├── build_script.re ├── example └── example.re ├── index.html ├── package-lock.json ├── package.json ├── require_polyfill.js ├── src ├── RGLConstants.re ├── RGLEvents.re ├── RGLInterface.re ├── ReasonglInterface.re ├── events.ml ├── native │ ├── events_native.ml │ ├── reasongl.c │ └── reasongl_native.ml ├── reasongl.ml └── web │ ├── events_web.ml │ └── reasongl_web.ml └── yarn.lock /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | _build 3 | lib 4 | .merlin 5 | *.o 6 | .static_libraries 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ReasonGL 2 | --- 3 | GL library for web and native. 4 | 5 | If you'd like a higher level API than GL, check out [Reprocessing](https://github.com/Schmavery/reprocessing). 6 | 7 | Install 8 | === 9 | This library is designed to be used with [bsb-native](https://github.com/bsansouci/bsb-native). 10 | 11 | Install it using: 12 | `npm install bsansouci/reasongl` 13 | 14 | Documentation 15 | === 16 | All of the method names are taken directly from opengl, and their docs should apply. 17 | 18 | Example projects 19 | === 20 | If you want to get started quickly, check out [this simple branch of ReasonglExampleProject](https://github.com/bsansouci/reasonglexampleproject/tree/simple). It's a great starting point to any project using `ReasonGL` directly. The master branch is a much bigger and complete example. 21 | 22 | [ReWitness](https://github.com/bsansouci/rewitness) is another big example project using those bindings. 23 | 24 | How it works 25 | === 26 | ReasonGL works by exposing a common interface between WebGL and OpenGL and then choosing a backend to use as the implementation of the interface at compile time. 27 | 28 | Related libraries 29 | === 30 | If you want super thin direct bindings to OpenGL use [tgls](https://github.com/bsansouci/tgls). 31 | 32 | If you want direct bindings to SDL use [tsdl](https://github.com/bsansouci/tsdl). 33 | -------------------------------------------------------------------------------- /bsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "@bsansouci/reasongl", 3 | "sources": [{ 4 | "dir": "src", 5 | "subdirs": [{ 6 | "dir": "native", 7 | "backend": ["native", "bytecode"] 8 | },{ 9 | "dir": "web", 10 | "backend": ["js"] 11 | }] 12 | },{ 13 | "dir": "example", 14 | "type": "dev" 15 | }], 16 | "warnings": {"number": "-44"}, 17 | "bs-dependencies": ["@bsansouci/tsdl", "@bsansouci/tgls", "unix", "bigarray"], 18 | "static-libraries": ["reasongl.o"], 19 | "entries": [ { 20 | "backend": "native", 21 | "main-module": "Example" 22 | },{ 23 | "backend": "bytecode", 24 | "main-module": "Example" 25 | },{ 26 | "backend": "js", 27 | "main-module": "Example" 28 | }], 29 | "refmt": 3 30 | } 31 | -------------------------------------------------------------------------------- /build.ninja: -------------------------------------------------------------------------------- 1 | build reasongl.o: cc $src_root_dir/src/native/reasongl.c 2 | -------------------------------------------------------------------------------- /build_script.re: -------------------------------------------------------------------------------- 1 | open Bsb_internals; 2 | 3 | 4 | let ( +/ ) = Filename.concat; 5 | 6 | gcc("lib" +/ "reasongl.o", ["src" +/ "native" +/ "reasongl.c"]); 7 | -------------------------------------------------------------------------------- /example/example.re: -------------------------------------------------------------------------------- 1 | module Constants = RGLConstants; 2 | 3 | module Gl = Reasongl.Gl; 4 | 5 | 6 | /*** 7 | * This program is an example of how to draw a square. 8 | * You can vary the number of vertices drawn, allowing you to draw triangles, squares and circles. 9 | */ 10 | type glCamera = {projectionMatrix: Gl.Mat4.t}; 11 | 12 | type glEnv = { 13 | camera: glCamera, 14 | window: Gl.Window.t, 15 | context: Gl.contextT 16 | }; 17 | 18 | 19 | /*** 20 | * Helper function which will initialize the shaders and attach them to the GL context. 21 | * Returns the program. 22 | */ 23 | let getProgram = 24 | ( 25 | ~context: Gl.contextT, 26 | ~vertexShader as vertexShaderSource: string, 27 | ~fragmentShader as fragmentShaderSource: string 28 | ) 29 | : option(Gl.programT) => { 30 | let vertexShader = Gl.createShader(~context, Constants.vertex_shader); 31 | Gl.shaderSource(~context, ~shader=vertexShader, ~source=vertexShaderSource); 32 | Gl.compileShader(~context, vertexShader); 33 | let compiledCorrectly = 34 | Gl.getShaderParameter(~context, ~shader=vertexShader, ~paramName=Gl.Compile_status) == 1; 35 | if (compiledCorrectly) { 36 | let fragmentShader = Gl.createShader(~context, Constants.fragment_shader); 37 | Gl.shaderSource(~context, ~shader=fragmentShader, ~source=fragmentShaderSource); 38 | Gl.compileShader(~context, fragmentShader); 39 | let compiledCorrectly = 40 | Gl.getShaderParameter(~context, ~shader=fragmentShader, ~paramName=Gl.Compile_status) == 1; 41 | if (compiledCorrectly) { 42 | let program = Gl.createProgram(~context); 43 | Gl.attachShader(~context, ~program, ~shader=vertexShader); 44 | Gl.deleteShader(~context, vertexShader); 45 | Gl.attachShader(~context, ~program, ~shader=fragmentShader); 46 | Gl.deleteShader(~context, fragmentShader); 47 | Gl.linkProgram(~context, program); 48 | let linkedCorrectly = 49 | Gl.getProgramParameter(~context, ~program, ~paramName=Gl.Link_status) == 1; 50 | if (linkedCorrectly) { 51 | Some(program) 52 | } else { 53 | print_endline @@ "Linking error: " ++ Gl.getProgramInfoLog(~context, program); 54 | None 55 | } 56 | } else { 57 | print_endline @@ "Fragment shader error: " ++ Gl.getShaderInfoLog(~context, fragmentShader); 58 | None 59 | } 60 | } else { 61 | print_endline @@ "Vertex shader error: " ++ Gl.getShaderInfoLog(~context, vertexShader); 62 | None 63 | } 64 | }; 65 | 66 | 67 | /*** 68 | * Dumb vertex shader which take for input a vertex position and a vertex color and maps the point onto 69 | * the screen. 70 | * Fragment shader simply applies the color to the pixel. 71 | */ 72 | let vertexShaderSource = {| 73 | attribute vec3 aVertexPosition; 74 | attribute vec4 aVertexColor; 75 | 76 | uniform mat4 uPMatrix; 77 | 78 | varying vec4 vColor; 79 | 80 | void main(void) { 81 | gl_Position = uPMatrix * vec4(aVertexPosition, 1.0); 82 | vColor = aVertexColor; 83 | } 84 | |}; 85 | 86 | let fragmentShaderSource = {| 87 | varying vec4 vColor; 88 | 89 | void main(void) { 90 | gl_FragColor = vColor; 91 | } 92 | |}; 93 | 94 | 95 | /*** This initializes the window **/ 96 | let window = Gl.Window.init(~screen="main", ~argv=Sys.argv); 97 | 98 | let windowSize = 600; 99 | 100 | Gl.Window.setWindowSize(~window, ~width=windowSize, ~height=windowSize); 101 | 102 | 103 | /*** Initialize the Gl context **/ 104 | let context = Gl.Window.getContext(window); 105 | 106 | Gl.viewport(~context, ~x=0, ~y=0, ~width=windowSize, ~height=windowSize); 107 | 108 | /* Gl.clearColor context 1.0 1.0 1.0 1.0; */ 109 | Gl.clear(~context, ~mask=Constants.color_buffer_bit lor Constants.depth_buffer_bit); 110 | 111 | 112 | /*** Camera is a simple record containing one matrix used to project a point in 3D onto the screen. **/ 113 | let camera = {projectionMatrix: Gl.Mat4.create()}; 114 | 115 | 116 | /*** 117 | * Those buffers are basically pointers to chunks of memory on the graphics card. They're used to store the 118 | * vertex and color data. 119 | */ 120 | let vertexBuffer = Gl.createBuffer(~context); 121 | 122 | let colorBuffer = Gl.createBuffer(~context); 123 | 124 | 125 | /*** Compiles the shaders and gets the program with the shaders loaded into **/ 126 | let program = 127 | switch ( 128 | getProgram(~context, ~vertexShader=vertexShaderSource, ~fragmentShader=fragmentShaderSource) 129 | ) { 130 | | None => failwith("Could not create the program and/or the shaders. Aborting.") 131 | | Some(program) => program 132 | }; 133 | 134 | Gl.useProgram(~context, program); 135 | 136 | 137 | /*** Get the attribs ahead of time to be used inside the render function **/ 138 | let aVertexPosition = Gl.getAttribLocation(~context, ~program, ~name="aVertexPosition"); 139 | 140 | Gl.enableVertexAttribArray(~context, ~attribute=aVertexPosition); 141 | 142 | let aVertexColor = Gl.getAttribLocation(~context, ~program, ~name="aVertexColor"); 143 | 144 | Gl.enableVertexAttribArray(~context, ~attribute=aVertexColor); 145 | 146 | let pMatrixUniform = Gl.getUniformLocation(~context, ~program, ~name="uPMatrix"); 147 | 148 | Gl.uniformMatrix4fv(~context, ~location=pMatrixUniform, ~value=camera.projectionMatrix); 149 | 150 | 151 | /*** 152 | * Will mutate the projectionMatrix to be an ortho matrix with the given boundaries. 153 | * See this link for quick explanation of what this is. 154 | * https://shearer12345.github.io/graphics/assets/projectionPerspectiveVSOrthographic.png 155 | */ 156 | Gl.Mat4.ortho( 157 | ~out=camera.projectionMatrix, 158 | ~left=0., 159 | ~right=float_of_int(Gl.Window.getWidth(window)), 160 | ~bottom=0., 161 | ~top=float_of_int(Gl.Window.getHeight(window)), 162 | ~near=0., 163 | ~far=100. 164 | ); 165 | 166 | 167 | /*** 168 | * Render simply draws a rectangle. 169 | */ 170 | let render = (_) => { 171 | /* 0,0 is the bottom left corner */ 172 | let x = 150; 173 | let y = 150; 174 | let width = 300; 175 | let height = 300; 176 | 177 | /*** 178 | * Setup vertices to be sent to the GPU and bind the data on the "register" called `array_buffer`. 179 | */ 180 | let square_vertices = [| 181 | float_of_int @@ x + width, 182 | float_of_int @@ y + height, 183 | 0.0, 184 | float_of_int(x), 185 | float_of_int @@ y + height, 186 | 0.0, 187 | float_of_int @@ x + width, 188 | float_of_int(y), 189 | 0.0, 190 | float_of_int(x), 191 | float_of_int(y), 192 | 0.0 193 | |]; 194 | Gl.bindBuffer(~context, ~target=Constants.array_buffer, ~buffer=vertexBuffer); 195 | Gl.bufferData( 196 | ~context, 197 | ~target=Constants.array_buffer, 198 | ~data=Gl.Bigarray.(of_array(Float32, square_vertices)), 199 | ~usage=Constants.static_draw 200 | ); 201 | Gl.vertexAttribPointer( 202 | ~context, 203 | ~attribute=aVertexPosition, 204 | ~size=3, 205 | ~type_=Constants.float_, 206 | ~normalize=false, 207 | ~stride=0, 208 | ~offset=0 209 | ); 210 | 211 | /*** Setup colors to be sent to the GPU **/ 212 | let r = 1.; 213 | let g = 0.; 214 | let b = 0.; 215 | let a = 1.; 216 | let square_colors = [|r, g, b, a, r, g, b, a, r, g, b, a, r, g, b, a|]; 217 | Gl.bindBuffer(~context, ~target=Constants.array_buffer, ~buffer=colorBuffer); 218 | Gl.bufferData( 219 | ~context, 220 | ~target=Constants.array_buffer, 221 | ~data=Gl.Bigarray.(of_array(Float32, square_colors)), 222 | ~usage=Constants.static_draw 223 | ); 224 | Gl.vertexAttribPointer( 225 | ~context, 226 | ~attribute=aVertexColor, 227 | ~size=4, 228 | ~type_=Constants.float_, 229 | ~normalize=false, 230 | ~stride=0, 231 | ~offset=0 232 | ); 233 | Gl.uniformMatrix4fv(~context, ~location=pMatrixUniform, ~value=camera.projectionMatrix); 234 | 235 | /*** Final call which actually does the "draw" **/ 236 | Gl.drawArrays(~context, ~mode=Constants.triangle_strip, ~first=0, ~count=4) 237 | }; 238 | 239 | 240 | /*** Start the render loop. **/ 241 | Gl.render(~window, ~displayFunc=render, ()); 242 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /package-lock.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "@bsansouci/reasongl", 3 | "version": "1.0.1", 4 | "lockfileVersion": 1, 5 | "requires": true, 6 | "dependencies": { 7 | "@bsansouci/tgls": { 8 | "version": "0.8.4", 9 | "resolved": "https://registry.npmjs.org/@bsansouci/tgls/-/tgls-0.8.4.tgz", 10 | "integrity": "sha512-BELFkZS1H8z8z1kTYiVJJc5WXY1KsY8oqfQZ2auwzonTLqIDq9cHIGx0IK5obxseCuiJdpxTx4lhlX3ju2IG+g==" 11 | }, 12 | "@bsansouci/tsdl": { 13 | "version": "0.9.1", 14 | "resolved": "https://registry.npmjs.org/@bsansouci/tsdl/-/tsdl-0.9.1.tgz", 15 | "integrity": "sha512-AAIdaYdJuTTO6IZ+YZJJJ8elspUcf2QJsBZ3KNwFDk9e7/HpPTyFtsOVHBPdu0mn+luI0OigUPwopI97esmL0g==", 16 | "requires": { 17 | "sdl2": "github:bsansouci/SDL-mirror#fast" 18 | } 19 | }, 20 | "bsb-native": { 21 | "version": "4.0.6", 22 | "resolved": "https://registry.npmjs.org/bsb-native/-/bsb-native-4.0.6.tgz", 23 | "integrity": "sha512-T1MkndnmA4StiKK2UvEftrqANN+h9StlLghBbwmKa833d97D86np+2wmIOw5Rqy6rNW3D076A2G51mooWTUwfQ==", 24 | "dev": true, 25 | "requires": { 26 | "yauzl": "^2.9.1" 27 | } 28 | }, 29 | "buffer-crc32": { 30 | "version": "0.2.13", 31 | "resolved": "https://registry.npmjs.org/buffer-crc32/-/buffer-crc32-0.2.13.tgz", 32 | "integrity": "sha1-DTM+PwDqxQqhRUq9MO+MKl2ackI=" 33 | }, 34 | "fd-slicer": { 35 | "version": "1.1.0", 36 | "resolved": "https://registry.npmjs.org/fd-slicer/-/fd-slicer-1.1.0.tgz", 37 | "integrity": "sha1-JcfInLH5B3+IkbvmHY85Dq4lbx4=", 38 | "requires": { 39 | "pend": "~1.2.0" 40 | } 41 | }, 42 | "gl-matrix": { 43 | "version": "2.6.1", 44 | "resolved": "https://registry.npmjs.org/gl-matrix/-/gl-matrix-2.6.1.tgz", 45 | "integrity": "sha512-fK37p7vkpw5H4WSypfa6TUV8nlB8+Fd1pZj15sMtvRPnfzArvTI4U4E25x2Hmp+UxZX11ve0aGaHarRieP+gSw==" 46 | }, 47 | "pend": { 48 | "version": "1.2.0", 49 | "resolved": "https://registry.npmjs.org/pend/-/pend-1.2.0.tgz", 50 | "integrity": "sha1-elfrVQpng/kRUzH89GY9XI4AelA=" 51 | }, 52 | "sdl2": { 53 | "version": "github:bsansouci/SDL-mirror#db0756eec3c5979b8291d739ebac9e8747ccbac2", 54 | "from": "github:bsansouci/SDL-mirror#fast", 55 | "requires": { 56 | "yauzl": "^2.9.1" 57 | } 58 | }, 59 | "yauzl": { 60 | "version": "2.9.2", 61 | "resolved": "https://registry.npmjs.org/yauzl/-/yauzl-2.9.2.tgz", 62 | "integrity": "sha1-T7G8euH8L1cDe1SvasyP4QMcW3c=", 63 | "requires": { 64 | "buffer-crc32": "~0.2.3", 65 | "fd-slicer": "~1.1.0" 66 | } 67 | } 68 | } 69 | } 70 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "@bsansouci/reasongl", 3 | "version": "1.0.1", 4 | "description": "Reason bindings to GL", 5 | "dependencies": { 6 | "@bsansouci/tgls": "^1.0.0", 7 | "@bsansouci/tsdl": "^1.0.0", 8 | "gl-matrix": "*", 9 | "unix": "bsansouci/otherlibs", 10 | "bigarray": "bsansouci/otherlibs" 11 | }, 12 | "repository": { 13 | "type": "git", 14 | "url": "git+https://github.com/bsansouci/reasongl-native.git" 15 | }, 16 | "author": "bsansouci & schmavery", 17 | "devDependencies": { 18 | "bsb-native": "4.0.6" 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /require_polyfill.js: -------------------------------------------------------------------------------- 1 | function normalizeArray(parts, allowAboveRoot) { 2 | // if the path tries to go above the root, `up` ends up > 0 3 | var up = 0; 4 | for (var i = parts.length - 1; i >= 0; i--) { 5 | var last = parts[i]; 6 | if (last === '.') { 7 | parts.splice(i, 1); 8 | } else if (last === '..') { 9 | parts.splice(i, 1); 10 | up++; 11 | } else if (up) { 12 | parts.splice(i, 1); 13 | up--; 14 | } 15 | } 16 | 17 | // if the path is allowed to go above the root, restore leading ..s 18 | if (allowAboveRoot) { 19 | for (; up--; up) { 20 | parts.unshift('..'); 21 | } 22 | } 23 | 24 | return parts; 25 | }; 26 | 27 | function pathNormalize(path) { 28 | var isAbsolute = path.charAt(0) === '/'; 29 | var trailingSlash = path.substr(-1) === '/'; 30 | 31 | // Normalize the path 32 | path = normalizeArray(path.split('/').filter(function(p) { 33 | return !!p; 34 | }), !isAbsolute).join('/'); 35 | 36 | if (!path && !isAbsolute) { 37 | path = '.'; 38 | } 39 | if (path && trailingSlash) { 40 | path += '/'; 41 | } 42 | 43 | return (isAbsolute ? '/' : '') + path; 44 | }; 45 | 46 | var globalEval = eval; 47 | var currentScript = document.currentScript; 48 | var projectRoot = currentScript.dataset['project-root'] || currentScript.dataset['projectRoot']; 49 | if (projectRoot == null) { 50 | throw new Error('The attribute `data-project-root` isn\'t found in the script tag. You need to provide the root (in which node_modules reside).') 51 | } 52 | var nodeModulesDir = projectRoot + '/node_modules/'; 53 | 54 | var modulesCache = {}; 55 | var packageJsonMainCache = {}; 56 | 57 | var ensureEndsWithJs = function(path) { 58 | if (path.endsWith('.js')) { 59 | return path; 60 | } else { 61 | return path + '.js'; 62 | } 63 | }; 64 | function loadScript(scriptPath) { 65 | var request = new XMLHttpRequest(); 66 | 67 | request.open("GET", scriptPath, false); // sync 68 | request.send(); 69 | var dirSeparatorIndex = scriptPath.lastIndexOf('/'); 70 | var dir = dirSeparatorIndex === -1 ? '.' : scriptPath.slice(0, dirSeparatorIndex); 71 | 72 | var moduleText = ` 73 | (function(module, exports, modulesCache, packageJsonMainCache, nodeModulesDir) { 74 | function require(path) { 75 | var __dirname = "${dir}/"; 76 | var resolvedPath; 77 | if (path.startsWith('.')) { 78 | // require('./foo/bar') 79 | resolvedPath = ensureEndsWithJs(__dirname + path); 80 | } else if (path.indexOf('/') === -1) { 81 | // require('react') 82 | var packageJson = pathNormalize(nodeModulesDir + path + '/package.json'); 83 | if (packageJsonMainCache[packageJson] == null) { 84 | var jsonRequest = new XMLHttpRequest(); 85 | jsonRequest.open("GET", packageJson, false); 86 | jsonRequest.send(); 87 | var main; 88 | if (jsonRequest.responseText != null) { 89 | main = JSON.parse(jsonRequest.responseText).main; 90 | }; 91 | if (main == null) { 92 | main = 'index.js'; 93 | } else if (!main.endsWith('.js')) { 94 | main = main + '.js'; 95 | } 96 | packageJsonMainCache[packageJson] = nodeModulesDir + path + '/' + main; 97 | } 98 | resolvedPath = packageJsonMainCache[packageJson]; 99 | } else { 100 | // require('react/bar') 101 | resolvedPath = ensureEndsWithJs(nodeModulesDir + path); 102 | }; 103 | resolvedPath = pathNormalize(resolvedPath); 104 | if (modulesCache[resolvedPath] != null) { 105 | return modulesCache[resolvedPath]; 106 | }; 107 | var result = loadScript(resolvedPath); 108 | modulesCache[resolvedPath] = result; 109 | return result; 110 | }; 111 | var process = {env: {}, argv: []}; 112 | var global = {}; 113 | 114 | 115 | // -------Begin Require Polyfilled Module Loaded From Disk------------------------------ 116 | // file: ${scriptPath} 117 | // root: ${projectRoot} 118 | // ---------------------------------------------------------------------- 119 | ${request.responseText} 120 | // -------End Polyfill Loaded From Disk------------------------------ 121 | // file: ${scriptPath} 122 | // root: ${projectRoot} 123 | // ---------------------------------------------------------------------- 124 | return module.exports})\n//@ sourceURL=${scriptPath}`; 125 | var module = {exports: {}}; 126 | return globalEval(moduleText)(module, module.exports, modulesCache, packageJsonMainCache, nodeModulesDir); 127 | }; 128 | 129 | loadScript(currentScript.dataset.main) 130 | -------------------------------------------------------------------------------- /src/RGLConstants.re: -------------------------------------------------------------------------------- 1 | let triangles = 4; 2 | 3 | let triangle_strip = 5; 4 | 5 | let texture0 = 33984; 6 | 7 | let texture1 = 33985; 8 | 9 | let texture2 = 33986; 10 | 11 | let texture_2d = 3553; 12 | 13 | let blend = 3042; 14 | 15 | let texture_wrap_s = 10242; 16 | 17 | let texture_wrap_t = 10243; 18 | 19 | let clamp_to_edge = 33071; 20 | 21 | let src_alpha = 770; 22 | 23 | let one_minus_src_alpha = 771; 24 | 25 | let dst_alpha = 772; 26 | 27 | let depth_test = 2929; 28 | 29 | let cull_face = 2884; 30 | 31 | let rgb = 6407; 32 | 33 | let rgba = 6408; 34 | 35 | let triangle_fan = 6; 36 | 37 | let array_buffer = 34962; 38 | 39 | let element_array_buffer = 34963; 40 | 41 | let array_buffer_binding = 34964; 42 | 43 | let element_array_buffer_binding = 34965; 44 | 45 | let stream_draw = 35040; 46 | 47 | let static_draw = 35044; 48 | 49 | let dynamic_draw = 35048; 50 | 51 | let buffer_size = 34660; 52 | 53 | let buffer_usage = 34661; 54 | 55 | let float_ = 5126; 56 | 57 | let unsigned_int = 5125; 58 | 59 | let current_vertex_attrib = 34342; 60 | 61 | let fragment_shader = 35632; 62 | 63 | let vertex_shader = 35633; 64 | 65 | let max_vertex_attribs = 34921; 66 | 67 | let max_vertex_uniform_vectors = 36347; 68 | 69 | let max_varying_vectors = 36348; 70 | 71 | let max_combined_texture_image_units = 35661; 72 | 73 | let max_vertex_texture_image_units = 35660; 74 | 75 | let max_texture_image_units = 34930; 76 | 77 | let max_fragment_uniform_vectors = 36349; 78 | 79 | let shader_type = 35663; 80 | 81 | let delete_status = 35712; 82 | 83 | let link_status = 35714; 84 | 85 | let validate_status = 35715; 86 | 87 | let attached_shaders = 35717; 88 | 89 | let active_uniforms = 35718; 90 | 91 | let active_attributes = 35721; 92 | 93 | let shading_language_version = 35724; 94 | 95 | let current_program = 35725; 96 | 97 | let compile_status = 35713; 98 | 99 | let vendor = 7936; 100 | 101 | let renderer = 7937; 102 | 103 | let version = 7938; 104 | 105 | let float_vec2 = 35664; 106 | 107 | let float_vec3 = 35665; 108 | 109 | let float_vec4 = 35666; 110 | 111 | let int_vec2 = 35667; 112 | 113 | let int_vec3 = 35668; 114 | 115 | let int_vec4 = 35669; 116 | 117 | let bool_ = 35670; 118 | 119 | let bool_vec2 = 35671; 120 | 121 | let bool_vec3 = 35672; 122 | 123 | let bool_vec4 = 35673; 124 | 125 | let float_mat2 = 35674; 126 | 127 | let float_mat3 = 35675; 128 | 129 | let float_mat4 = 35676; 130 | 131 | let sampler_2d = 35678; 132 | 133 | let sampler_cube = 35680; 134 | 135 | let unpack_flip_y_webgl = 37440; 136 | 137 | let unpack_premultiply_alpha_webgl = 37441; 138 | 139 | let context_lost_webgl = 37442; 140 | 141 | let unpack_colorspace_conversion_webgl = 37443; 142 | 143 | let browser_default_webgl = 37444; 144 | 145 | let vertex_attrib_array_enabled = 34338; 146 | 147 | let vertex_attrib_array_size = 34339; 148 | 149 | let vertex_attrib_array_stride = 34340; 150 | 151 | let vertex_attrib_array_type = 34341; 152 | 153 | let vertex_attrib_array_normalized = 34922; 154 | 155 | let vertex_attrib_array_pointer = 34373; 156 | 157 | let vertex_attrib_array_buffer_binding = 34975; 158 | 159 | let depth_buffer_bit = 256; 160 | 161 | let stencil_buffer_bit = 1024; 162 | 163 | let color_buffer_bit = 16384; 164 | 165 | let unsigned_short = 5123; 166 | 167 | let unsigned_byte = 5121; 168 | 169 | let texture_mag_filter = 10240; 170 | 171 | let texture_min_filter = 10241; 172 | 173 | let nearest = 9728; 174 | 175 | let linear = 9729; 176 | 177 | let nearest_mipmap_nearest = 9984; 178 | 179 | let linear_mipmap_nearest = 9985; 180 | 181 | let nearest_mipmap_linear = 9986; 182 | 183 | let linear_mipmap_linear = 9987; 184 | 185 | let framebuffer = 36160; 186 | 187 | let color_attachment0 = 36064; 188 | -------------------------------------------------------------------------------- /src/RGLEvents.re: -------------------------------------------------------------------------------- 1 | module type t = { 2 | type buttonStateT = 3 | | LeftButton 4 | | MiddleButton 5 | | RightButton; 6 | type stateT = 7 | | MouseDown 8 | | MouseUp; 9 | type keycodeT = 10 | | Backspace 11 | | Delete 12 | | Tab 13 | | Enter 14 | | Escape 15 | | Space 16 | | Quote 17 | | Comma 18 | | Minus 19 | | Period 20 | | Slash 21 | | Num_0 22 | | Num_1 23 | | Num_2 24 | | Num_3 25 | | Num_4 26 | | Num_5 27 | | Num_6 28 | | Num_7 29 | | Num_8 30 | | Num_9 31 | | Semicolon 32 | | Equals 33 | | OpenBracket 34 | | Backslash 35 | | CloseBracket 36 | | A 37 | | B 38 | | C 39 | | D 40 | | E 41 | | F 42 | | G 43 | | H 44 | | I 45 | | J 46 | | K 47 | | L 48 | | M 49 | | N 50 | | O 51 | | P 52 | | Q 53 | | R 54 | | S 55 | | T 56 | | U 57 | | V 58 | | W 59 | | X 60 | | Y 61 | | Z 62 | | Right 63 | | Left 64 | | Down 65 | | Up 66 | | LeftCtrl 67 | | LeftShift 68 | | LeftAlt 69 | | LeftOsKey 70 | | RightCtrl 71 | | RightShift 72 | | RightAlt 73 | | RightOsKey 74 | | CapsLock 75 | | Backtick 76 | | Nothing; 77 | let keycodeMap: Int32.t => keycodeT; 78 | }; 79 | -------------------------------------------------------------------------------- /src/RGLInterface.re: -------------------------------------------------------------------------------- 1 | module type t = { 2 | let target: string; 3 | type contextT; 4 | module type FileT = {type t; let readFile: (~filename: string, ~cb: string => unit) => unit;}; 5 | module File: FileT; 6 | module type WindowT = { 7 | type t; 8 | let getWidth: t => int; 9 | let getHeight: t => int; 10 | let getPixelWidth: t => int; 11 | let getPixelHeight: t => int; 12 | let getPixelScale: t => float; 13 | let init: (~screen: string=?, ~argv: array(string)) => t; 14 | let setWindowSize: (~window: t, ~width: int, ~height: int) => unit; 15 | let setWindowTitle: (~window: t, ~title: string) => unit; 16 | let getContext: t => contextT; 17 | }; 18 | module Window: WindowT; 19 | module type AudioT = { 20 | type t; 21 | let loadSound: (Window.t, string, t => unit) => unit; 22 | let playSound: (Window.t, t, ~volume: float, ~loop: bool) => unit; 23 | }; 24 | module Audio: AudioT; 25 | module Events: RGLEvents.t; 26 | 27 | /*** We're currently mimicking the JS asynchronous event handling allowing the user to register callbacks. 28 | * Instead of mutating global state in the Events module, we simply force the user to register all events 29 | * handlers at once, allowing us to use the closure to keep track of the data for us. 30 | * For native, the easiest way to handle events is in the render loop, so we force the user to also 31 | * register the draw call `displayFunc` which will effectively do all of the rendering. 32 | */ 33 | let render: 34 | ( 35 | ~window: Window.t, 36 | ~mouseDown: (~button: Events.buttonStateT, ~state: Events.stateT, ~x: int, ~y: int) => unit=?, 37 | ~mouseUp: (~button: Events.buttonStateT, ~state: Events.stateT, ~x: int, ~y: int) => unit=?, 38 | ~mouseMove: (~x: int, ~y: int) => unit=?, 39 | ~keyDown: (~keycode: Events.keycodeT, ~repeat: bool) => unit=?, 40 | ~keyUp: (~keycode: Events.keycodeT) => unit=?, 41 | ~windowResize: unit => unit=?, 42 | ~displayFunc: float => unit, 43 | unit 44 | ) => 45 | bool => bool; 46 | type programT; 47 | type shaderT; 48 | let clearColor: (~context: contextT, ~r: float, ~g: float, ~b: float, ~a: float) => unit; 49 | let createProgram: (~context: contextT) => programT; 50 | let createShader: (~context: contextT, int) => shaderT; 51 | let attachShader: (~context: contextT, ~program: programT, ~shader: shaderT) => unit; 52 | let deleteShader: (~context: contextT, shaderT) => unit; 53 | let shaderSource: (~context: contextT, ~shader: shaderT, ~source: string) => unit; 54 | let compileShader: (~context: contextT, shaderT) => unit; 55 | let linkProgram: (~context: contextT, programT) => unit; 56 | let useProgram: (~context: contextT, programT) => unit; 57 | type bufferT; 58 | type attributeT; 59 | type uniformT; 60 | let createBuffer: (~context: contextT) => bufferT; 61 | let bindBuffer: (~context: contextT, ~target: int, ~buffer: bufferT) => unit; 62 | type textureT; 63 | let createTexture: (~context: contextT) => textureT; 64 | let activeTexture: (~context: contextT, int) => unit; 65 | let bindTexture: (~context: contextT, ~target: int, ~texture: textureT) => unit; 66 | let texParameteri: (~context: contextT, ~target: int, ~pname: int, ~param: int) => unit; 67 | type framebufferT; 68 | let createFramebuffer : (~context: contextT) => framebufferT; 69 | let bindFramebuffer: (~context: contextT, ~target: int, ~framebuffer: framebufferT) => unit; 70 | let bindDefaultFramebuffer: (~context: contextT, ~target: int) => unit; 71 | let framebufferTexture2D : (~context: contextT, ~target:int, ~attachment:int, ~texTarget:int, ~texture:textureT) => unit; 72 | /*let drawBuffers : (~context : contextT, ~target: int) => unit;*/ 73 | /*type rawTextureDataT; 74 | let toTextureData: array int => rawTextureDataT;*/ 75 | let enable: (~context: contextT, int) => unit; 76 | let disable: (~context: contextT, int) => unit; 77 | let blendFunc: (~context: contextT, int, int) => unit; 78 | module type Bigarray = { 79 | type t('a, 'b); 80 | type float64_elt; 81 | type float32_elt; 82 | type int16_unsigned_elt; 83 | type int16_signed_elt; 84 | type int8_unsigned_elt; 85 | type int8_signed_elt; 86 | type int_elt; 87 | type int32_elt; 88 | type int64_elt; 89 | type kind('a, 'b) = 90 | | Float64: kind(float, float64_elt) 91 | | Float32: kind(float, float32_elt) 92 | | Int16: kind(int, int16_signed_elt) 93 | | Uint16: kind(int, int16_unsigned_elt) 94 | | Int8: kind(int, int8_signed_elt) 95 | | Uint8: kind(int, int8_unsigned_elt) 96 | | Char: kind(char, int8_unsigned_elt) 97 | | Int: kind(int, int_elt) 98 | | Int64: kind(int64, int64_elt) 99 | | Int32: kind(int32, int32_elt); 100 | let create: (kind('a, 'b), int) => t('a, 'b); 101 | let of_array: (kind('a, 'b), array('a)) => t('a, 'b); 102 | let dim: t('a, 'b) => int; 103 | let blit: (t('a, 'b), t('a, 'b)) => unit; 104 | let unsafe_blit: (t('a, 'b), t('a, 'b), ~offset: int, ~numOfBytes: int) => unit; 105 | let get: (t('a, 'b), int) => 'a; 106 | let unsafe_get: (t('a, 'b), int) => 'a; 107 | let set: (t('a, 'b), int, 'a) => unit; 108 | let unsafe_set: (t('a, 'b), int, 'a) => unit; 109 | let sub: (t('a, 'b), ~offset: int, ~len: int) => t('a, 'b); 110 | }; 111 | module Bigarray: Bigarray; 112 | let texSubImage2D: 113 | ( 114 | ~context: contextT, 115 | ~target: int, 116 | ~level: int, 117 | ~xoffset: int, 118 | ~yoffset: int, 119 | ~width: int, 120 | ~height: int, 121 | ~format: int, 122 | ~type_: int, 123 | ~pixels: Bigarray.t('a, 'b) 124 | ) => 125 | unit; 126 | let readPixels_RGBA: 127 | (~context: contextT, ~x: int, ~y: int, ~width: int, ~height: int) => 128 | Bigarray.t(int, Bigarray.int8_unsigned_elt); 129 | type imageT; 130 | let getImageWidth: imageT => int; 131 | let getImageHeight: imageT => int; 132 | type loadOptionT = 133 | | LoadAuto 134 | | LoadL 135 | | LoadLA 136 | | LoadRGB 137 | | LoadRGBA; 138 | let loadImage: 139 | (~filename: string, ~loadOption: loadOptionT=?, ~callback: option(imageT) => unit, unit) => 140 | unit; 141 | let loadImageFromMemory: 142 | (~data: string, ~loadOption: loadOptionT=?, ~callback: option(imageT) => unit, unit) => 143 | unit; 144 | let texImage2DWithImage: (~context: contextT, ~target: int, ~level: int, ~image: imageT) => unit; 145 | let uniform1i: (~context: contextT, ~location: uniformT, ~value: int) => unit; 146 | let uniform1f: (~context: contextT, ~location: uniformT, ~value: float) => unit; 147 | let uniform2f: (~context: contextT, ~location: uniformT, ~v1: float, ~v2: float) => unit; 148 | let uniform3f: 149 | (~context: contextT, ~location: uniformT, ~v1: float, ~v2: float, ~v3: float) => unit; 150 | let uniform4f: 151 | (~context: contextT, ~location: uniformT, ~v1: float, ~v2: float, ~v3: float, ~v4: float) => 152 | unit; 153 | let texImage2D_RGBA: 154 | ( 155 | ~context: contextT, 156 | ~target: int, 157 | ~level: int, 158 | ~width: int, 159 | ~height: int, 160 | ~border: int, 161 | ~data: Bigarray.t('a, 'b) 162 | ) => 163 | unit; 164 | let texImage2D_null: ( 165 | ~context: contextT, 166 | ~target: int, 167 | ~level: int, 168 | ~width: int, 169 | ~height: int 170 | ) => 171 | unit; 172 | let bufferData: 173 | (~context: contextT, ~target: int, ~data: Bigarray.t('a, 'b), ~usage: int) => unit; 174 | let viewport: (~context: contextT, ~x: int, ~y: int, ~width: int, ~height: int) => unit; 175 | let clear: (~context: contextT, ~mask: int) => unit; 176 | let getUniformLocation: (~context: contextT, ~program: programT, ~name: string) => uniformT; 177 | let getAttribLocation: (~context: contextT, ~program: programT, ~name: string) => attributeT; 178 | let enableVertexAttribArray: (~context: contextT, ~attribute: attributeT) => unit; 179 | let vertexAttribPointer: 180 | ( 181 | ~context: contextT, 182 | ~attribute: attributeT, 183 | ~size: int, 184 | ~type_: int, 185 | ~normalize: bool, 186 | ~stride: int, 187 | ~offset: int 188 | ) => 189 | unit; 190 | let vertexAttribDivisor: (~context: contextT, ~attribute: attributeT, ~divisor: int) => unit; 191 | module type Mat4T = { 192 | type t; 193 | let to_array: t => array(float); 194 | let create: unit => t; 195 | let identity: (~out: t) => unit; 196 | let translate: (~out: t, ~matrix: t, ~vec: array(float)) => unit; 197 | let scale: (~out: t, ~matrix: t, ~vec: array(float)) => unit; 198 | let rotate: (~out: t, ~matrix: t, ~rad: float, ~vec: array(float)) => unit; 199 | let ortho: 200 | ( 201 | ~out: t, 202 | ~left: float, 203 | ~right: float, 204 | ~bottom: float, 205 | ~top: float, 206 | ~near: float, 207 | ~far: float 208 | ) => 209 | unit; 210 | let perspective: 211 | ( 212 | ~out: t, 213 | ~fovy: float, 214 | ~aspect: float, 215 | ~near: float, 216 | ~far: float, 217 | ) => 218 | unit; 219 | let lookAt: 220 | ( 221 | ~out: t, 222 | ~eye: array(float), 223 | ~center: array(float), 224 | ~up: array(float), 225 | ) => 226 | unit; 227 | }; 228 | module Mat4: Mat4T; 229 | let uniformMatrix4fv: (~context: contextT, ~location: uniformT, ~value: Mat4.t) => unit; 230 | type shaderParamsT = 231 | | Shader_delete_status 232 | | Compile_status 233 | | Shader_type; 234 | type programParamsT = 235 | | Program_delete_status 236 | | Link_status 237 | | Validate_status; 238 | let getProgramParameter: 239 | (~context: contextT, ~program: programT, ~paramName: programParamsT) => int; 240 | let getShaderParameter: (~context: contextT, ~shader: shaderT, ~paramName: shaderParamsT) => int; 241 | let getShaderInfoLog: (~context: contextT, shaderT) => string; 242 | let getProgramInfoLog: (~context: contextT, programT) => string; 243 | let getShaderSource: (~context: contextT, shaderT) => string; 244 | let drawArrays: (~context: contextT, ~mode: int, ~first: int, ~count: int) => unit; 245 | let drawElements: 246 | (~context: contextT, ~mode: int, ~count: int, ~type_: int, ~offset: int) => unit; 247 | let drawElementsInstanced: 248 | (~context: contextT, ~mode: int, ~count: int, ~type_: int, ~indices: int, ~primcount: int) => 249 | unit; 250 | }; 251 | -------------------------------------------------------------------------------- /src/ReasonglInterface.re: -------------------------------------------------------------------------------- 1 | module Gl = RGLInterface; 2 | 3 | module Constants = RGLConstants; 4 | -------------------------------------------------------------------------------- /src/events.ml: -------------------------------------------------------------------------------- 1 | (* Include both because only one will have anything in it, the other will be compiled out. *) 2 | include Events_web 3 | include Events_native 4 | -------------------------------------------------------------------------------- /src/native/events_native.ml: -------------------------------------------------------------------------------- 1 | #if NATIVE || BYTECODE then 2 | type buttonStateT = 3 | | LeftButton 4 | | MiddleButton 5 | | RightButton 6 | type stateT = 7 | | MouseDown 8 | | MouseUp 9 | type keycodeT = 10 | | Backspace 11 | | Delete 12 | | Tab 13 | | Enter 14 | | Escape 15 | | Space 16 | | Quote 17 | | Comma 18 | | Minus 19 | | Period 20 | | Slash 21 | | Num_0 22 | | Num_1 23 | | Num_2 24 | | Num_3 25 | | Num_4 26 | | Num_5 27 | | Num_6 28 | | Num_7 29 | | Num_8 30 | | Num_9 31 | | Semicolon 32 | | Equals 33 | | OpenBracket 34 | | Backslash 35 | | CloseBracket 36 | | A 37 | | B 38 | | C 39 | | D 40 | | E 41 | | F 42 | | G 43 | | H 44 | | I 45 | | J 46 | | K 47 | | L 48 | | M 49 | | N 50 | | O 51 | | P 52 | | Q 53 | | R 54 | | S 55 | | T 56 | | U 57 | | V 58 | | W 59 | | X 60 | | Y 61 | | Z 62 | | Right 63 | | Left 64 | | Down 65 | | Up 66 | | LeftCtrl 67 | | LeftShift 68 | | LeftAlt 69 | | LeftOsKey 70 | | RightCtrl 71 | | RightShift 72 | | RightAlt 73 | | RightOsKey 74 | | CapsLock 75 | | Backtick 76 | | Nothing 77 | let max_31_bit_int = Int32.of_int 1073741823 78 | let keycodeMap = 79 | (fun i32 -> 80 | if i32 < max_31_bit_int 81 | then 82 | match Int32.to_int i32 with 83 | | 8 -> Backspace 84 | | 9 -> Tab 85 | | 13 -> Enter 86 | | 27 -> Escape 87 | | 32 -> Space 88 | | 39 -> Quote 89 | | 44 -> Comma 90 | | 45 -> Minus 91 | | 46 -> Period 92 | | 47 -> Slash 93 | | 48 -> Num_0 94 | | 49 -> Num_1 95 | | 50 -> Num_2 96 | | 51 -> Num_3 97 | | 52 -> Num_4 98 | | 53 -> Num_5 99 | | 54 -> Num_6 100 | | 55 -> Num_7 101 | | 56 -> Num_8 102 | | 57 -> Num_9 103 | | 59 -> Semicolon 104 | | 61 -> Equals 105 | | 91 -> OpenBracket 106 | | 92 -> Backslash 107 | | 93 -> CloseBracket 108 | | 96 -> Backtick 109 | | 97 -> A 110 | | 98 -> B 111 | | 99 -> C 112 | | 100 -> D 113 | | 101 -> E 114 | | 102 -> F 115 | | 103 -> G 116 | | 104 -> H 117 | | 105 -> I 118 | | 106 -> J 119 | | 107 -> K 120 | | 108 -> L 121 | | 109 -> M 122 | | 110 -> N 123 | | 111 -> O 124 | | 112 -> P 125 | | 113 -> Q 126 | | 114 -> R 127 | | 115 -> S 128 | | 116 -> T 129 | | 117 -> U 130 | | 118 -> V 131 | | 119 -> W 132 | | 120 -> X 133 | | 121 -> Y 134 | | 122 -> Z 135 | | 127 -> Delete 136 | | _ -> Nothing 137 | else 138 | (match Int32.to_int (Int32.sub i32 max_31_bit_int) with 139 | | 58 -> CapsLock 140 | | 80 -> Right 141 | | 81 -> Left 142 | | 82 -> Down 143 | | 83 -> Up 144 | | 225 -> LeftCtrl 145 | | 226 -> LeftShift 146 | | 227 -> LeftAlt 147 | | 228 -> LeftOsKey 148 | | 229 -> RightCtrl 149 | | 230 -> RightShift 150 | | 231 -> RightAlt 151 | | 232 -> RightOsKey 152 | | _ -> Nothing) : Int32.t -> keycodeT) 153 | #end 154 | -------------------------------------------------------------------------------- /src/native/reasongl.c: -------------------------------------------------------------------------------- 1 | #include // for memcpy 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | void bigarray_unsafe_blit(value arr1, value arr2, value offset, value numOfBytes) { 8 | char *arr1Data = Caml_ba_data_val(arr1); 9 | char *arr2Data = Caml_ba_data_val(arr2); 10 | memcpy(arr2Data + Int_val(offset) * Int_val(numOfBytes), arr1Data, caml_ba_byte_size(Caml_ba_array_val(arr1))); 11 | } 12 | -------------------------------------------------------------------------------- /src/native/reasongl_native.ml: -------------------------------------------------------------------------------- 1 | #if NATIVE || BYTECODE then 2 | ;;try 3 | if Sys.unix && ((Sys.getenv "WAYLAND_DISPLAY") <> "") 4 | then Unix.putenv "SDL_VIDEODRIVER" "wayland" 5 | with | Not_found -> () 6 | module Str = Str 7 | module Bigarray = Bigarray 8 | module Unix = Unix 9 | module Sdl = Tsdl_new 10 | let (>>=) t f = match t with | 0 -> f () | _ -> failwith @@ (Sdl.error ()) 11 | let create_window ~gl:(maj, min) = 12 | let w_atts = let open Sdl.Window in (opengl + resizable) + allow_highdpi in 13 | let w_title = Printf.sprintf "OpenGL %d.%d (core profile)" maj min in 14 | let set a v = Sdl.Gl.gl_set_attribute ~attr:a ~value:v in 15 | (set Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_compatibility) >>= 16 | (fun () -> 17 | (set Sdl.Gl.context_major_version maj) >>= 18 | (fun () -> 19 | (set Sdl.Gl.context_minor_version min) >>= 20 | (fun () -> 21 | (set Sdl.Gl.doublebuffer 1) >>= 22 | (fun () -> 23 | (set Sdl.Gl.multisamplebuffers 1) >>= 24 | (fun () -> 25 | (set Sdl.Gl.multisamplesamples 8) >>= 26 | (fun () -> 27 | Sdl.create_window ~title:w_title 28 | ~x:Sdl.Window.pos_centered 29 | ~y:Sdl.Window.pos_centered ~w:640 ~h:480 30 | ~flags:w_atts)))))) 31 | module Gl : ReasonglInterface.Gl.t = 32 | struct 33 | module Gl = Tgls_new 34 | let target = "native" 35 | type contextT = Sdl.glContextT 36 | module type FileT = 37 | sig 38 | type t 39 | val readFile : filename:string -> cb:(string -> unit) -> unit 40 | end 41 | module File = 42 | struct 43 | type t 44 | let readFile ~filename ~cb = 45 | let ic = open_in filename in 46 | let try_read () = 47 | match input_line ic with 48 | | exception End_of_file -> None 49 | | x -> ((Some (x))[@explicit_arity ]) in 50 | let rec loop acc = 51 | match try_read () with 52 | | ((Some (s))[@explicit_arity ]) -> loop (s :: acc) 53 | | None -> (close_in ic; List.rev acc) in 54 | let text = (loop []) |> (String.concat (String.make 1 '\n')) in 55 | cb text 56 | end 57 | module type WindowT = 58 | sig 59 | type t 60 | val getWidth : t -> int 61 | val getHeight : t -> int 62 | val getPixelWidth : t -> int 63 | val getPixelHeight : t -> int 64 | val getPixelScale : t -> float 65 | val init : ?screen:string -> argv:string array -> t 66 | val setWindowSize : window:t -> width:int -> height:int -> unit 67 | val setWindowTitle : window:t -> title:string -> unit 68 | val getContext : t -> contextT 69 | end 70 | module Window = 71 | struct 72 | type t = Sdl.windowT 73 | let getWidth (window : t) = 74 | let (width, _) = Sdl.get_window_size window in width 75 | let getHeight (window : t) = 76 | let (_, height) = Sdl.get_window_size window in height 77 | let getPixelWidth (window : t) = 78 | let (width, _) = Sdl.get_drawable_size window in width 79 | let getPixelHeight (window : t) = 80 | let (_, height) = Sdl.get_drawable_size window in height 81 | let getPixelScale (window : t) = 82 | let { Sdl.hdpi = hdpi } = Sdl.get_window_dpi window in hdpi /. 72. 83 | let init ?screen ~argv:_ = 84 | if (Sdl.Init.init (Sdl.Init.video lor Sdl.Init.audio)) <> 0 85 | then failwith @@ (Sdl.error ()); 86 | create_window ~gl:(2, 1) 87 | let setWindowSize ~window:(window : t) ~width ~height = 88 | Sdl.set_window_size window ~width ~height 89 | let getContext (window : t) = 90 | (let ctx = Sdl.gl_create_context window in 91 | Gl.gladLoadGL (); 92 | (let e = Sdl.gl_make_current window ctx in 93 | if e <> 0 then failwith @@ (Sdl.error ()); ctx) : contextT) 94 | let setWindowTitle ~window:(window : t) ~title = 95 | Sdl.set_window_title window title 96 | end 97 | module type AudioT = 98 | sig 99 | type t 100 | val loadSound : Sdl.windowT -> string -> (t -> unit) -> unit 101 | val playSound : Sdl.windowT -> t -> volume:float -> loop:bool -> unit 102 | end 103 | module Audio = 104 | struct 105 | type t = Sdl.soundT 106 | let loadSound w s cb = cb (Sdl.load_audio w s) 107 | let playSound = Sdl.play_audio 108 | end 109 | module Events = Events 110 | type mouseButtonEventT = 111 | button:Events.buttonStateT -> 112 | state:Events.stateT -> x:int -> y:int -> unit 113 | external usleep : int -> unit = "reasongl_usleep"[@@noalloc ] 114 | let render ~window:(window : Window.t) 115 | ?mouseDown:(mouseDown : mouseButtonEventT option) 116 | ?mouseUp:(mouseUp : mouseButtonEventT option) 117 | ?mouseMove:(mouseMove : (x:int -> y:int -> unit) option) 118 | ?keyDown:(keyDown : 119 | (keycode:Events.keycodeT -> repeat:bool -> unit) option) 120 | ?keyUp:(keyUp : (keycode:Events.keycodeT -> unit) option) 121 | ?windowResize:(windowResize : (unit -> unit) option) 122 | ~displayFunc:(displayFunc : float -> unit) () = 123 | let checkEvents () = 124 | (let open Sdl.Event in 125 | let shouldQuit = ref false in 126 | let shouldPoll = ref true in 127 | while !shouldPoll do 128 | (match Sdl.Event.poll_event () with 129 | | None -> shouldPoll := false 130 | | ((Some (e))[@explicit_arity ]) -> 131 | let eventType = e.typ in 132 | if eventType = Sdl.Event.quit 133 | then shouldQuit := true 134 | else 135 | if eventType = Sdl.Event.mousebuttondown 136 | then 137 | (match mouseDown with 138 | | None -> () 139 | | ((Some (cb))[@explicit_arity ]) -> 140 | let x = e.mouse_button_x in 141 | let y = e.mouse_button_y in 142 | let button = 143 | match e.mouse_button_button with 144 | | 1 -> Events.LeftButton 145 | | 2 -> Events.MiddleButton 146 | | 3 -> Events.RightButton 147 | | _ -> failwith "Button not supported" in 148 | (cb ~button ~state:Events.MouseDown ~x ~y; ())) 149 | else 150 | if eventType = Sdl.Event.mousebuttonup 151 | then 152 | (match mouseUp with 153 | | None -> () 154 | | ((Some (cb))[@explicit_arity ]) -> 155 | let x = e.mouse_button_x in 156 | let y = e.mouse_button_y in 157 | let button = 158 | match e.mouse_button_button with 159 | | 1 -> Events.LeftButton 160 | | 2 -> Events.MiddleButton 161 | | 3 -> Events.RightButton 162 | | _ -> failwith "Button not supported" in 163 | (cb ~button ~state:Events.MouseUp ~x ~y; ())) 164 | else 165 | if eventType = Sdl.Event.mousemotion 166 | then 167 | (match mouseMove with 168 | | None -> () 169 | | ((Some (cb))[@explicit_arity ]) -> 170 | let x = e.mouse_motion_x in 171 | let y = e.mouse_motion_y in (cb ~x ~y; ())) 172 | else 173 | if eventType = Sdl.Event.windowevent 174 | then 175 | (match windowResize with 176 | | None -> () 177 | | ((Some (cb))[@explicit_arity ]) -> 178 | if 179 | (e.window_event_enum = 180 | Sdl.Event.window_resized) 181 | || 182 | ((e.window_event_enum = 183 | Sdl.Event.window_maximized) 184 | || 185 | (e.window_event_enum = 186 | Sdl.Event.window_restored)) 187 | then cb ()) 188 | else 189 | if eventType = Sdl.Event.keydown 190 | then 191 | (match keyDown with 192 | | None -> () 193 | | ((Some (cb))[@explicit_arity ]) -> 194 | let (keycode, repeat) = 195 | ((e.keyboard_keycode), 196 | (e.keyboard_repeat)) in 197 | cb ~keycode:(Events.keycodeMap keycode) 198 | ~repeat:(repeat == 1)) 199 | else 200 | if eventType = Sdl.Event.keyup 201 | then 202 | (match keyUp with 203 | | None -> () 204 | | ((Some (cb))[@explicit_arity ]) -> 205 | let keycode = e.keyboard_keycode in 206 | cb ~keycode:(Events.keycodeMap keycode))) 207 | done; 208 | !shouldQuit : bool) in 209 | let timeSinceLastDraw = ref (Sdl.get_performance_counter ()) in 210 | let oneFrame = 1000. /. 60. in 211 | let shouldQuit = ref false in 212 | let rec tick () = 213 | let time = Sdl.get_performance_counter () in 214 | let diff = Sdl.get_time_diff (!timeSinceLastDraw) time in 215 | if diff > oneFrame 216 | then 217 | (timeSinceLastDraw := time; 218 | shouldQuit := ((!shouldQuit) || (checkEvents ())); 219 | displayFunc diff; 220 | Sdl.gl_swap_window window); 221 | if not (!shouldQuit) 222 | then 223 | (let timeToSleep = (mod_float (oneFrame -. diff) oneFrame) -. 2. in 224 | if timeToSleep > 1. 225 | then usleep (int_of_float (1000. *. timeToSleep)); 226 | tick ()) in 227 | tick (); (fun _ignored -> false) 228 | type programT = Gl.programT 229 | type shaderT = Gl.shaderT 230 | let clearColor ~context:_ ~r ~g ~b ~a = 231 | Gl.clearColor ~red:r ~green:g ~blue:b ~alpha:a 232 | let createProgram ~context:_ = (Gl.createProgram () : programT) 233 | let createShader ~context:_ shaderType = 234 | (Gl.createShader shaderType : shaderT) 235 | let attachShader ~context:_ ~program ~shader = 236 | Gl.attachShader ~program ~shader 237 | let deleteShader ~context:_ shader = Gl.deleteShader shader 238 | let shaderSource ~context:_ ~shader ~source = 239 | Gl.shaderSource shader [|"#version 120 \n";source|] 240 | let compileShader ~context:_ shader = Gl.compileShader shader 241 | let linkProgram ~context:_ program = Gl.linkProgram program 242 | let useProgram ~context:_ program = Gl.useProgram program 243 | type bufferT = Gl.bufferT 244 | type attributeT = Gl.attribT 245 | type uniformT = Gl.uniformT 246 | let createBuffer ~context:_ = Gl.genBuffer () 247 | let bindBuffer ~context:_ ~target ~buffer = 248 | Gl.bindBuffer ~target ~buffer 249 | type textureT = Gl.textureT 250 | let createTexture ~context:_ = Gl.genTexture () 251 | let activeTexture ~context:_ target = Gl.activeTexture target 252 | let bindTexture ~context:_ ~target ~texture = 253 | Gl.bindTexture ~target ~texture 254 | let texParameteri ~context:_ ~target ~pname ~param = 255 | Gl.texParameteri ~target ~pname ~param 256 | type framebufferT = Gl.framebufferT 257 | let createFramebuffer ~context:_ = Gl.genFramebuffer () 258 | let bindFramebuffer ~context:_ ~target ~framebuffer = 259 | Gl.bindFramebuffer target framebuffer 260 | let bindDefaultFramebuffer ~context:_ ~target = 261 | Gl.bindDefaultFramebuffer target 262 | let framebufferTexture2D ~context:_ ~target ~attachment ~texTarget 263 | ~texture = 264 | Gl.framebufferTexture2D ~target ~attachment ~texTarget ~texture 265 | ~level:0 266 | let enable ~context:_ i = Gl.enable i 267 | let disable ~context:_ i = Gl.disable i 268 | let blendFunc ~context:_ a b = Gl.blendFunc ~sfactor:a ~dfactor:b 269 | let readPixels_RGBA ~context:_ ~x ~y ~width ~height = 270 | Gl.readPixels_RGBA ~x ~y ~width ~height 271 | type loadOptionT = 272 | | LoadAuto 273 | | LoadL 274 | | LoadLA 275 | | LoadRGB 276 | | LoadRGBA 277 | type imageT = Gl.imageT = 278 | { 279 | width: int ; 280 | height: int ; 281 | channels: int ; 282 | data: 283 | (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) 284 | Bigarray.Array1.t 285 | } 286 | let getImageWidth image = image.width 287 | let getImageHeight image = image.height 288 | let loadImage ~filename ?(loadOption= LoadAuto) 289 | ~callback:(callback : imageT option -> unit) () = 290 | match loadOption with 291 | | LoadAuto -> callback (Gl.soilLoadImage ~filename ~loadOption:0) 292 | | LoadL -> callback (Gl.soilLoadImage ~filename ~loadOption:1) 293 | | LoadLA -> callback (Gl.soilLoadImage ~filename ~loadOption:2) 294 | | LoadRGB -> callback (Gl.soilLoadImage ~filename ~loadOption:3) 295 | | LoadRGBA -> callback (Gl.soilLoadImage ~filename ~loadOption:4) 296 | let loadImageFromMemory ~data ?(loadOption= LoadAuto) 297 | ~callback:(callback : imageT option -> unit) () = 298 | match loadOption with 299 | | LoadAuto -> callback (Gl.soilLoadImageFromMemory ~data ~loadOption:0) 300 | | LoadL -> callback (Gl.soilLoadImageFromMemory ~data ~loadOption:1) 301 | | LoadLA -> callback (Gl.soilLoadImageFromMemory ~data ~loadOption:2) 302 | | LoadRGB -> callback (Gl.soilLoadImageFromMemory ~data ~loadOption:3) 303 | | LoadRGBA -> callback (Gl.soilLoadImageFromMemory ~data ~loadOption:4) 304 | let texImage2D_RGBA ~context:_ ~target ~level ~width ~height ~border 305 | ~data = 306 | Gl.texImage2D_RGBA ~target ~level ~width ~height ~border ~data 307 | let texImage2D_null ~context:_ ~target ~level ~width ~height = 308 | Gl.texImage2D_null ~target ~level ~width ~height ~border:0 309 | let texImage2DWithImage ~context ~target ~level ~image = 310 | texImage2D_RGBA ~context ~target ~level ~width:(image.width) 311 | ~height:(image.height) ~border:0 ~data:(image.data) 312 | let uniform1i ~context:_ ~location ~value = 313 | Gl.uniform1i ~location ~value 314 | let uniform1f ~context:_ ~location ~value = 315 | Gl.uniform1f ~location ~value 316 | let uniform2f ~context:_ ~location ~v1 ~v2 = 317 | Gl.uniform2f ~location ~v1 ~v2 318 | let uniform3f ~context:_ ~location ~v1 ~v2 ~v3 = 319 | Gl.uniform3f ~location ~v1 ~v2 ~v3 320 | let uniform4f ~context:_ ~location ~v1 ~v2 ~v3 ~v4 = 321 | Gl.uniform4f ~location ~v1 ~v2 ~v3 ~v4 322 | module type Bigarray = 323 | sig 324 | type ('a, 'b) t 325 | type float64_elt 326 | type float32_elt 327 | type int16_unsigned_elt 328 | type int16_signed_elt 329 | type int8_unsigned_elt 330 | type int8_signed_elt 331 | type int_elt 332 | type int32_elt 333 | type int64_elt 334 | type ('a, 'b) kind = 335 | | Float64: (float, float64_elt) kind 336 | | Float32: (float, float32_elt) kind 337 | | Int16: (int, int16_signed_elt) kind 338 | | Uint16: (int, int16_unsigned_elt) kind 339 | | Int8: (int, int8_signed_elt) kind 340 | | Uint8: (int, int8_unsigned_elt) kind 341 | | Char: (char, int8_unsigned_elt) kind 342 | | Int: (int, int_elt) kind 343 | | Int64: (int64, int64_elt) kind 344 | | Int32: (int32, int32_elt) kind 345 | val create : ('a, 'b) kind -> int -> ('a, 'b) t 346 | val of_array : ('a, 'b) kind -> 'a array -> ('a, 'b) t 347 | val dim : ('a, 'b) t -> int 348 | val blit : ('a, 'b) t -> ('a, 'b) t -> unit 349 | val unsafe_blit : 350 | ('a, 'b) t -> ('a, 'b) t -> offset:int -> numOfBytes:int -> unit 351 | val get : ('a, 'b) t -> int -> 'a 352 | val unsafe_get : ('a, 'b) t -> int -> 'a 353 | val set : ('a, 'b) t -> int -> 'a -> unit 354 | val unsafe_set : ('a, 'b) t -> int -> 'a -> unit 355 | val sub : ('a, 'b) t -> offset:int -> len:int -> ('a, 'b) t 356 | end 357 | module Bigarray = 358 | struct 359 | type ('a, 'b) t = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t 360 | type float64_elt = Bigarray.float64_elt 361 | type float32_elt = Bigarray.float32_elt 362 | type int16_unsigned_elt = Bigarray.int16_unsigned_elt 363 | type int16_signed_elt = Bigarray.int16_signed_elt 364 | type int8_unsigned_elt = Bigarray.int8_unsigned_elt 365 | type int8_signed_elt = Bigarray.int8_signed_elt 366 | type int_elt = Bigarray.int_elt 367 | type int32_elt = Bigarray.int32_elt 368 | type int64_elt = Bigarray.int64_elt 369 | type ('a, 'b) kind = 370 | | Float64: (float, float64_elt) kind 371 | | Float32: (float, float32_elt) kind 372 | | Int16: (int, int16_signed_elt) kind 373 | | Uint16: (int, int16_unsigned_elt) kind 374 | | Int8: (int, int8_signed_elt) kind 375 | | Uint8: (int, int8_unsigned_elt) kind 376 | | Char: (char, int8_unsigned_elt) kind 377 | | Int: (int, int_elt) kind 378 | | Int64: (int64, int64_elt) kind 379 | | Int32: (int32, int32_elt) kind 380 | let create (type a) (type b) (kind : (a, b) kind) size = 381 | (match kind with 382 | | Float64 -> 383 | Bigarray.Array1.create Bigarray.Float64 Bigarray.c_layout size 384 | | Float32 -> 385 | Bigarray.Array1.create Bigarray.Float32 Bigarray.c_layout size 386 | | Int16 -> 387 | Bigarray.Array1.create Bigarray.Int16_signed Bigarray.c_layout 388 | size 389 | | Uint16 -> 390 | Bigarray.Array1.create Bigarray.Int16_unsigned 391 | Bigarray.c_layout size 392 | | Int8 -> 393 | Bigarray.Array1.create Bigarray.Int8_signed Bigarray.c_layout 394 | size 395 | | Uint8 -> 396 | Bigarray.Array1.create Bigarray.Int8_unsigned 397 | Bigarray.c_layout size 398 | | Char -> 399 | Bigarray.Array1.create Bigarray.Char Bigarray.c_layout size 400 | | Int -> 401 | Bigarray.Array1.create Bigarray.Int Bigarray.c_layout size 402 | | Int64 -> 403 | Bigarray.Array1.create Bigarray.Int64 Bigarray.c_layout size 404 | | Int32 -> 405 | Bigarray.Array1.create Bigarray.Int32 Bigarray.c_layout size : 406 | (a, b) t) 407 | let of_array (type a) (type b) (kind : (a, b) kind) (arr : a array) = 408 | (match kind with 409 | | Float64 -> 410 | Bigarray.Array1.of_array Bigarray.Float64 Bigarray.c_layout 411 | arr 412 | | Float32 -> 413 | Bigarray.Array1.of_array Bigarray.Float32 Bigarray.c_layout 414 | arr 415 | | Int16 -> 416 | Bigarray.Array1.of_array Bigarray.Int16_signed 417 | Bigarray.c_layout arr 418 | | Uint16 -> 419 | Bigarray.Array1.of_array Bigarray.Int16_unsigned 420 | Bigarray.c_layout arr 421 | | Int8 -> 422 | Bigarray.Array1.of_array Bigarray.Int8_signed 423 | Bigarray.c_layout arr 424 | | Uint8 -> 425 | Bigarray.Array1.of_array Bigarray.Int8_unsigned 426 | Bigarray.c_layout arr 427 | | Char -> 428 | Bigarray.Array1.of_array Bigarray.Char Bigarray.c_layout arr 429 | | Int -> 430 | Bigarray.Array1.of_array Bigarray.Int Bigarray.c_layout arr 431 | | Int64 -> 432 | Bigarray.Array1.of_array Bigarray.Int64 Bigarray.c_layout arr 433 | | Int32 -> 434 | Bigarray.Array1.of_array Bigarray.Int32 Bigarray.c_layout arr : 435 | (a, b) t) 436 | let dim = Bigarray.Array1.dim 437 | let blit = Bigarray.Array1.blit 438 | external unsafe_blit : 439 | ('a, 'b, 'c) Bigarray.Array1.t -> 440 | ('a, 'b, 'c) Bigarray.Array1.t -> 441 | offset:int -> numOfBytes:int -> unit = "bigarray_unsafe_blit" 442 | [@@noalloc ] 443 | let get = Bigarray.Array1.get 444 | let unsafe_get = Bigarray.Array1.unsafe_get 445 | let set = Bigarray.Array1.set 446 | let unsafe_set = Bigarray.Array1.unsafe_set 447 | let sub (type a) (type b) (arr : (a, b) t) ~offset ~len = 448 | (Bigarray.Array1.sub arr offset len : (a, b) t) 449 | end 450 | let texSubImage2D ~context:_ ~target ~level ~xoffset ~yoffset ~width 451 | ~height ~format ~type_ ~pixels:(pixels : ('a, 'b) Bigarray.t) = 452 | Gl.texSubImage2D ~target ~level ~xoffset ~yoffset ~width ~height 453 | ~format ~type_ ~pixels 454 | let bufferData ~context:_ ~target ~data:(data : ('a, 'b) Bigarray.t) 455 | ~usage = Gl.bufferData ~target ~data ~usage 456 | let viewport ~context:_ ~x ~y ~width ~height = 457 | Gl.viewport ~x ~y ~width ~height 458 | let clear ~context:_ ~mask = Gl.clear mask 459 | let getUniformLocation ~context:_ ~program:(program : programT) ~name 460 | = (Gl.getUniformLocation ~program ~name : uniformT) 461 | let getAttribLocation ~context:_ ~program:(program : programT) ~name = 462 | (Gl.getAttribLocation ~program ~name : attributeT) 463 | let enableVertexAttribArray ~context:_ ~attribute = 464 | Gl.enableVertexAttribArray attribute 465 | let vertexAttribPointer ~context:_ ~attribute ~size ~type_ ~normalize 466 | ~stride ~offset = 467 | Gl.vertexAttribPointer ~index:attribute ~size ~typ:type_ ~normalize 468 | ~stride ~offset 469 | let vertexAttribDivisor ~context:_ ~attribute ~divisor = 470 | Gl.vertexAttribDivisor ~attribute ~divisor 471 | module type Mat4T = 472 | sig 473 | type t 474 | val to_array : t -> float array 475 | val create : unit -> t 476 | val identity : out:t -> unit 477 | val translate : out:t -> matrix:t -> vec:float array -> unit 478 | val scale : out:t -> matrix:t -> vec:float array -> unit 479 | val rotate : 480 | out:t -> matrix:t -> rad:float -> vec:float array -> unit 481 | val ortho : 482 | out:t -> 483 | left:float -> 484 | right:float -> 485 | bottom:float -> top:float -> near:float -> far:float -> unit 486 | val perspective : 487 | out:t -> 488 | fovy:float -> aspect:float -> near:float -> far:float -> unit 489 | val lookAt : 490 | out:t -> 491 | eye:float array -> center:float array -> up:float array -> unit 492 | end 493 | module Mat4 : Mat4T = 494 | struct 495 | type t = float array 496 | let to_array a = a 497 | let epsilon = 0.00001 498 | let create () = 499 | [|1.0;0.0;0.0;0.0;0.0;1.0;0.0;0.0;0.0;0.0;1.0;0.0;0.0;0.0;0.0;1.0|] 500 | let identity ~out:(out : t) = 501 | out.(0) <- 1.0; 502 | out.(1) <- 0.0; 503 | out.(2) <- 0.0; 504 | out.(3) <- 0.0; 505 | out.(4) <- 0.0; 506 | out.(5) <- 1.0; 507 | out.(6) <- 0.0; 508 | out.(7) <- 0.0; 509 | out.(8) <- 0.0; 510 | out.(9) <- 0.0; 511 | out.(10) <- 1.0; 512 | out.(11) <- 0.0; 513 | out.(12) <- 0.0; 514 | out.(13) <- 0.0; 515 | out.(14) <- 0.0; 516 | out.(15) <- 1.0 517 | let translate ~out:(out : t) ~matrix:(matrix : t) 518 | ~vec:(vec : float array) = 519 | let x = vec.(0) in 520 | let y = vec.(1) in 521 | let z = vec.(2) in 522 | if matrix == out 523 | then 524 | (out.(12) <- 525 | (((((matrix.(0)) *. x) +. ((matrix.(4)) *. y)) +. 526 | ((matrix.(8)) *. z)) 527 | +. (matrix.(12))); 528 | out.(13) <- 529 | (((((matrix.(1)) *. x) +. ((matrix.(5)) *. y)) +. 530 | ((matrix.(9)) *. z)) 531 | +. (matrix.(13))); 532 | out.(14) <- 533 | (((((matrix.(2)) *. x) +. ((matrix.(6)) *. y)) +. 534 | ((matrix.(10)) *. z)) 535 | +. (matrix.(14))); 536 | out.(15) <- 537 | (((((matrix.(3)) *. x) +. ((matrix.(7)) *. y)) +. 538 | ((matrix.(11)) *. z)) 539 | +. (matrix.(15)))) 540 | else 541 | (let a00 = matrix.(0) in 542 | let a01 = matrix.(1) in 543 | let a02 = matrix.(2) in 544 | let a03 = matrix.(3) in 545 | let a10 = matrix.(4) in 546 | let a11 = matrix.(5) in 547 | let a12 = matrix.(6) in 548 | let a13 = matrix.(7) in 549 | let a20 = matrix.(8) in 550 | let a21 = matrix.(9) in 551 | let a22 = matrix.(10) in 552 | let a23 = matrix.(11) in 553 | out.(0) <- a00; 554 | out.(1) <- a01; 555 | out.(2) <- a02; 556 | out.(3) <- a03; 557 | out.(4) <- a10; 558 | out.(5) <- a11; 559 | out.(6) <- a12; 560 | out.(7) <- a13; 561 | out.(8) <- a20; 562 | out.(9) <- a21; 563 | out.(10) <- a22; 564 | out.(11) <- a23; 565 | out.(12) <- 566 | ((((a00 *. x) +. (a10 *. y)) +. (a20 *. z)) +. (matrix.(12))); 567 | out.(13) <- 568 | ((((a01 *. x) +. (a11 *. y)) +. (a21 *. z)) +. (matrix.(13))); 569 | out.(14) <- 570 | ((((a02 *. x) +. (a12 *. y)) +. (a22 *. z)) +. (matrix.(14))); 571 | out.(15) <- 572 | ((((a03 *. x) +. (a13 *. y)) +. (a23 *. z)) +. (matrix.(15)))) 573 | let scale ~out:(out : t) ~matrix:(matrix : t) 574 | ~vec:(vec : float array) = 575 | let x = vec.(0) in 576 | let y = vec.(1) in 577 | let z = vec.(2) in 578 | out.(0) <- ((matrix.(0)) *. x); 579 | out.(1) <- ((matrix.(1)) *. x); 580 | out.(2) <- ((matrix.(2)) *. x); 581 | out.(3) <- ((matrix.(3)) *. x); 582 | out.(4) <- ((matrix.(4)) *. y); 583 | out.(5) <- ((matrix.(5)) *. y); 584 | out.(6) <- ((matrix.(6)) *. y); 585 | out.(7) <- ((matrix.(7)) *. y); 586 | out.(8) <- ((matrix.(8)) *. z); 587 | out.(9) <- ((matrix.(9)) *. z); 588 | out.(10) <- ((matrix.(10)) *. z); 589 | out.(11) <- ((matrix.(11)) *. z); 590 | out.(12) <- (matrix.(12)); 591 | out.(13) <- (matrix.(13)); 592 | out.(14) <- (matrix.(14)); 593 | out.(15) <- (matrix.(15)) 594 | let rotate ~out:(out : t) ~matrix:(matrix : t) ~rad:(rad : float) 595 | ~vec:(vec : float array) = 596 | let x = vec.(0) in 597 | let y = vec.(1) in 598 | let z = vec.(2) in 599 | let len = sqrt (((x *. x) +. (y *. y)) +. (z *. z)) in 600 | if (abs_float len) >= epsilon 601 | then 602 | (let len = 1. /. len in 603 | let x = x *. len in 604 | let y = y *. len in 605 | let z = z *. len in 606 | let s = sin rad in 607 | let c = cos rad in 608 | let t = 1. -. c in 609 | let a00 = matrix.(0) in 610 | let a01 = matrix.(1) in 611 | let a02 = matrix.(2) in 612 | let a03 = matrix.(3) in 613 | let a10 = matrix.(4) in 614 | let a11 = matrix.(5) in 615 | let a12 = matrix.(6) in 616 | let a13 = matrix.(7) in 617 | let a20 = matrix.(8) in 618 | let a21 = matrix.(9) in 619 | let a22 = matrix.(10) in 620 | let a23 = matrix.(11) in 621 | let b00 = ((x *. x) *. t) +. c in 622 | let b01 = ((y *. x) *. t) +. (z *. s) in 623 | let b02 = ((z *. x) *. t) -. (y *. s) in 624 | let b10 = ((x *. y) *. t) -. (z *. s) in 625 | let b11 = ((y *. y) *. t) +. c in 626 | let b12 = ((z *. y) *. t) +. (x *. s) in 627 | let b20 = ((x *. z) *. t) +. (y *. s) in 628 | let b21 = ((y *. z) *. t) -. (x *. s) in 629 | let b22 = ((z *. z) *. t) +. c in 630 | out.(0) <- (((a00 *. b00) +. (a10 *. b01)) +. (a20 *. b02)); 631 | out.(1) <- (((a01 *. b00) +. (a11 *. b01)) +. (a21 *. b02)); 632 | out.(2) <- (((a02 *. b00) +. (a12 *. b01)) +. (a22 *. b02)); 633 | out.(3) <- (((a03 *. b00) +. (a13 *. b01)) +. (a23 *. b02)); 634 | out.(4) <- (((a00 *. b10) +. (a10 *. b11)) +. (a20 *. b12)); 635 | out.(5) <- (((a01 *. b10) +. (a11 *. b11)) +. (a21 *. b12)); 636 | out.(6) <- (((a02 *. b10) +. (a12 *. b11)) +. (a22 *. b12)); 637 | out.(7) <- (((a03 *. b10) +. (a13 *. b11)) +. (a23 *. b12)); 638 | out.(8) <- (((a00 *. b20) +. (a10 *. b21)) +. (a20 *. b22)); 639 | out.(9) <- (((a01 *. b20) +. (a11 *. b21)) +. (a21 *. b22)); 640 | out.(10) <- (((a02 *. b20) +. (a12 *. b21)) +. (a22 *. b22)); 641 | out.(11) <- (((a03 *. b20) +. (a13 *. b21)) +. (a23 *. b22))); 642 | if matrix != out 643 | then 644 | (out.(12) <- (matrix.(12)); 645 | out.(13) <- (matrix.(13)); 646 | out.(14) <- (matrix.(14)); 647 | out.(15) <- (matrix.(15))) 648 | let ortho ~out:(out : t) ~left:(left : float) 649 | ~right:(right : float) ~bottom:(bottom : float) 650 | ~top:(top : float) ~near:(near : float) ~far:(far : float) = 651 | let lr = 1. /. (left -. right) in 652 | let bt = 1. /. (bottom -. top) in 653 | let nf = 1. /. (near -. far) in 654 | out.(0) <- ((-2.) *. lr); 655 | out.(1) <- 0.; 656 | out.(2) <- 0.; 657 | out.(3) <- 0.; 658 | out.(4) <- 0.; 659 | out.(5) <- ((-2.) *. bt); 660 | out.(6) <- 0.; 661 | out.(7) <- 0.; 662 | out.(8) <- 0.; 663 | out.(9) <- 0.; 664 | out.(10) <- (2. *. nf); 665 | out.(11) <- 0.; 666 | out.(12) <- ((left +. right) *. lr); 667 | out.(13) <- ((top +. bottom) *. bt); 668 | out.(14) <- ((far +. near) *. nf); 669 | out.(15) <- 1. 670 | let perspective ~out:(out : t) ~fovy:(fovy : float) 671 | ~aspect:(aspect : float) ~near:(near : float) ~far:(far : float) 672 | = 673 | let f = 1.0 /. (tan (fovy /. 2.)) in 674 | out.(0) <- (f /. aspect); 675 | out.(1) <- 0.; 676 | out.(2) <- 0.; 677 | out.(3) <- 0.; 678 | out.(4) <- 0.; 679 | out.(5) <- f; 680 | out.(6) <- 0.; 681 | out.(7) <- 0.; 682 | out.(8) <- 0.; 683 | out.(9) <- 0.; 684 | out.(11) <- (-1.); 685 | out.(12) <- 0.; 686 | out.(13) <- 0.; 687 | out.(15) <- 0.; 688 | if far != infinity 689 | then 690 | (let nf = 1. /. (near -. far) in 691 | out.(10) <- ((far +. near) *. nf); 692 | out.(14) <- (((2. *. far) *. near) *. nf)) 693 | else (out.(10) <- (-1.); out.(14) <- ((-2.) *. near)) 694 | let lookAt ~out ~eye ~center ~up = 695 | let eyex = eye.(0) in 696 | let eyey = eye.(1) in 697 | let eyez = eye.(2) in 698 | let centerx = center.(0) in 699 | let centery = center.(1) in 700 | let centerz = center.(2) in 701 | let upx = up.(0) in 702 | let upy = up.(1) in 703 | let upz = up.(2) in 704 | if 705 | ((abs_float (eyex -. centerx)) < epsilon) && 706 | (((abs_float (eyey -. centery)) < epsilon) && 707 | ((abs_float (eyez -. centerz)) < epsilon)) 708 | then identity ~out 709 | else 710 | (let z0 = eyex -. centerx in 711 | let z1 = eyey -. centery in 712 | let z2 = eyez -. centerz in 713 | let len = 714 | 1. /. (sqrt (((z0 *. z0) +. (z1 *. z1)) +. (z2 *. z2))) in 715 | let z0 = z0 *. len in 716 | let z1 = z1 *. len in 717 | let z2 = z2 *. len in 718 | let x0 = (upy *. z2) -. (upz *. z1) in 719 | let x1 = (upz *. z0) -. (upx *. z2) in 720 | let x2 = (upx *. z1) -. (upy *. z0) in 721 | let len = sqrt (((x0 *. x0) +. (x1 *. x1)) +. (x2 *. x2)) in 722 | let (len, x0, x1, x2) = 723 | if len = 0. 724 | then (len, 0., 0., 0.) 725 | else 726 | (let len = 1. /. len in 727 | (len, (x0 *. len), (x1 *. len), (x2 *. len))) in 728 | let y0 = (z1 *. x2) -. (z2 *. x1) in 729 | let y1 = (z2 *. x0) -. (z0 *. x2) in 730 | let y2 = (z0 *. x1) -. (z1 *. x0) in 731 | let len = sqrt (((y0 *. y0) +. (y1 *. y1)) +. (y2 *. y2)) in 732 | let (len, y0, y1, y2) = 733 | if len = 0. 734 | then (len, 0., 0., 0.) 735 | else 736 | (let len = 1. /. len in 737 | (len, (y0 *. len), (y1 *. len), (y2 *. len))) in 738 | out.(0) <- x0; 739 | out.(1) <- y0; 740 | out.(2) <- z0; 741 | out.(3) <- 0.; 742 | out.(4) <- x1; 743 | out.(5) <- y1; 744 | out.(6) <- z1; 745 | out.(7) <- 0.; 746 | out.(8) <- x2; 747 | out.(9) <- y2; 748 | out.(10) <- z2; 749 | out.(11) <- 0.; 750 | out.(12) <- 751 | (-. (((x0 *. eyex) +. (x1 *. eyey)) +. (x2 *. eyez))); 752 | out.(13) <- 753 | (-. (((y0 *. eyex) +. (y1 *. eyey)) +. (y2 *. eyez))); 754 | out.(14) <- 755 | (-. (((z0 *. eyex) +. (z1 *. eyey)) +. (z2 *. eyez))); 756 | out.(15) <- 1.) 757 | end 758 | let uniformMatrix4fv ~context:_ ~location ~value = 759 | Gl.uniformMatrix4fv ~location ~transpose:false 760 | ~value:(Mat4.to_array value) 761 | type shaderParamsT = 762 | | Shader_delete_status 763 | | Compile_status 764 | | Shader_type 765 | type programParamsT = 766 | | Program_delete_status 767 | | Link_status 768 | | Validate_status 769 | let _getProgramParameter ~context:_ ~program:(program : programT) 770 | ~paramName = Gl.getProgramiv ~program ~pname:paramName 771 | let getProgramParameter ~context ~program:(program : programT) 772 | ~paramName = 773 | match paramName with 774 | | Program_delete_status -> 775 | _getProgramParameter ~context ~program 776 | ~paramName:Gl.gl_delete_status 777 | | Link_status -> 778 | _getProgramParameter ~context ~program ~paramName:Gl.gl_link_status 779 | | Validate_status -> 780 | _getProgramParameter ~context ~program 781 | ~paramName:Gl.gl_validate_status 782 | let _getShaderParameter ~context:_ ~shader ~paramName = 783 | Gl.getShaderiv ~shader ~pname:paramName 784 | let getShaderParameter ~context ~shader ~paramName = 785 | match paramName with 786 | | Shader_delete_status -> 787 | _getShaderParameter ~context ~shader ~paramName:Gl.gl_delete_status 788 | | Compile_status -> 789 | _getShaderParameter ~context ~shader 790 | ~paramName:Gl.gl_compile_status 791 | | Shader_type -> 792 | _getShaderParameter ~context ~shader ~paramName:Gl.gl_shader_type 793 | let getShaderInfoLog ~context:_ shader = Gl.getShaderInfoLog shader 794 | let getProgramInfoLog ~context:_ program = Gl.getProgramInfoLog program 795 | let getShaderSource ~context:_ shader = Gl.getShaderSource shader 796 | let drawArrays ~context:_ ~mode ~first ~count = 797 | Gl.drawArrays ~mode ~first ~count 798 | let drawElements ~context:_ ~mode ~count ~type_ ~offset = 799 | Gl.drawElements ~mode ~count ~typ:type_ ~offset 800 | let drawElementsInstanced ~context:_ ~mode ~count ~type_ ~indices 801 | ~primcount = 802 | Gl.drawElementsInstanced ~mode ~count ~type_ ~indices ~primcount 803 | end 804 | #end 805 | -------------------------------------------------------------------------------- /src/reasongl.ml: -------------------------------------------------------------------------------- 1 | (* Include both because only one will have anything in it, the other will be compiled out. *) 2 | include Reasongl_web 3 | include Reasongl_native 4 | -------------------------------------------------------------------------------- /src/web/events_web.ml: -------------------------------------------------------------------------------- 1 | #if JS then 2 | type buttonStateT = 3 | | LeftButton 4 | | MiddleButton 5 | | RightButton 6 | type stateT = 7 | | MouseDown 8 | | MouseUp 9 | type keycodeT = 10 | | Backspace 11 | | Delete 12 | | Tab 13 | | Enter 14 | | Escape 15 | | Space 16 | | Quote 17 | | Comma 18 | | Minus 19 | | Period 20 | | Slash 21 | | Num_0 22 | | Num_1 23 | | Num_2 24 | | Num_3 25 | | Num_4 26 | | Num_5 27 | | Num_6 28 | | Num_7 29 | | Num_8 30 | | Num_9 31 | | Semicolon 32 | | Equals 33 | | OpenBracket 34 | | Backslash 35 | | CloseBracket 36 | | A 37 | | B 38 | | C 39 | | D 40 | | E 41 | | F 42 | | G 43 | | H 44 | | I 45 | | J 46 | | K 47 | | L 48 | | M 49 | | N 50 | | O 51 | | P 52 | | Q 53 | | R 54 | | S 55 | | T 56 | | U 57 | | V 58 | | W 59 | | X 60 | | Y 61 | | Z 62 | | Right 63 | | Left 64 | | Down 65 | | Up 66 | | LeftCtrl 67 | | LeftShift 68 | | LeftAlt 69 | | LeftOsKey 70 | | RightCtrl 71 | | RightShift 72 | | RightAlt 73 | | RightOsKey 74 | | CapsLock 75 | | Backtick 76 | | Nothing 77 | let keycodeMap = 78 | (fun i32 -> 79 | match Int32.to_int i32 with 80 | | 8 -> Backspace 81 | | 9 -> Tab 82 | | 13 -> Enter 83 | | 16 -> LeftShift 84 | | 17 -> LeftCtrl 85 | | 18 -> LeftAlt 86 | | 20 -> CapsLock 87 | | 27 -> Escape 88 | | 32 -> Space 89 | | 37 -> Left 90 | | 38 -> Up 91 | | 39 -> Right 92 | | 40 -> Down 93 | | 46 -> Delete 94 | | 48 -> Num_0 95 | | 49 -> Num_1 96 | | 50 -> Num_2 97 | | 51 -> Num_3 98 | | 52 -> Num_4 99 | | 53 -> Num_5 100 | | 54 -> Num_6 101 | | 55 -> Num_7 102 | | 56 -> Num_8 103 | | 57 -> Num_9 104 | | 65 -> A 105 | | 66 -> B 106 | | 67 -> C 107 | | 68 -> D 108 | | 69 -> E 109 | | 70 -> F 110 | | 71 -> G 111 | | 72 -> H 112 | | 73 -> I 113 | | 74 -> J 114 | | 75 -> K 115 | | 76 -> L 116 | | 77 -> M 117 | | 78 -> N 118 | | 79 -> O 119 | | 80 -> P 120 | | 81 -> Q 121 | | 82 -> R 122 | | 83 -> S 123 | | 84 -> T 124 | | 85 -> U 125 | | 86 -> V 126 | | 87 -> W 127 | | 88 -> X 128 | | 89 -> Y 129 | | 90 -> Z 130 | | 91 -> LeftOsKey 131 | | 93 -> RightOsKey 132 | | 186 -> Semicolon 133 | | 187 -> Equals 134 | | 188 -> Comma 135 | | 189 -> Minus 136 | | 190 -> Period 137 | | 191 -> Slash 138 | | 192 -> Backtick 139 | | 219 -> OpenBracket 140 | | 220 -> Backslash 141 | | 221 -> CloseBracket 142 | | 222 -> Quote 143 | | _ -> Nothing : Int32.t -> keycodeT) 144 | #end 145 | -------------------------------------------------------------------------------- /src/web/reasongl_web.ml: -------------------------------------------------------------------------------- 1 | #if JS then 2 | module Document = 3 | struct 4 | type t 5 | type element 6 | type window 7 | let window = ([%bs.raw "window"] : window) 8 | let document = ([%bs.raw "document"] : t) 9 | external getElementById : 10 | string -> element Js.nullable = "document.getElementById"[@@bs.val ] 11 | external getContext : element -> string -> 'context = "getContext" 12 | [@@bs.send ] 13 | external getWidth : element -> int = "width"[@@bs.get ] 14 | external getHeight : element -> int = "height"[@@bs.get ] 15 | external requestAnimationFrame : 16 | (unit -> unit) -> int = "window.requestAnimationFrame"[@@bs.val ] 17 | external cancelAnimationFrame : 18 | int -> unit = "window.cancelAnimationFrame"[@@bs.val ] 19 | external now : unit -> float = "Date.now"[@@bs.val ] 20 | external addEventListener : 21 | 'window -> string -> ('eventT -> unit) -> unit = "addEventListener" 22 | [@@bs.send ] 23 | external devicePixelRatio : float = "window.devicePixelRatio"[@@bs.val ] 24 | external setTitle : t -> string -> unit = "title"[@@bs.set ] 25 | end 26 | type canvasT 27 | external setHiddenRAFID : 'a -> int -> unit = "__hiddenrafid"[@@bs.set ] 28 | external getButton : 'eventT -> int = "button"[@@bs.get ] 29 | external getClientX : 'eventT -> int = "clientX"[@@bs.get ] 30 | external getClientY : 'eventT -> int = "clientY"[@@bs.get ] 31 | external getChangedTouches : 'eventT -> 'touchListT = "changedTouches" 32 | [@@bs.get ] 33 | external convertToArray : 34 | 'notarray -> 'thing array = "Array.prototype.slice.call"[@@bs.val ] 35 | external getTouchIdentifier : 'touchT -> int = "identifier"[@@bs.get ] 36 | external preventDefault : 'eventT -> unit = "preventDefault"[@@bs.send ] 37 | external getWhich : 'eventT -> int = "which"[@@bs.get ] 38 | external getBoundingClientRect : 39 | canvasT -> 'leftAndTop = "getBoundingClientRect"[@@bs.send ] 40 | external getTop : 'a -> int = "top"[@@bs.get ] 41 | external getLeft : 'a -> int = "left"[@@bs.get ] 42 | let getTouch0 e canvas = 43 | let touches = convertToArray (getChangedTouches e) in 44 | match touches with 45 | | [|t|] -> 46 | let rect = getBoundingClientRect canvas in 47 | let x = (getClientX t) - (getLeft rect) in 48 | let y = (getClientY t) - (getTop rect) in 49 | ((Some (((getTouchIdentifier t), x, y)))) 50 | | _ -> None 51 | external getCanvasWidth : canvasT -> int = "width"[@@bs.get ] 52 | external getCanvasHeight : canvasT -> int = "height"[@@bs.get ] 53 | external setWidth : canvasT -> int -> unit = "width"[@@bs.set ] 54 | external setHeight : canvasT -> int -> unit = "height"[@@bs.set ] 55 | external createElement : string -> canvasT = "document.createElement" 56 | [@@bs.val ] 57 | let createCanvas () = createElement "canvas" 58 | external addToBody : canvasT -> unit = "document.body.appendChild"[@@bs.val ] 59 | external getContext : 60 | canvasT -> string -> 'options -> 'context = "getContext"[@@bs.send ] 61 | type styleT 62 | external getStyle : canvasT -> styleT = "style"[@@bs.get ] 63 | external setWidthStyle : styleT -> string -> unit = "width"[@@bs.set ] 64 | external setHeightStyle : styleT -> string -> unit = "height"[@@bs.set ] 65 | external setBackgroundColor : styleT -> string -> unit = "backgroundColor" 66 | [@@bs.set ] 67 | type httpRequestT 68 | external makeXMLHttpRequest : unit -> httpRequestT = "XMLHttpRequest" 69 | [@@bs.new ] 70 | external openFile : 71 | httpRequestT -> kind:string -> filename:string -> whatIsThis:bool -> unit = 72 | "open"[@@bs.send ] 73 | external onreadystatechange : 74 | httpRequestT -> (unit -> unit) -> unit = "onreadystatechange"[@@bs.set ] 75 | external setResponseType : httpRequestT -> string -> unit = "responseType" 76 | [@@bs.set ] 77 | external getReadyState : httpRequestT -> int = "readyState"[@@bs.get ] 78 | external getStatus : httpRequestT -> int = "status"[@@bs.get ] 79 | external getResponseText : httpRequestT -> string = "responseText"[@@bs.get ] 80 | type arrayBufferT 81 | type soundT 82 | type audioContextT 83 | type audioLocT 84 | type audioGainT 85 | let makeAudioContext = 86 | ([%bs.raw 87 | {| function(_) { return new (window.AudioContext || window.webkitAudioContext)(); } |}] : 88 | unit -> audioContextT) 89 | external getResponse : httpRequestT -> arrayBufferT = "response"[@@bs.get ] 90 | external decodeAudioData : 91 | audioContextT -> arrayBufferT -> (soundT -> unit) -> unit = 92 | "decodeAudioData"[@@bs.send ] 93 | external createBufferSource : 94 | audioContextT -> audioLocT = "createBufferSource"[@@bs.send ] 95 | external createGain : audioContextT -> audioLocT = "createGain"[@@bs.send ] 96 | external getGain : 'a -> audioGainT = "gain"[@@bs.get ] 97 | external setGainValue : audioGainT -> float -> unit = "value"[@@bs.set ] 98 | external setAudioSourceBuffer : audioLocT -> soundT -> unit = "buffer" 99 | [@@bs.set ] 100 | external getAudioContextDestination : 101 | audioContextT -> audioLocT = "destination"[@@bs.get ] 102 | external audioSourceConnect : audioLocT -> audioLocT -> unit = "connect" 103 | [@@bs.send ] 104 | external audioSourceStart : audioLocT -> float -> unit = "start"[@@bs.send ] 105 | external setAudioSourceLoop : audioLocT -> bool -> unit = "loop"[@@bs.set ] 106 | external sendRequest : httpRequestT -> 'a Js.null -> unit = "send"[@@bs.send 107 | ] 108 | module Gl : RGLInterface.t = 109 | struct 110 | let target = "web" 111 | type contextT 112 | module type FileT = 113 | sig 114 | type t 115 | val readFile : filename:string -> cb:(string -> unit) -> unit 116 | end 117 | module File = 118 | struct 119 | type t 120 | let readFile ~filename ~cb = 121 | let rawFile = makeXMLHttpRequest () in 122 | openFile rawFile ~kind:"GET" ~filename ~whatIsThis:false; 123 | onreadystatechange rawFile 124 | (fun () -> 125 | if 126 | ((getReadyState rawFile) == 4) && 127 | (((getStatus rawFile) == 200) || 128 | ((getStatus rawFile) == 0)) 129 | then cb (getResponseText rawFile)); 130 | sendRequest rawFile Js.null 131 | end 132 | module type WindowT = 133 | sig 134 | type t 135 | val getWidth : t -> int 136 | val getHeight : t -> int 137 | val getPixelWidth : t -> int 138 | val getPixelHeight : t -> int 139 | val getPixelScale : t -> float 140 | val init : ?screen:string -> argv:string array -> t 141 | val setWindowSize : window:t -> width:int -> height:int -> unit 142 | val setWindowTitle : window:t -> title:string -> unit 143 | val getContext : t -> contextT 144 | end 145 | module Window = 146 | struct 147 | type t = (canvasT * audioContextT) 148 | let getWidth (window, _ac) = 149 | int_of_float @@ 150 | ((float_of_int (getCanvasWidth window)) /. 151 | Document.devicePixelRatio) 152 | let getHeight (window, _ac) = 153 | int_of_float @@ 154 | ((float_of_int (getCanvasHeight window)) /. 155 | Document.devicePixelRatio) 156 | let getPixelWidth (window, _ac) = 157 | int_of_float @@ (float_of_int @@ (getCanvasWidth window)) 158 | let getPixelHeight (window, _ac) = 159 | int_of_float @@ (float_of_int @@ (getCanvasHeight window)) 160 | let getPixelScale (_ : t) = Document.devicePixelRatio 161 | let init ?screen ~argv:_ = 162 | let node = 163 | match screen with 164 | | None -> None 165 | | ((Some (id))[@explicit_arity ]) -> 166 | Js.Nullable.toOption(Document.getElementById id) in 167 | let canvas = 168 | match node with 169 | | ((Some (node))[@explicit_arity ]) -> Obj.magic node 170 | | None -> 171 | let canvas = createCanvas () in (addToBody canvas; canvas) in 172 | setBackgroundColor (getStyle canvas) "black"; 173 | (canvas, (makeAudioContext ())) 174 | let setWindowSize ~window:(w, _) ~width ~height = 175 | setWidth w 176 | (int_of_float @@ 177 | ((float_of_int width) *. Document.devicePixelRatio)); 178 | setHeight w 179 | (int_of_float @@ 180 | ((float_of_int height) *. Document.devicePixelRatio)); 181 | setWidthStyle (getStyle w) ((string_of_int width) ^ "px"); 182 | setHeightStyle (getStyle w) ((string_of_int height) ^ "px") 183 | let setWindowTitle ~window:_ ~title = 184 | Document.setTitle Document.document title 185 | let getContext (window, _ac) = 186 | (getContext window "webgl" 187 | ([%bs.obj { preserveDrawingBuffer = true; antialias = true }]) : 188 | contextT) 189 | end 190 | module type AudioT = 191 | sig 192 | type t 193 | val loadSound : Window.t -> string -> (t -> unit) -> unit 194 | val playSound : Window.t -> t -> volume:float -> loop:bool -> unit 195 | end 196 | module Audio = 197 | struct 198 | type t = soundT 199 | let loadSound (_window, audioctx) path cb = 200 | let rawFile = makeXMLHttpRequest () in 201 | setResponseType rawFile "arraybuffer"; 202 | openFile rawFile ~kind:"GET" ~filename:path ~whatIsThis:true; 203 | onreadystatechange rawFile 204 | (fun () -> 205 | if 206 | ((getReadyState rawFile) == 4) && 207 | (((getStatus rawFile) == 200) || 208 | ((getStatus rawFile) == 0)) 209 | then decodeAudioData audioctx (getResponse rawFile) cb); 210 | sendRequest rawFile Js.null 211 | let playSound (_window, audioctx) sound ~volume ~loop = 212 | let src = createBufferSource audioctx in 213 | let gain = createGain audioctx in 214 | setGainValue (getGain gain) volume; 215 | setAudioSourceBuffer src sound; 216 | audioSourceConnect src gain; 217 | audioSourceConnect gain (getAudioContextDestination audioctx); 218 | audioSourceStart src 0.0; 219 | setAudioSourceLoop src loop 220 | end 221 | module Events = Events 222 | type mouseButtonEventT = 223 | button:Events.buttonStateT -> 224 | state:Events.stateT -> x:int -> y:int -> unit 225 | let render ~window:((canvas, _ac) : Window.t) 226 | ?mouseDown:(mouseDown : mouseButtonEventT option) 227 | ?mouseUp:(mouseUp : mouseButtonEventT option) 228 | ?mouseMove:(mouseMove : (x:int -> y:int -> unit) option) 229 | ?keyDown:(keyDown : 230 | (keycode:Events.keycodeT -> repeat:bool -> unit) option) 231 | ?keyUp:(keyUp : (keycode:Events.keycodeT -> unit) option) 232 | ?windowResize:(windowResize : (unit -> unit) option) 233 | ~displayFunc:(displayFunc : float -> unit) () = 234 | let singleTouchId = ref None in 235 | (match mouseDown with 236 | | None -> () 237 | | ((Some (cb))[@explicit_arity ]) -> 238 | (Document.addEventListener canvas "touchstart" 239 | (fun e -> 240 | match getTouch0 e canvas with 241 | | ((Some ((touchId, x, y)))) -> 242 | (match !singleTouchId with 243 | | None -> 244 | (singleTouchId := ((Some (touchId)) 245 | [@explicit_arity ]); 246 | preventDefault e; 247 | cb ~button:Events.LeftButton 248 | ~state:Events.MouseDown ~x ~y) 249 | | _ -> singleTouchId := None) 250 | | None -> ()); 251 | Document.addEventListener canvas "mousedown" 252 | (fun e -> 253 | let button = 254 | match getButton e with 255 | | 0 -> Events.LeftButton 256 | | 1 -> Events.MiddleButton 257 | | 2 -> Events.RightButton 258 | | _ -> assert false in 259 | let state = Events.MouseDown in 260 | let rect = getBoundingClientRect canvas in 261 | let x = (getClientX e) - (getLeft rect) in 262 | let y = (getClientY e) - (getTop rect) in 263 | cb ~button ~state ~x ~y))); 264 | (match mouseUp with 265 | | None -> () 266 | | ((Some (cb))[@explicit_arity ]) -> 267 | (Document.addEventListener canvas "touchend" 268 | (fun e -> 269 | match getTouch0 e canvas with 270 | | ((Some ((touchId, x, y)))) -> 271 | (match !singleTouchId with 272 | | ((Some (id))[@explicit_arity ]) when id = touchId -> 273 | (singleTouchId := None; 274 | preventDefault e; 275 | cb ~button:Events.LeftButton ~state:Events.MouseUp 276 | ~x ~y) 277 | | _ -> ()) 278 | | None -> ()); 279 | Document.addEventListener canvas "touchcancel" 280 | (fun e -> 281 | match getTouch0 e canvas with 282 | | ((Some ((touchId, x, y)))) -> 283 | (match !singleTouchId with 284 | | ((Some (id))[@explicit_arity ]) when id = touchId -> 285 | (singleTouchId := None; 286 | preventDefault e; 287 | cb ~button:Events.LeftButton ~state:Events.MouseUp 288 | ~x ~y) 289 | | _ -> ()) 290 | | None -> ()); 291 | Document.addEventListener canvas "mouseup" 292 | (fun e -> 293 | let button = 294 | match getButton e with 295 | | 0 -> Events.LeftButton 296 | | 1 -> Events.MiddleButton 297 | | 2 -> Events.RightButton 298 | | _ -> assert false in 299 | let state = Events.MouseUp in 300 | let rect = getBoundingClientRect canvas in 301 | let x = (getClientX e) - (getLeft rect) in 302 | let y = (getClientY e) - (getTop rect) in 303 | cb ~button ~state ~x ~y))); 304 | (match mouseMove with 305 | | None -> () 306 | | ((Some (cb))[@explicit_arity ]) -> 307 | (Document.addEventListener canvas "touchmove" 308 | (fun e -> 309 | match getTouch0 e canvas with 310 | | ((Some ((touchId, x, y)))) -> 311 | (match !singleTouchId with 312 | | ((Some (id))[@explicit_arity ]) when id = touchId -> 313 | (preventDefault e; cb ~x ~y) 314 | | _ -> ()) 315 | | None -> ()); 316 | Document.addEventListener canvas "mousemove" 317 | (fun e -> 318 | let rect = getBoundingClientRect canvas in 319 | let x = (getClientX e) - (getLeft rect) in 320 | let y = (getClientY e) - (getTop rect) in cb ~x ~y))); 321 | (let keyLastPressed = ref [] in 322 | (match keyDown with 323 | | None -> () 324 | | ((Some (cb))[@explicit_arity ]) -> 325 | Document.addEventListener Document.window "keydown" 326 | (fun e -> 327 | let keycode = Int32.of_int (getWhich e) in 328 | let repeat = 329 | List.fold_left (fun acc -> fun k -> acc || (k == keycode)) 330 | false (!keyLastPressed) in 331 | if not repeat 332 | then keyLastPressed := (keycode :: (!keyLastPressed)); 333 | cb ~keycode:(Events.keycodeMap keycode) ~repeat)); 334 | (match keyUp with 335 | | None -> () 336 | | ((Some (cb))[@explicit_arity ]) -> 337 | Document.addEventListener Document.window "keyup" 338 | (fun e -> 339 | let keycode = Int32.of_int (getWhich e) in 340 | keyLastPressed := 341 | (List.filter (fun k -> k != keycode) (!keyLastPressed)); 342 | cb ~keycode:(Events.keycodeMap keycode))); 343 | (match windowResize with 344 | | None -> () 345 | | ((Some (cb))[@explicit_arity ]) -> 346 | Document.addEventListener Document.window "resize" 347 | (fun _ -> cb ())); 348 | (let frame = ref None in 349 | let rec tick prev () = 350 | let now = Document.now () in 351 | displayFunc (now -. prev); 352 | (let id = Document.requestAnimationFrame (tick now) in 353 | frame := ((Some (id))[@explicit_arity ]); setHiddenRAFID canvas id) in 354 | let id = Document.requestAnimationFrame (tick (Document.now ())) in 355 | frame := ((Some (id))[@explicit_arity ]); 356 | setHiddenRAFID canvas id; 357 | (fun play -> 358 | match !frame with 359 | | None -> 360 | if play 361 | then 362 | let id = 363 | Document.requestAnimationFrame (tick (Document.now ())) in 364 | (frame := ((Some (id))[@explicit_arity ]); 365 | setHiddenRAFID canvas id; 366 | true) 367 | else false 368 | | ((Some (id))[@explicit_arity ]) -> 369 | if not play 370 | then (Document.cancelAnimationFrame id; frame := None; false) 371 | else true))) 372 | type programT 373 | type shaderT 374 | external clearColor : 375 | context:contextT -> r:float -> g:float -> b:float -> a:float -> unit = 376 | "clearColor"[@@bs.send ] 377 | external createProgram : context:contextT -> programT = "createProgram" 378 | [@@bs.send ] 379 | external createShader : 380 | context:contextT -> int -> shaderT = "createShader"[@@bs.send ] 381 | external _shaderSource : 382 | context:contextT -> shader:shaderT -> source:string -> unit = 383 | "shaderSource"[@@bs.send ] 384 | let shaderSource ~context ~shader ~source = 385 | _shaderSource ~context ~shader 386 | ~source:("#version 100 \n precision highp float; \n" ^ source) 387 | external compileShader : 388 | context:contextT -> shaderT -> unit = "compileShader"[@@bs.send ] 389 | external attachShader : 390 | context:contextT -> program:programT -> shader:shaderT -> unit = 391 | "attachShader"[@@bs.send ] 392 | external deleteShader : 393 | context:contextT -> shaderT -> unit = "deleteShader"[@@bs.send ] 394 | external linkProgram : 395 | context:contextT -> programT -> unit = "linkProgram"[@@bs.send ] 396 | external useProgram : context:contextT -> programT -> unit = "useProgram" 397 | [@@bs.send ] 398 | type bufferT 399 | type attributeT 400 | type uniformT 401 | external createBuffer : context:contextT -> bufferT = "createBuffer" 402 | [@@bs.send ] 403 | external bindBuffer : 404 | context:contextT -> target:int -> buffer:bufferT -> unit = "bindBuffer" 405 | [@@bs.send ] 406 | type textureT 407 | external createTexture : context:contextT -> textureT = "createTexture" 408 | [@@bs.send ] 409 | external activeTexture : 410 | context:contextT -> int -> unit = "activeTexture"[@@bs.send ] 411 | external bindTexture : 412 | context:contextT -> target:int -> texture:textureT -> unit = 413 | "bindTexture"[@@bs.send ] 414 | external texParameteri : 415 | context:contextT -> target:int -> pname:int -> param:int -> unit = 416 | "texParameteri"[@@bs.send ] 417 | type framebufferT 418 | external createFramebuffer : context:contextT -> framebufferT = "" 419 | [@@bs.send ] 420 | external bindFramebuffer : 421 | context:contextT -> target:int -> framebuffer:framebufferT -> unit = "" 422 | [@@bs.send ] 423 | external bindDefaultFramebuffer : 424 | context:contextT -> 425 | target:int -> ((_)[@bs.as {json|null|json}]) -> unit = 426 | "bindFramebuffer"[@@bs.send ] 427 | external framebufferTexture2D : 428 | context:contextT -> 429 | target:int -> 430 | attachment:int -> 431 | texTarget:int -> 432 | texture:textureT -> ((_)[@bs.as {json|0|json}]) -> unit = "" 433 | [@@bs.send ] 434 | external enable : context:contextT -> int -> unit = "enable"[@@bs.send ] 435 | external disable : context:contextT -> int -> unit = "disable"[@@bs.send 436 | ] 437 | external blendFunc : context:contextT -> int -> int -> unit = "blendFunc" 438 | [@@bs.send ] 439 | external createFloat32ArrayOfArray : 440 | float array -> 'flot32array = "Float32Array"[@@bs.new ] 441 | external createFloat32Array : int -> 'float32array = "Float32Array" 442 | [@@bs.new ] 443 | external createFloat64ArrayOfArray : 444 | float array -> 'flot64array = "Float64Array"[@@bs.new ] 445 | external createFloat64Array : int -> 'float64array = "Float64Array" 446 | [@@bs.new ] 447 | external createIntArrayOfArray : int array -> 'int32array = "Int32Array" 448 | [@@bs.new ] 449 | external createInt32ArrayOfArray : 450 | int32 array -> 'int32array = "Int32Array"[@@bs.new ] 451 | external createIntArray : int -> 'int32array = "Int32Array"[@@bs.new ] 452 | external createInt32Array : int -> 'int32array = "Int32Array"[@@bs.new ] 453 | external createUint16ArrayOfArray : 454 | int array -> 'uint16array = "Uint16Array"[@@bs.new ] 455 | external createUint16Array : int -> 'uint16array = "Uint16Array"[@@bs.new 456 | ] 457 | external createInt16ArrayOfArray : 458 | int array -> 'int16array = "Int16Array"[@@bs.new ] 459 | external createInt16Array : int -> 'int16array = "Int16Array"[@@bs.new ] 460 | external createUint8ArrayOfArray : 461 | int array -> 'uint8array = "Uint8Array"[@@bs.new ] 462 | external createUint8Array : int -> 'uint8array = "Uint8Array"[@@bs.new ] 463 | external createInt8ArrayOfArray : int array -> 'int8array = "Int8Array" 464 | [@@bs.new ] 465 | external createInt8Array : int -> 'int8array = "Int8Array"[@@bs.new ] 466 | external createCharArrayOfArray : 467 | char array -> 'uint8array = "Uint8Array"[@@bs.new ] 468 | external sub : 'a -> int -> int -> 'a = "subarray"[@@bs.send ] 469 | module type Bigarray = 470 | sig 471 | type ('a, 'b) t 472 | type float64_elt 473 | type float32_elt 474 | type int16_unsigned_elt 475 | type int16_signed_elt 476 | type int8_unsigned_elt 477 | type int8_signed_elt 478 | type int_elt 479 | type int32_elt 480 | type int64_elt 481 | type ('a, 'b) kind = 482 | | Float64: (float, float64_elt) kind 483 | | Float32: (float, float32_elt) kind 484 | | Int16: (int, int16_signed_elt) kind 485 | | Uint16: (int, int16_unsigned_elt) kind 486 | | Int8: (int, int8_signed_elt) kind 487 | | Uint8: (int, int8_unsigned_elt) kind 488 | | Char: (char, int8_unsigned_elt) kind 489 | | Int: (int, int_elt) kind 490 | | Int64: (int64, int64_elt) kind 491 | | Int32: (int32, int32_elt) kind 492 | val create : ('a, 'b) kind -> int -> ('a, 'b) t 493 | val of_array : ('a, 'b) kind -> 'a array -> ('a, 'b) t 494 | val dim : ('a, 'b) t -> int 495 | val blit : ('a, 'b) t -> ('a, 'b) t -> unit 496 | val unsafe_blit : 497 | ('a, 'b) t -> ('a, 'b) t -> offset:int -> numOfBytes:int -> unit 498 | val get : ('a, 'b) t -> int -> 'a 499 | val unsafe_get : ('a, 'b) t -> int -> 'a 500 | val set : ('a, 'b) t -> int -> 'a -> unit 501 | val unsafe_set : ('a, 'b) t -> int -> 'a -> unit 502 | val sub : ('a, 'b) t -> offset:int -> len:int -> ('a, 'b) t 503 | end 504 | module Bigarray = 505 | struct 506 | type ('a, 'b) t 507 | type float64_elt 508 | type float32_elt 509 | type int16_unsigned_elt 510 | type int16_signed_elt 511 | type int8_unsigned_elt 512 | type int8_signed_elt 513 | type int_elt 514 | type int32_elt 515 | type int64_elt 516 | type ('a, 'b) kind = 517 | | Float64: (float, float64_elt) kind 518 | | Float32: (float, float32_elt) kind 519 | | Int16: (int, int16_signed_elt) kind 520 | | Uint16: (int, int16_unsigned_elt) kind 521 | | Int8: (int, int8_signed_elt) kind 522 | | Uint8: (int, int8_unsigned_elt) kind 523 | | Char: (char, int8_unsigned_elt) kind 524 | | Int: (int, int_elt) kind 525 | | Int64: (int64, int64_elt) kind 526 | | Int32: (int32, int32_elt) kind 527 | let create (type a) (type b) (kind : (a, b) kind) size = 528 | (match kind with 529 | | Float64 -> createFloat64Array size 530 | | Float32 -> createFloat32Array size 531 | | Int16 -> createInt16Array size 532 | | Uint16 -> createUint16Array size 533 | | Int8 -> createInt8Array size 534 | | Uint8 -> createUint8Array size 535 | | Char -> createUint8Array size 536 | | Int -> createIntArray size 537 | | Int32 -> createInt32Array size 538 | | Int64 -> assert false : (a, b) t) 539 | let of_array (type a) (type b) (kind : (a, b) kind) (arr : a array) = 540 | (match kind with 541 | | Float64 -> createFloat64ArrayOfArray arr 542 | | Float32 -> createFloat32ArrayOfArray arr 543 | | Int16 -> createInt16ArrayOfArray arr 544 | | Uint16 -> createUint16ArrayOfArray arr 545 | | Int8 -> createInt8ArrayOfArray arr 546 | | Uint8 -> createUint8ArrayOfArray arr 547 | | Char -> createCharArrayOfArray arr 548 | | Int -> createIntArrayOfArray arr 549 | | Int32 -> createInt32ArrayOfArray arr 550 | | Int64 -> assert false : (a, b) t) 551 | external dim : 'a -> int = "length"[@@bs.get ] 552 | external blit : ('a, 'b) t -> ('a, 'b) t -> unit = "set"[@@bs.send ] 553 | external unsafe_blit : 554 | ('a, 'b) t -> ('a, 'b) t -> offset:int -> unit = "set"[@@bs.send ] 555 | let unsafe_blit = 556 | (fun arr -> 557 | fun arr2 -> 558 | fun ~offset -> 559 | fun ~numOfBytes:_ -> unsafe_blit arr2 arr ~offset : 560 | ('a, 'b) t -> ('a, 'b) t -> offset:int -> numOfBytes:int -> unit) 561 | external get : ('a, 'b) t -> int -> 'a = ""[@@bs.get_index ] 562 | external unsafe_get : ('a, 'b) t -> int -> 'a = ""[@@bs.get_index ] 563 | external set : ('a, 'b) t -> int -> 'a -> unit = ""[@@bs.set_index ] 564 | external unsafe_set : ('a, 'b) t -> int -> 'a -> unit = ""[@@bs.set_index 565 | ] 566 | let sub arr ~offset ~len = sub arr offset (offset + len) 567 | end 568 | external texSubImage2D : 569 | context:contextT -> 570 | target:int -> 571 | level:int -> 572 | xoffset:int -> 573 | yoffset:int -> 574 | width:int -> 575 | height:int -> 576 | format:int -> 577 | type_:int -> pixels:('a, 'b) Bigarray.t -> unit = 578 | "texSubImage2D"[@@bs.send ] 579 | external readPixels : 580 | context:contextT -> 581 | x:int -> 582 | y:int -> 583 | width:int -> 584 | height:int -> 585 | format:int -> 586 | type_:int -> 587 | pixels:(int, Bigarray.int8_unsigned_elt) Bigarray.t -> 588 | unit = "readPixels"[@@bs.send ] 589 | let readPixels_RGBA ~context ~x ~y ~width ~height = 590 | let data = createUint8Array ((width * height) * 4) in 591 | readPixels ~context ~x ~y ~width ~height ~format:RGLConstants.rgba 592 | ~type_:RGLConstants.unsigned_byte ~pixels:data; 593 | data 594 | type imageT 595 | external getImageWidth : imageT -> int = "width"[@@bs.get ] 596 | external getImageHeight : imageT -> int = "height"[@@bs.get ] 597 | type loadOptionT = 598 | | LoadAuto 599 | | LoadL 600 | | LoadLA 601 | | LoadRGB 602 | | LoadRGBA 603 | external makeImage : unit -> imageT = "Image"[@@bs.new ] 604 | external setSrc : imageT -> string -> unit = "src"[@@bs.set ] 605 | external addEventListener : 606 | imageT -> string -> (unit -> unit) -> unit = "addEventListener" 607 | [@@bs.send ] 608 | external btoa : string -> string = ""[@@bs.val ] 609 | let loadImage ~filename ?loadOption ~callback () = 610 | match loadOption with 611 | | _ -> 612 | let image = makeImage () in 613 | (setSrc image filename; 614 | addEventListener image "load" 615 | (fun () -> callback ((Some (image))[@explicit_arity ]))) 616 | let loadImageFromMemory ~data ?loadOption ~callback () = 617 | let image = makeImage () in 618 | setSrc image ("data:image/png;base64," ^ (btoa data)); 619 | addEventListener image "load" 620 | (fun () -> callback ((Some (image))[@explicit_arity ])) 621 | external _texImage2DWithImage : 622 | context:contextT -> 623 | target:int -> 624 | level:int -> 625 | internalFormat:int -> 626 | format:int -> type_:int -> image:imageT -> unit = "texImage2D" 627 | [@@bs.send ] 628 | let texImage2DWithImage ~context ~target ~level ~image = 629 | _texImage2DWithImage ~context ~target ~level 630 | ~internalFormat:RGLConstants.rgba ~format:RGLConstants.rgba 631 | ~type_:RGLConstants.unsigned_byte ~image 632 | external _texImage2D : 633 | context:contextT -> 634 | target:int -> 635 | level:int -> 636 | internalFormat:int -> 637 | width:int -> 638 | height:int -> 639 | border:int -> 640 | format:int -> 641 | type_:int -> data:('a, 'b) Bigarray.t -> unit = 642 | "texImage2D"[@@bs.send ] 643 | let texImage2D_RGBA ~context ~target ~level ~width ~height ~border 644 | ~data = 645 | _texImage2D ~context ~target ~level ~internalFormat:RGLConstants.rgba 646 | ~width ~height ~border ~format:RGLConstants.rgba 647 | ~type_:RGLConstants.unsigned_byte ~data 648 | let texImage2D_null = 649 | [%bs.raw 650 | {| function(gl, target, level, width, height) { 651 | gl.texImage2D(target, level, gl.RGBA, width, height, 0, gl.RGBA, gl.UNSIGNED_BYTE, null) 652 | } |}] 653 | external vertexAttribDivisor : 654 | context:contextT -> attribute:attributeT -> divisor:int -> unit = 655 | "vertexAttribDivisor"[@@bs.send ] 656 | external bufferData : 657 | context:contextT -> 658 | target:int -> data:('a, 'b) Bigarray.t -> usage:int -> unit = 659 | "bufferData"[@@bs.send ] 660 | external viewport : 661 | context:contextT -> x:int -> y:int -> width:int -> height:int -> unit = 662 | "viewport"[@@bs.send ] 663 | external clear : context:contextT -> mask:int -> unit = "clear"[@@bs.send 664 | ] 665 | external getUniformLocation : 666 | context:contextT -> program:programT -> name:string -> uniformT = 667 | "getUniformLocation"[@@bs.send ] 668 | external getAttribLocation : 669 | context:contextT -> program:programT -> name:string -> attributeT = 670 | "getAttribLocation"[@@bs.send ] 671 | external enableVertexAttribArray : 672 | context:contextT -> attribute:attributeT -> unit = 673 | "enableVertexAttribArray"[@@bs.send ] 674 | external _vertexAttribPointer : 675 | context:contextT -> 676 | attribute:attributeT -> 677 | size:int -> 678 | type_:int -> normalize:bool -> stride:int -> offset:int -> unit = 679 | "vertexAttribPointer"[@@bs.send ] 680 | let vertexAttribPointer ~context ~attribute ~size ~type_ ~normalize 681 | ~stride ~offset = 682 | let normalize = if normalize then true else false in 683 | _vertexAttribPointer ~context ~attribute ~size ~type_ ~normalize 684 | ~stride ~offset 685 | module type Mat4T = 686 | sig 687 | type t 688 | val to_array : t -> float array 689 | val create : unit -> t 690 | val identity : out:t -> unit 691 | val translate : out:t -> matrix:t -> vec:float array -> unit 692 | val scale : out:t -> matrix:t -> vec:float array -> unit 693 | val rotate : 694 | out:t -> matrix:t -> rad:float -> vec:float array -> unit 695 | val ortho : 696 | out:t -> 697 | left:float -> 698 | right:float -> 699 | bottom:float -> top:float -> near:float -> far:float -> unit 700 | val perspective : 701 | out:t -> 702 | fovy:float -> aspect:float -> near:float -> far:float -> unit 703 | val lookAt : 704 | out:t -> 705 | eye:float array -> center:float array -> up:float array -> unit 706 | end 707 | module Mat4 : Mat4T = 708 | struct 709 | type t = float array 710 | let to_array a = a 711 | external create : unit -> t = ""[@@bs.scope "mat4"][@@bs.module 712 | "gl-matrix"] 713 | external identity : out:t -> unit = ""[@@bs.scope "mat4"][@@bs.module 714 | "gl-matrix"] 715 | external translate : 716 | out:t -> matrix:t -> vec:float array -> unit = ""[@@bs.scope 717 | "mat4"][@@bs.module 718 | "gl-matrix"] 719 | external scale : out:t -> matrix:t -> vec:float array -> unit = "" 720 | [@@bs.scope "mat4"][@@bs.module "gl-matrix"] 721 | external rotate : 722 | out:t -> matrix:t -> rad:float -> vec:float array -> unit = "" 723 | [@@bs.scope "mat4"][@@bs.module "gl-matrix"] 724 | external ortho : 725 | out:t -> 726 | left:float -> 727 | right:float -> 728 | bottom:float -> top:float -> near:float -> far:float -> unit 729 | = ""[@@bs.scope "mat4"][@@bs.module "gl-matrix"] 730 | external perspective : 731 | out:t -> 732 | fovy:float -> aspect:float -> near:float -> far:float -> unit = 733 | ""[@@bs.scope "mat4"][@@bs.module "gl-matrix"] 734 | external lookAt : 735 | out:t -> 736 | eye:float array -> center:float array -> up:float array -> unit = 737 | ""[@@bs.scope "mat4"][@@bs.module "gl-matrix"] 738 | end 739 | external uniform1i : 740 | context:contextT -> location:uniformT -> value:int -> unit = 741 | "uniform1i"[@@bs.send ] 742 | external uniform1f : 743 | context:contextT -> location:uniformT -> value:float -> unit = 744 | "uniform1f"[@@bs.send ] 745 | external uniform2f : 746 | context:contextT -> location:uniformT -> v1:float -> v2:float -> unit = 747 | "uniform2f"[@@bs.send ] 748 | external uniform3f : 749 | context:contextT -> 750 | location:uniformT -> v1:float -> v2:float -> v3:float -> unit = 751 | "uniform3f"[@@bs.send ] 752 | external uniform4f : 753 | context:contextT -> 754 | location:uniformT -> 755 | v1:float -> v2:float -> v3:float -> v4:float -> unit = "uniform4f" 756 | [@@bs.send ] 757 | external _uniformMatrix4fv : 758 | context:contextT -> 759 | location:uniformT -> transpose:bool -> value:Mat4.t -> unit = 760 | "uniformMatrix4fv"[@@bs.send ] 761 | let uniformMatrix4fv ~context ~location ~value = 762 | _uniformMatrix4fv ~context ~location ~transpose:false ~value 763 | type 'a shaderParamsInternalT = 764 | | Shader_delete_status_internal: bool shaderParamsInternalT 765 | | Compile_status_internal: bool shaderParamsInternalT 766 | | Shader_type_internal: int shaderParamsInternalT 767 | type 'a programParamsInternalT = 768 | | Program_delete_status_internal: bool programParamsInternalT 769 | | Link_status_internal: bool programParamsInternalT 770 | | Validate_status_internal: bool programParamsInternalT 771 | type shaderParamsT = 772 | | Shader_delete_status 773 | | Compile_status 774 | | Shader_type 775 | type programParamsT = 776 | | Program_delete_status 777 | | Link_status 778 | | Validate_status 779 | external deleteStatus : context:contextT -> int = "DELETE_STATUS" 780 | [@@bs.get ] 781 | external compileStatus : context:contextT -> int = "COMPILE_STATUS" 782 | [@@bs.get ] 783 | external linkStatus : context:contextT -> int = "LINK_STATUS"[@@bs.get ] 784 | external validateStatus : context:contextT -> int = "VALIDATE_STATUS" 785 | [@@bs.get ] 786 | external shaderType : context:contextT -> int = "SHADER_TYPE"[@@bs.get ] 787 | external _getProgramParameter : 788 | context:contextT -> 789 | program:programT -> 790 | paramName:int -> (('a programParamsInternalT)[@bs.ignore ]) -> 'a = 791 | "getProgramParameter"[@@bs.send ] 792 | let getProgramParameter ~context ~program ~paramName = 793 | match paramName with 794 | | Program_delete_status -> 795 | if 796 | _getProgramParameter ~context ~program 797 | ~paramName:(deleteStatus ~context) 798 | Program_delete_status_internal 799 | then 1 800 | else 0 801 | | Link_status -> 802 | if 803 | _getProgramParameter ~context ~program 804 | ~paramName:(linkStatus ~context) Link_status_internal 805 | then 1 806 | else 0 807 | | Validate_status -> 808 | if 809 | _getProgramParameter ~context ~program 810 | ~paramName:(validateStatus ~context) Validate_status_internal 811 | then 1 812 | else 0 813 | external _getShaderParameter : 814 | context:contextT -> 815 | shader:shaderT -> 816 | paramName:int -> (('a shaderParamsInternalT)[@bs.ignore ]) -> 'a = 817 | "getShaderParameter"[@@bs.send ] 818 | let getShaderParameter ~context ~shader ~paramName = 819 | match paramName with 820 | | Shader_delete_status -> 821 | if 822 | _getShaderParameter ~context ~shader 823 | ~paramName:(deleteStatus ~context) 824 | Shader_delete_status_internal 825 | then 1 826 | else 0 827 | | Compile_status -> 828 | if 829 | _getShaderParameter ~context ~shader 830 | ~paramName:(compileStatus ~context) Compile_status_internal 831 | then 1 832 | else 0 833 | | Shader_type -> 834 | _getShaderParameter ~context ~shader 835 | ~paramName:(shaderType ~context) Shader_type_internal 836 | external getShaderInfoLog : 837 | context:contextT -> shaderT -> string = "getShaderInfoLog"[@@bs.send ] 838 | external getProgramInfoLog : 839 | context:contextT -> programT -> string = "getProgramInfoLog"[@@bs.send 840 | ] 841 | external getShaderSource : 842 | context:contextT -> shaderT -> string = "getShaderSource"[@@bs.send ] 843 | external drawArrays : 844 | context:contextT -> mode:int -> first:int -> count:int -> unit = 845 | "drawArrays"[@@bs.send ] 846 | external drawElements : 847 | context:contextT -> 848 | mode:int -> count:int -> type_:int -> offset:int -> unit = 849 | "drawElements"[@@bs.send ] 850 | external drawElementsInstanced : 851 | context:contextT -> 852 | mode:int -> 853 | count:int -> type_:int -> indices:int -> primcount:int -> unit = 854 | "drawElementsInstanced"[@@bs.send ] 855 | end 856 | #end 857 | -------------------------------------------------------------------------------- /yarn.lock: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. 2 | # yarn lockfile v1 3 | 4 | 5 | "@bsansouci/tgls@^0.8.4": 6 | version "0.8.4" 7 | resolved "https://registry.yarnpkg.com/@bsansouci/tgls/-/tgls-0.8.4.tgz#55af985dd08077216dd7b60f5ba71e1f4d18c5a5" 8 | integrity sha512-BELFkZS1H8z8z1kTYiVJJc5WXY1KsY8oqfQZ2auwzonTLqIDq9cHIGx0IK5obxseCuiJdpxTx4lhlX3ju2IG+g== 9 | 10 | "@bsansouci/tsdl@^0.9.1": 11 | version "0.9.1" 12 | resolved "https://registry.yarnpkg.com/@bsansouci/tsdl/-/tsdl-0.9.1.tgz#5d19bdf76b1f6ceea9d6aa3c407a6592f3f8f1f2" 13 | integrity sha512-AAIdaYdJuTTO6IZ+YZJJJ8elspUcf2QJsBZ3KNwFDk9e7/HpPTyFtsOVHBPdu0mn+luI0OigUPwopI97esmL0g== 14 | dependencies: 15 | sdl2 bsansouci/SDL-mirror#fast 16 | 17 | bsb-native@4.0.6: 18 | version "4.0.6" 19 | resolved "https://registry.yarnpkg.com/bsb-native/-/bsb-native-4.0.6.tgz#5c0289e24e0a3375ebf8f69a17510b884cace1ca" 20 | integrity sha512-T1MkndnmA4StiKK2UvEftrqANN+h9StlLghBbwmKa833d97D86np+2wmIOw5Rqy6rNW3D076A2G51mooWTUwfQ== 21 | dependencies: 22 | yauzl "^2.9.1" 23 | 24 | buffer-crc32@~0.2.3: 25 | version "0.2.13" 26 | resolved "https://registry.yarnpkg.com/buffer-crc32/-/buffer-crc32-0.2.13.tgz#0d333e3f00eac50aa1454abd30ef8c2a5d9a7242" 27 | 28 | fd-slicer@~1.1.0: 29 | version "1.1.0" 30 | resolved "https://registry.yarnpkg.com/fd-slicer/-/fd-slicer-1.1.0.tgz#25c7c89cb1f9077f8891bbe61d8f390eae256f1e" 31 | dependencies: 32 | pend "~1.2.0" 33 | 34 | gl-matrix@*: 35 | version "2.6.1" 36 | resolved "https://registry.yarnpkg.com/gl-matrix/-/gl-matrix-2.6.1.tgz#1bc7f7b396f4ae80abdb4db9a98cd07d170b9004" 37 | 38 | pend@~1.2.0: 39 | version "1.2.0" 40 | resolved "https://registry.yarnpkg.com/pend/-/pend-1.2.0.tgz#7a57eb550a6783f9115331fcf4663d5c8e007a50" 41 | 42 | "sdl2@github:bsansouci/SDL-mirror#fast": 43 | version "2.0.5" 44 | resolved "https://codeload.github.com/bsansouci/SDL-mirror/tar.gz/db0756eec3c5979b8291d739ebac9e8747ccbac2" 45 | dependencies: 46 | yauzl "^2.9.1" 47 | 48 | yauzl@^2.9.1: 49 | version "2.9.2" 50 | resolved "https://registry.yarnpkg.com/yauzl/-/yauzl-2.9.2.tgz#4fb1bc7ae1fc2f57037b54af6acc8fe1031c5b77" 51 | dependencies: 52 | buffer-crc32 "~0.2.3" 53 | fd-slicer "~1.1.0" 54 | --------------------------------------------------------------------------------