Skip to content

Instantly share code, notes, and snippets.

@RawToast
Last active January 16, 2020 05:34
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Embed
What would you like to do?
Getting window details from reasongl
module Document = {
type t;
type element;
type window;
let window: window = [%bs.raw "window"];
let document: t = [%bs.raw "document"];
/* external setGlDebug : window => GlT.context => unit = "debugContext" [@@bs.set]; */
[@bs.val]
external getElementById : string => Js.nullable(element) =
"document.getElementById";
[@bs.send]
external getContext : (element, string) => 'context = "getContext";
[@bs.get] external getWidth : element => int = "width";
[@bs.get] external getHeight : element => int = "height";
[@bs.val]
external requestAnimationFrame : (unit => unit) => int =
"window.requestAnimationFrame";
[@bs.val]
external cancelAnimationFrame : int => unit = "window.cancelAnimationFrame";
[@bs.val] external now : unit => float = "Date.now";
[@bs.send]
external addEventListener : ('window, string, 'eventT => unit) => unit =
"addEventListener";
[@bs.val] external devicePixelRatio : float = "window.devicePixelRatio";
[@bs.set] external setTitle : (t, string) => unit = "title";
};
type canvasT;
[@bs.set] external setHiddenRAFID : ('a, int) => unit = "__hiddenrafid";
[@bs.get] external getButton : 'eventT => int = "button";
[@bs.get] external getClientX : 'eventT => int = "clientX";
[@bs.get] external getClientY : 'eventT => int = "clientY";
[@bs.get]
external getChangedTouches : 'eventT => 'touchListT = "changedTouches";
[@bs.val] external convertToArray : 'notarray => array('thing) = "Array.prototype.slice.call";
[@bs.get] external getTouchIdentifier : 'touchT => int = "identifier";
[@bs.send] external preventDefault : 'eventT => unit = "preventDefault";
[@bs.get] external getWhich : 'eventT => int = "which";
[@bs.send]
external getBoundingClientRect : canvasT => 'leftAndTop =
"getBoundingClientRect";
[@bs.get] external getTop : 'a => int = "top";
[@bs.get] external getLeft : 'a => int = "left";
[@bs.get] external getRectWidth : 'a => float = "width";
[@bs.get] external getRectHeight : 'a => float = "height";
let getTouch0 = (e, canvas) => {
let touches = convertToArray(getChangedTouches(e));
switch (touches) {
| [|t|] =>
let rect = getBoundingClientRect(canvas);
let x = getClientX(t) - getLeft(rect);
let y = getClientY(t) - getTop(rect);
Some((getTouchIdentifier(t), x, y));
| _ => None
};
};
let getTouches = (e, canvas) => {
let touches = convertToArray(getChangedTouches(e));
let rect = getBoundingClientRect(canvas);
Array.map(t => (
getTouchIdentifier(t),
getClientX(t) - getLeft(rect),
getClientY(t) - getTop(rect)),
touches);
};
[@bs.get] external getCanvasWidth : canvasT => int = "width";
[@bs.get] external getCanvasHeight : canvasT => int = "height";
[@bs.set] external setWidth : (canvasT, int) => unit = "width";
[@bs.set] external setHeight : (canvasT, int) => unit = "height";
[@bs.val]
external createElement : string => canvasT = "document.createElement";
let createCanvas = () => createElement("canvas");
[@bs.val] external addToBody : canvasT => unit = "document.body.appendChild";
[@bs.send]
external getContext : (canvasT, string, 'options) => 'context = "getContext";
type styleT;
[@bs.get] external getStyle : canvasT => styleT = "style";
[@bs.set] external setWidthStyle : (styleT, string) => unit = "width";
[@bs.set] external setHeightStyle : (styleT, string) => unit = "height";
[@bs.get] external getWidthStyle : (styleT) => string = "width";
[@bs.get] external getHeightStyle : (styleT) => string = "height";
[@bs.set]
external setBackgroundColor : (styleT, string) => unit = "backgroundColor";
type httpRequestT;
[@bs.new]
external makeXMLHttpRequest : unit => httpRequestT = "XMLHttpRequest";
[@bs.send]
external openFile :
(httpRequestT, ~kind: string, ~filename: string, ~whatIsThis: bool) => unit =
"open";
[@bs.set]
external onreadystatechange : (httpRequestT, unit => unit) => unit =
"onreadystatechange";
[@bs.set]
external setResponseType : (httpRequestT, string) => unit = "responseType";
[@bs.get] external getReadyState : httpRequestT => int = "readyState";
[@bs.get] external getStatus : httpRequestT => int = "status";
[@bs.get] external getResponseText : httpRequestT => string = "responseText";
type arrayBufferT;
type soundT;
type audioContextT;
type audioLocT;
type audioGainT;
let makeAudioContext: unit => audioContextT = [%bs.raw
{| function(_) { return new (window.AudioContext || window.webkitAudioContext)(); } |}
];
[@bs.get] external getResponse : httpRequestT => arrayBufferT = "response";
[@bs.send]
external decodeAudioData :
(audioContextT, arrayBufferT, soundT => unit) => unit =
"decodeAudioData";
[@bs.send]
external createBufferSource : audioContextT => audioLocT =
"createBufferSource";
[@bs.send] external createGain : audioContextT => audioLocT = "createGain";
[@bs.get] external getGain : 'a => audioGainT = "gain";
[@bs.set] external setGainValue : (audioGainT, float) => unit = "value";
[@bs.set]
external setAudioSourceBuffer : (audioLocT, soundT) => unit = "buffer";
[@bs.get]
external getAudioContextDestination : audioContextT => audioLocT =
"destination";
[@bs.send]
external audioSourceConnect : (audioLocT, audioLocT) => unit = "connect";
[@bs.send] external audioSourceStart : (audioLocT, float) => unit = "start";
[@bs.set] external setAudioSourceLoop : (audioLocT, bool) => unit = "loop";
[@bs.send]
external sendRequest : (httpRequestT, Js.null('a)) => unit = "send";
module Gl: RGLInterface.t = {
let target = "web";
type contextT;
module type FileT = {
type t;
let readFile: (~filename: string, ~cb: string => unit) => unit;
};
module File = {
type t;
let readFile = (~filename, ~cb) => {
let rawFile = makeXMLHttpRequest();
openFile(rawFile, ~kind="GET", ~filename, ~whatIsThis=false);
onreadystatechange(rawFile, () =>
if (getReadyState(rawFile) === 4
&& (getStatus(rawFile) === 200 || getStatus(rawFile) === 0)) {
cb(getResponseText(rawFile));
}
);
sendRequest(rawFile, Js.null);
};
};
module type WindowT = {
type t;
let getWidth: t => int;
let getHeight: t => int;
let getPixelWidth: t => int;
let getPixelHeight: t => int;
let getPixelScale: t => float;
let init: (~screen: string=?, ~argv: array(string)) => t;
let setWindowSize: (~window: t, ~width: int, ~height: int) => unit;
let setWindowTitle: (~window: t, ~title: string) => unit;
let getContext: t => contextT;
};
module Window = {
type t = (canvasT, audioContextT);
let getWidth = ((window, _ac)) =>
int_of_float @@
float_of_int(getCanvasWidth(window))
/. Document.devicePixelRatio;
let getHeight = ((window, _ac)) =>
int_of_float @@
float_of_int(getCanvasHeight(window))
/. Document.devicePixelRatio;
let getPixelWidth = ((window, _ac)) =>
int_of_float @@ float_of_int @@ getCanvasWidth(window);
let getPixelHeight = ((window, _ac)) =>
int_of_float @@ float_of_int @@ getCanvasHeight(window);
let getPixelScale = (_: t) => Document.devicePixelRatio;
let init = (~screen=?, ~argv as _) => {
let node =
switch (screen) {
| None => None
| Some(id) => Js.Nullable.toOption(Document.getElementById(id))
};
let canvas =
switch (node) {
| Some(node) => Obj.magic(node)
| None =>
let canvas = createCanvas();
addToBody(canvas);
canvas;
};
setBackgroundColor(getStyle(canvas), "black");
(canvas, makeAudioContext());
};
let setWindowSize = (~window as (w, _), ~width, ~height) => {
setWidth(
w,
int_of_float @@ float_of_int(width) *. Document.devicePixelRatio,
);
setHeight(
w,
int_of_float @@ float_of_int(height) *. Document.devicePixelRatio,
);
setWidthStyle(getStyle(w), string_of_int(width) ++ "px");
setHeightStyle(getStyle(w), string_of_int(height) ++ "px");
};
let setWindowTitle = (~window as _, ~title) =>
Document.setTitle(Document.document, title);
let getContext = ((window, _ac)) : contextT =>
getContext(
window,
"webgl",
{"preserveDrawingBuffer": true, "antialias": true},
);
};
module type AudioT = {
type t;
let loadSound: (Window.t, string, t => unit) => unit;
let playSound: (Window.t, t, ~volume: float, ~loop: bool) => unit;
};
module Audio = {
type t = soundT;
let loadSound = ((_window, audioctx), path, cb) => {
let rawFile = makeXMLHttpRequest();
setResponseType(rawFile, "arraybuffer");
openFile(rawFile, ~kind="GET", ~filename=path, ~whatIsThis=true);
onreadystatechange(rawFile, () =>
if (getReadyState(rawFile) === 4
&& (getStatus(rawFile) === 200 || getStatus(rawFile) === 0)) {
decodeAudioData(audioctx, getResponse(rawFile), cb);
}
);
sendRequest(rawFile, Js.null);
};
let playSound = ((_window, audioctx), sound, ~volume, ~loop) => {
let src = createBufferSource(audioctx);
let gain = createGain(audioctx);
setGainValue(getGain(gain), volume);
setAudioSourceBuffer(src, sound);
audioSourceConnect(src, gain);
audioSourceConnect(gain, getAudioContextDestination(audioctx));
audioSourceStart(src, 0.0);
setAudioSourceLoop(src, loop);
};
};
module Events = Events;
type mouseButtonEventT =
(~button: Events.buttonStateT, ~state: Events.stateT, ~x: int, ~y: int) =>
unit;
/*** See Gl.re for explanation. **/
let render =
(
~window as (canvas, _ac): Window.t,
~mouseDown: option(mouseButtonEventT)=?,
~mouseUp: option(mouseButtonEventT)=?,
~mouseMove: option((~x: int, ~y: int) => unit)=?,
~keyDown: option((~keycode: Events.keycodeT, ~repeat: bool) => unit)=?,
~keyUp: option((~keycode: Events.keycodeT) => unit)=?,
~windowResize: option(unit => unit)=?,
~displayFunc: float => unit,
(),
) => {
let touches = ref([]);
let addTouch = touchId => {
touches := List.exists(id => id == touchId, touches^) ?
touches^ :
[touchId, ...touches^];
};
let removeTouch = touchId => {
touches := List.filter(id => id == touchId, touches^);
};
switch (mouseDown) {
| None => ()
| Some(cb) =>
Document.addEventListener(canvas, "touchstart", e => {
let touches = getTouches(e, canvas);
Array.length(touches) > 0 ? {
preventDefault(e);
Array.iter(t => {
let (touchId, x, y) = t;
addTouch(touchId);
cb(~button=Events.LeftButton, ~state=Events.MouseDown, ~x, ~y)}, touches);
} : ();
}
);
Document.addEventListener(
canvas,
"mousedown",
e => {
let button =
switch (getButton(e)) {
| 0 => Events.LeftButton
| 1 => Events.MiddleButton
| 2 => Events.RightButton
| _ => assert false
};
let rect = getBoundingClientRect(canvas);
let left = getLeft(rect);
let top = getTop(rect);
let actualWidth = getRectWidth(rect);
let actualHeight = getRectHeight(rect);
let style = getStyle(canvas);
let removePx = s => Js.String.slice(0, Js.String.length(s) - 2, s) |> float_of_string;
let width = style |> getWidthStyle |> removePx;
let height = style |> getHeightStyle |> removePx;
let state = Events.MouseDown;
let x = int_of_float((float_of_int(getClientX(e) - left)) *. (width /. actualWidth));
let y = int_of_float((float_of_int(getClientY(e) - top)) *. (width /. actualWidth));
Js.log3("Found", x, y);
cb(~button, ~state, ~x, ~y);
},
);
};
switch (mouseUp) {
| None => ()
| Some(cb) =>
Document.addEventListener(canvas, "touchend", e => {
let touches = getTouches(e, canvas);
Array.length(touches) > 0 ? {
preventDefault(e);
Array.iter(t => {
let (touchId, x, y) = t;
removeTouch(touchId);
cb(~button=Events.LeftButton, ~state=Events.MouseUp, ~x, ~y)}, touches);
} : ();
}
);
Document.addEventListener(canvas, "touchcancel", e => {
let touches = getTouches(e, canvas);
Array.length(touches) > 0 ? {
preventDefault(e);
Array.iter(t => {
let (touchId, x, y) = t;
removeTouch(touchId);
cb(~button=Events.LeftButton, ~state=Events.MouseUp, ~x, ~y)}, touches);
} : ();
}
);
Document.addEventListener(
canvas,
"mouseup",
e => {
let button =
switch (getButton(e)) {
| 0 => Events.LeftButton
| 1 => Events.MiddleButton
| 2 => Events.RightButton
| _ => assert false
};
let state = Events.MouseUp;
let rect = getBoundingClientRect(canvas);
let x = getClientX(e) - getLeft(rect);
let y = getClientY(e) - getTop(rect);
cb(~button, ~state, ~x, ~y);
},
);
};
switch (mouseMove) {
| None => ()
| Some(cb) =>
Document.addEventListener(canvas, "touchmove", e => {
preventDefault(e);
switch (getTouch0(e, canvas)) {
| Some((touchId, x, y)) => {
List.exists(id => id == touchId, touches^) ?
cb(~x, ~y): ();
}
| None => ()
};
}
);
Document.addEventListener(
canvas,
"mousemove",
e => {
let rect = getBoundingClientRect(canvas);
let x = getClientX(e) - getLeft(rect);
let y = getClientY(e) - getTop(rect);
cb(~x, ~y);
},
);
};
let keyLastPressed = ref([]);
switch (keyDown) {
| None => ()
| Some(cb) =>
Document.addEventListener(
Document.window, /* This is the real window. The "window" param is the canvas. */
"keydown",
e => {
let keycode = Int32.of_int(getWhich(e));
let repeat =
List.fold_left(
(acc, k) => acc || k === keycode,
false,
keyLastPressed^,
);
if (! repeat) {
keyLastPressed := [keycode, ...keyLastPressed^];
};
cb(~keycode=Events.keycodeMap(keycode), ~repeat);
},
)
};
switch (keyUp) {
| None => ()
| Some(cb) =>
Document.addEventListener(
Document.window,
"keyup",
e => {
let keycode = Int32.of_int(getWhich(e));
keyLastPressed := List.filter(k => k !== keycode, keyLastPressed^);
cb(~keycode=Events.keycodeMap(keycode));
},
)
};
switch (windowResize) {
| None => ()
| Some(cb) =>
Document.addEventListener(Document.window, "resize", (_) => cb())
};
let frame = ref(None);
let rec tick = (prev, ()) => {
let now = Document.now();
displayFunc(now -. prev);
let id = Document.requestAnimationFrame(tick(now));
frame := Some(id);
setHiddenRAFID(canvas, id);
};
let id = Document.requestAnimationFrame(tick(Document.now()));
frame := Some(id);
setHiddenRAFID(canvas, id);
play =>
switch (frame^) {
| None =>
if (play) {
let id = Document.requestAnimationFrame(tick(Document.now()));
frame := Some(id);
setHiddenRAFID(canvas, id);
true;
} else {
false;
}
| Some(id) =>
if (! play) {
Document.cancelAnimationFrame(id);
frame := None;
false;
} else {
true;
}
};
};
type programT;
type shaderT;
[@bs.send]
external clearColor :
(~context: contextT, ~r: float, ~g: float, ~b: float, ~a: float) => unit =
"clearColor";
[@bs.send]
external createProgram : (~context: contextT) => programT = "createProgram";
[@bs.send]
external createShader : (~context: contextT, int) => shaderT =
"createShader";
[@bs.send]
external _shaderSource :
(~context: contextT, ~shader: shaderT, ~source: string) => unit =
"shaderSource";
let shaderSource = (~context, ~shader, ~source) =>
_shaderSource(
~context,
~shader,
~source="#version 100 \n precision highp float; \n" ++ source,
);
[@bs.send]
external compileShader : (~context: contextT, shaderT) => unit =
"compileShader";
[@bs.send]
external attachShader :
(~context: contextT, ~program: programT, ~shader: shaderT) => unit =
"attachShader";
[@bs.send]
external deleteShader : (~context: contextT, shaderT) => unit =
"deleteShader";
[@bs.send]
external linkProgram : (~context: contextT, programT) => unit =
"linkProgram";
[@bs.send]
external useProgram : (~context: contextT, programT) => unit = "useProgram";
type bufferT;
type attributeT;
type uniformT;
[@bs.send]
external createBuffer : (~context: contextT) => bufferT = "createBuffer";
[@bs.send]
external bindBuffer :
(~context: contextT, ~target: int, ~buffer: bufferT) => unit =
"bindBuffer";
type textureT;
[@bs.send]
external createTexture : (~context: contextT) => textureT = "createTexture";
[@bs.send]
external activeTexture : (~context: contextT, int) => unit = "activeTexture";
[@bs.send]
external bindTexture :
(~context: contextT, ~target: int, ~texture: textureT) => unit =
"bindTexture";
[@bs.send]
external texParameteri :
(~context: contextT, ~target: int, ~pname: int, ~param: int) => unit =
"texParameteri";
type framebufferT;
[@bs.send]
external createFramebuffer : (~context: contextT) => framebufferT = "";
[@bs.send]
external bindFramebuffer :
(~context: contextT, ~target: int, ~framebuffer: framebufferT) => unit =
"";
[@bs.send]
external bindDefaultFramebuffer :
(~context: contextT, ~target: int, [@bs.as {json|null|json}] _) => unit =
"bindFramebuffer";
[@bs.send]
external framebufferTexture2D :
(
~context: contextT,
~target: int,
~attachment: int,
~texTarget: int,
~texture: textureT,
[@bs.as {json|0|json}] _
) =>
unit =
"";
[@bs.send] external enable : (~context: contextT, int) => unit = "enable";
[@bs.send] external disable : (~context: contextT, int) => unit = "disable";
[@bs.send]
external blendFunc : (~context: contextT, int, int) => unit = "blendFunc";
/*** Those externals are used for bufferData to instantiate what gl.bufferData actually expects, because JS
* doesn't differentiate between float and int but the GL backend needs to know the types precisely.
**/
[@bs.new]
external createFloat32ArrayOfArray : array(float) => 'flot32array =
"Float32Array";
[@bs.new]
external createFloat32Array : int => 'float32array = "Float32Array";
[@bs.new]
external createFloat64ArrayOfArray : array(float) => 'flot64array =
"Float64Array";
[@bs.new]
external createFloat64Array : int => 'float64array = "Float64Array";
[@bs.new]
external createIntArrayOfArray : array(int) => 'int32array = "Int32Array";
[@bs.new]
external createInt32ArrayOfArray : array(int32) => 'int32array =
"Int32Array";
[@bs.new] external createIntArray : int => 'int32array = "Int32Array";
[@bs.new] external createInt32Array : int => 'int32array = "Int32Array";
[@bs.new]
external createUint16ArrayOfArray : array(int) => 'uint16array =
"Uint16Array";
[@bs.new] external createUint16Array : int => 'uint16array = "Uint16Array";
[@bs.new]
external createInt16ArrayOfArray : array(int) => 'int16array = "Int16Array";
[@bs.new] external createInt16Array : int => 'int16array = "Int16Array";
[@bs.new]
external createUint8ArrayOfArray : array(int) => 'uint8array = "Uint8Array";
[@bs.new] external createUint8Array : int => 'uint8array = "Uint8Array";
[@bs.new]
external createInt8ArrayOfArray : array(int) => 'int8array = "Int8Array";
[@bs.new] external createInt8Array : int => 'int8array = "Int8Array";
[@bs.new]
external createCharArrayOfArray : array(char) => 'uint8array = "Uint8Array";
[@bs.send] external sub : ('a, int, int) => 'a = "subarray";
module type Bigarray = {
type t('a, 'b);
type float64_elt;
type float32_elt;
type int16_unsigned_elt;
type int16_signed_elt;
type int8_unsigned_elt;
type int8_signed_elt;
type int_elt;
type int32_elt;
type int64_elt;
type kind('a, 'b) =
| Float64: kind(float, float64_elt)
| Float32: kind(float, float32_elt)
| Int16: kind(int, int16_signed_elt)
| Uint16: kind(int, int16_unsigned_elt)
| Int8: kind(int, int8_signed_elt)
| Uint8: kind(int, int8_unsigned_elt)
| Char: kind(char, int8_unsigned_elt)
| Int: kind(int, int_elt)
| Int64: kind(int64, int64_elt)
| Int32: kind(int32, int32_elt);
let create: (kind('a, 'b), int) => t('a, 'b);
let of_array: (kind('a, 'b), array('a)) => t('a, 'b);
let dim: t('a, 'b) => int;
let blit: (t('a, 'b), t('a, 'b)) => unit;
let unsafe_blit:
(t('a, 'b), t('a, 'b), ~offset: int, ~numOfBytes: int) => unit;
let get: (t('a, 'b), int) => 'a;
let unsafe_get: (t('a, 'b), int) => 'a;
let set: (t('a, 'b), int, 'a) => unit;
let unsafe_set: (t('a, 'b), int, 'a) => unit;
let sub: (t('a, 'b), ~offset: int, ~len: int) => t('a, 'b);
};
module Bigarray = {
type t('a, 'b);
type float64_elt;
type float32_elt;
type int16_unsigned_elt;
type int16_signed_elt;
type int8_unsigned_elt;
type int8_signed_elt;
type int_elt;
type int32_elt;
type int64_elt;
type kind('a, 'b) =
| Float64: kind(float, float64_elt)
| Float32: kind(float, float32_elt)
| Int16: kind(int, int16_signed_elt)
| Uint16: kind(int, int16_unsigned_elt)
| Int8: kind(int, int8_signed_elt)
| Uint8: kind(int, int8_unsigned_elt)
| Char: kind(char, int8_unsigned_elt)
| Int: kind(int, int_elt)
| Int64: kind(int64, int64_elt)
| Int32: kind(int32, int32_elt);
let create = (type a, type b, kind: kind(a, b), size) : t(a, b) =>
switch (kind) {
| Float64 => createFloat64Array(size)
| Float32 => createFloat32Array(size)
| Int16 => createInt16Array(size)
| Uint16 => createUint16Array(size)
| Int8 => createInt8Array(size)
| Uint8 => createUint8Array(size)
| Char => createUint8Array(size)
| Int => createIntArray(size)
| Int32 => createInt32Array(size)
| Int64 => assert false
};
let of_array =
(type a, type b, kind: kind(a, b), arr: array(a))
: t(a, b) =>
switch (kind) {
| Float64 => createFloat64ArrayOfArray(arr)
| Float32 => createFloat32ArrayOfArray(arr)
| Int16 => createInt16ArrayOfArray(arr)
| Uint16 => createUint16ArrayOfArray(arr)
| Int8 => createInt8ArrayOfArray(arr)
| Uint8 => createUint8ArrayOfArray(arr)
| Char => createCharArrayOfArray(arr)
| Int => createIntArrayOfArray(arr)
| Int32 => createInt32ArrayOfArray(arr)
| Int64 => assert false
};
[@bs.get] external dim : 'a => int = "length";
[@bs.send] external blit : (t('a, 'b), t('a, 'b)) => unit = "set";
[@bs.send]
external unsafe_blit : (t('a, 'b), t('a, 'b), ~offset: int) => unit =
"set";
let unsafe_blit:
(t('a, 'b), t('a, 'b), ~offset: int, ~numOfBytes: int) => unit =
(arr, arr2, ~offset, ~numOfBytes as _) =>
unsafe_blit(arr2, arr, ~offset);
[@bs.get_index] external get : (t('a, 'b), int) => 'a = "";
[@bs.get_index] external unsafe_get : (t('a, 'b), int) => 'a = "";
[@bs.set_index] external set : (t('a, 'b), int, 'a) => unit = "";
[@bs.set_index] external unsafe_set : (t('a, 'b), int, 'a) => unit = "";
let sub = (arr, ~offset, ~len) => sub(arr, offset, offset + len);
};
[@bs.send]
external texSubImage2D :
(
~context: contextT,
~target: int,
~level: int,
~xoffset: int,
~yoffset: int,
~width: int,
~height: int,
~format: int,
~type_: int,
~pixels: Bigarray.t('a, 'b)
) =>
unit =
"texSubImage2D";
[@bs.send]
external readPixels :
(
~context: contextT,
~x: int,
~y: int,
~width: int,
~height: int,
~format: int,
~type_: int,
~pixels: Bigarray.t(int, Bigarray.int8_unsigned_elt)
) =>
unit =
"readPixels";
let readPixels_RGBA = (~context, ~x, ~y, ~width, ~height) => {
let data = createUint8Array(width * height * 4);
readPixels(
~context,
~x,
~y,
~width,
~height,
~format=RGLConstants.rgba,
~type_=RGLConstants.unsigned_byte,
~pixels=data,
);
data;
};
type imageT;
[@bs.get] external getImageWidth : imageT => int = "width";
[@bs.get] external getImageHeight : imageT => int = "height";
type loadOptionT =
| LoadAuto
| LoadL
| LoadLA
| LoadRGB
| LoadRGBA;
/*** makeImage, setSrc and addEventListener are three helpers for loadImage. */
[@bs.new] external makeImage : unit => imageT = "Image";
/* TODO: when the type of bs.set is `imageT => unit` you get something like
node_modules/reglweb/src/webgl.re:
Bsppx.Location.Error(_)
File "node_modules/reglweb/src/webgl.re", line 1:
Error: Error while running external preprocessor
Command line: bsppx.exe '/var/folders/g_/v45pqsrn65xbszd33yvd8lj40000gn/T/camlppx129341' '/var/folders/g_/v45pqsrn65xbszd33yvd8lj40000gn/T/camlppx438846'
This is due to the fact that bsppx expects 2 args, the "this" and the new value to set.
We should open an issue in Buckelscript.
*/
[@bs.set] external setSrc : (imageT, string) => unit = "src";
[@bs.send]
external addEventListener : (imageT, string, unit => unit) => unit =
"addEventListener";
[@bs.val] external btoa : string => string = "";
/*** TODO: We don't care about forcing load option for web images (we do allow it for native as SOIL supports
it). We should probably not do this... */
let loadImage = (~filename, ~loadOption=?, ~callback, ()) =>
switch (loadOption) {
| _ =>
let image = makeImage();
setSrc(image, filename);
addEventListener(image, "load", () => callback(Some(image)));
};
let loadImageFromMemory = (~data, ~loadOption=?, ~callback, ()) => {
let image = makeImage();
setSrc(image, "data:image/png;base64," ++ btoa(data));
addEventListener(image, "load", () => callback(Some(image)));
};
[@bs.send]
external _texImage2DWithImage :
(
~context: contextT,
~target: int,
~level: int,
~internalFormat: int,
~format: int,
~type_: int,
~image: imageT
) =>
unit =
"texImage2D";
let texImage2DWithImage = (~context, ~target, ~level, ~image) =>
_texImage2DWithImage(
~context,
~target,
~level,
~internalFormat=RGLConstants.rgba,
~format=RGLConstants.rgba,
~type_=RGLConstants.unsigned_byte,
~image,
);
[@bs.send]
external _texImage2D :
(
~context: contextT,
~target: int,
~level: int,
~internalFormat: int,
~width: int,
~height: int,
~border: int,
~format: int,
~type_: int,
~data: Bigarray.t('a, 'b)
) =>
unit =
"texImage2D";
let texImage2D_RGBA =
(~context, ~target, ~level, ~width, ~height, ~border, ~data) =>
_texImage2D(
~context,
~target,
~level,
~internalFormat=RGLConstants.rgba,
~width,
~height,
~border,
~format=RGLConstants.rgba,
~type_=RGLConstants.unsigned_byte,
~data,
);
let texImage2D_null = [%bs.raw
{| function(gl, target, level, width, height) {
gl.texImage2D(target, level, gl.RGBA, width, height, 0, gl.RGBA, gl.UNSIGNED_BYTE, null)
} |}
];
[@bs.send]
external vertexAttribDivisor :
(~context: contextT, ~attribute: attributeT, ~divisor: int) => unit =
"vertexAttribDivisor";
/*external generateMipmap : context::contextT => target::int => unit = "generateMipmap" [@@bs.send];*/
[@bs.send]
external bufferData :
(
~context: contextT,
~target: int,
~data: Bigarray.t('a, 'b),
~usage: int
) =>
unit =
"bufferData";
[@bs.send]
external viewport :
(~context: contextT, ~x: int, ~y: int, ~width: int, ~height: int) => unit =
"viewport";
[@bs.send]
external clear : (~context: contextT, ~mask: int) => unit = "clear";
[@bs.send]
external getUniformLocation :
(~context: contextT, ~program: programT, ~name: string) => uniformT =
"getUniformLocation";
[@bs.send]
external getAttribLocation :
(~context: contextT, ~program: programT, ~name: string) => attributeT =
"getAttribLocation";
[@bs.send]
external enableVertexAttribArray :
(~context: contextT, ~attribute: attributeT) => unit =
"enableVertexAttribArray";
[@bs.send]
external _vertexAttribPointer :
(
~context: contextT,
~attribute: attributeT,
~size: int,
~type_: int,
~normalize: bool,
~stride: int,
~offset: int
) =>
unit =
"vertexAttribPointer";
let vertexAttribPointer =
(~context, ~attribute, ~size, ~type_, ~normalize, ~stride, ~offset) => {
let normalize = if (normalize) {true} else {false};
_vertexAttribPointer(
~context,
~attribute,
~size,
~type_,
~normalize,
~stride,
~offset,
);
};
module type Mat4T = {
type t;
let to_array: t => array(float);
let create: unit => t;
let identity: (~out: t) => unit;
let translate: (~out: t, ~matrix: t, ~vec: array(float)) => unit;
let scale: (~out: t, ~matrix: t, ~vec: array(float)) => unit;
let rotate:
(~out: t, ~matrix: t, ~rad: float, ~vec: array(float)) => unit;
let ortho:
(
~out: t,
~left: float,
~right: float,
~bottom: float,
~top: float,
~near: float,
~far: float
) =>
unit;
let perspective:
(
~out: t,
~fovy: float,
~aspect: float,
~near: float,
~far: float,
) =>
unit;
let lookAt:
(
~out: t,
~eye: array(float),
~center: array(float),
~up: array(float),
) =>
unit;
};
module Mat4: Mat4T = {
type t = array(float);
let to_array = a => a;
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external create : unit => t = "";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external identity : (~out: t) => unit = "";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external translate : (~out: t, ~matrix: t, ~vec: array(float)) => unit =
"";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external scale : (~out: t, ~matrix: t, ~vec: array(float)) => unit = "";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external rotate :
(~out: t, ~matrix: t, ~rad: float, ~vec: array(float)) => unit =
"";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external ortho :
(
~out: t,
~left: float,
~right: float,
~bottom: float,
~top: float,
~near: float,
~far: float
) =>
unit =
"";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external perspective:
(
~out: t,
~fovy: float,
~aspect: float,
~near: float,
~far: float
) =>
unit =
"";
[@bs.scope "mat4"] [@bs.module "gl-matrix"]
external lookAt:
(
~out: t,
~eye: array(float),
~center: array(float),
~up: array(float),
) =>
unit =
"";
};
[@bs.send]
external uniform1i :
(~context: contextT, ~location: uniformT, ~value: int) => unit =
"uniform1i";
[@bs.send]
external uniform1f :
(~context: contextT, ~location: uniformT, ~value: float) => unit =
"uniform1f";
[@bs.send]
external uniform2f :
(~context: contextT, ~location: uniformT, ~v1: float, ~v2: float) => unit =
"uniform2f";
[@bs.send]
external uniform3f :
(
~context: contextT,
~location: uniformT,
~v1: float,
~v2: float,
~v3: float
) =>
unit =
"uniform3f";
[@bs.send]
external uniform4f :
(
~context: contextT,
~location: uniformT,
~v1: float,
~v2: float,
~v3: float,
~v4: float
) =>
unit =
"uniform4f";
[@bs.send]
external _uniformMatrix4fv :
(
~context: contextT,
~location: uniformT,
~transpose: bool,
~value: Mat4.t
) =>
unit =
"uniformMatrix4fv";
let uniformMatrix4fv = (~context, ~location, ~value) =>
_uniformMatrix4fv(~context, ~location, ~transpose=false, ~value);
/* Can return other value types as well, see https://developer.mozilla.org/en-US/docs/Web/API/WebGL_API/Types */
type shaderParamsInternalT('a) =
| Shader_delete_status_internal: shaderParamsInternalT(bool)
| Compile_status_internal: shaderParamsInternalT(bool)
| Shader_type_internal: shaderParamsInternalT(int);
type programParamsInternalT('a) =
| Program_delete_status_internal: programParamsInternalT(bool)
| Link_status_internal: programParamsInternalT(bool)
| Validate_status_internal: programParamsInternalT(bool);
/* | Attached_shaders_internal :programParamsInternalT int
| Active_attributes_internal :programParamsInternalT int
| Active_uniforms_internal :programParamsInternalT int */
type shaderParamsT =
| Shader_delete_status
| Compile_status
| Shader_type;
type programParamsT =
| Program_delete_status
| Link_status
| Validate_status;
/* | Attached_shaders
| Active_attributes
| Active_uniforms */
[@bs.get]
external deleteStatus : (~context: contextT) => int = "DELETE_STATUS";
[@bs.get]
external compileStatus : (~context: contextT) => int = "COMPILE_STATUS";
[@bs.get] external linkStatus : (~context: contextT) => int = "LINK_STATUS";
[@bs.get]
external validateStatus : (~context: contextT) => int = "VALIDATE_STATUS";
[@bs.get] external shaderType : (~context: contextT) => int = "SHADER_TYPE";
[@bs.send]
external _getProgramParameter :
(
~context: contextT,
~program: programT,
~paramName: int,
[@bs.ignore] programParamsInternalT('a)
) =>
'a =
"getProgramParameter";
let getProgramParameter = (~context, ~program, ~paramName) =>
switch (paramName) {
| Program_delete_status =>
if (_getProgramParameter(
~context,
~program,
~paramName=deleteStatus(~context),
Program_delete_status_internal,
)) {
1;
} else {
0;
}
| Link_status =>
if (_getProgramParameter(
~context,
~program,
~paramName=linkStatus(~context),
Link_status_internal,
)) {
1;
} else {
0;
}
| Validate_status =>
if (_getProgramParameter(
~context,
~program,
~paramName=validateStatus(~context),
Validate_status_internal,
)) {
1;
} else {
0;
}
};
[@bs.send]
external _getShaderParameter :
(
~context: contextT,
~shader: shaderT,
~paramName: int,
[@bs.ignore] shaderParamsInternalT('a)
) =>
'a =
"getShaderParameter";
let getShaderParameter = (~context, ~shader, ~paramName) =>
switch (paramName) {
| Shader_delete_status =>
if (_getShaderParameter(
~context,
~shader,
~paramName=deleteStatus(~context),
Shader_delete_status_internal,
)) {
1;
} else {
0;
}
| Compile_status =>
if (_getShaderParameter(
~context,
~shader,
~paramName=compileStatus(~context),
Compile_status_internal,
)) {
1;
} else {
0;
}
| Shader_type =>
_getShaderParameter(
~context,
~shader,
~paramName=shaderType(~context),
Shader_type_internal,
)
};
[@bs.send]
external getShaderInfoLog : (~context: contextT, shaderT) => string =
"getShaderInfoLog";
[@bs.send]
external getProgramInfoLog : (~context: contextT, programT) => string =
"getProgramInfoLog";
[@bs.send]
external getShaderSource : (~context: contextT, shaderT) => string =
"getShaderSource";
[@bs.send]
external drawArrays :
(~context: contextT, ~mode: int, ~first: int, ~count: int) => unit =
"drawArrays";
[@bs.send]
external drawElements :
(~context: contextT, ~mode: int, ~count: int, ~type_: int, ~offset: int) =>
unit =
"drawElements";
[@bs.send]
external drawElementsInstanced :
(
~context: contextT,
~mode: int,
~count: int,
~type_: int,
~indices: int,
~primcount: int
) =>
unit =
"drawElementsInstanced";
};
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment