humza/sml-projects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

init

Browse Source
This commit is contained in:
Humza Shahid
2024-07-28 14:22:17 +01:00
commit 319ba58b3e
17 changed files with 5124 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
LICENSE Normal file
View File

@@ -0,0 +1,5 @@
Copyright (C) 2024 by Humza Shahid <humzasaur@gmail.com>
Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

82
README.md Normal file
View File

@@ -0,0 +1,82 @@
# box-x-box
## What is this?
This is a broken attempt at changing [box-x-box-c-callback](https://github.com/hummy123/box-x-box-c-callback) to accept a callback from an exported SML function instead.
It's broken because (at least on aarch64-linux) there is a segfault when trying to press a keyboard key (to trigger the key callback) when the window is focused.
## Building
Building the program and running it is exactly the same as it is for the C counterpart of this repository.
## How the callback is set in code
There are two files again, `ffi/glfw-key-input.c` and `ffi/glfw-key-input.sml` (which each have different contents from the C counterpart of this repository).
`ffi/glfw-key-input.c` has two functions:
- One callback function that does nothing but call a print function exported from SML
- One other function which, when called, will register the callback with GLFW
`ffi/glfw-key-input.sml` has two parts as well:
- Lines 5 - 6 define a function that is exported to C
- Line 9 imports a C function which calls the exported SML function (and this has the `reentrant` attribute).
The callback is registered with GLFW at runtime at line 32 of `imperative-shell/shell.sml`.
## Trying to narrow down the issue
### Don't register the callback
Deleting line 32 of `imperative-shell/shell.sml` will stop the program from giving a segfault but we obviously lose functionality that way.
This is mentioned because I think the issue is something to do with how the callback is set.
A (mostly) uninformed guess: The `reentrant` attribute for importing functions is meant to be used for importing C functions that call SML functions.
This is different from how GLFW works, which triggers the callback registered with it without MLton knowing.
(If this is the case, why does [simple-mlton-glfw-callback](https://github.com/hummy123/simple-mlton-glfw-callback) work?)
### Remove code dealing with vectors
Separately from removing the registration of the callback, we can make small edits to `functional-core/game-update.sml` and `imperative-shell/game-draw.sml` to avoid the segfault issue. (Both of these edits must be made together.)
#### Editing game-update.sml
In lines 269-270 of `functional-core/game-update.sml`, there's a call to a pure function which recreates a `block vector vector` type.
This function checks if a box/ball collides with any of the blocks.
If a collision occurs, both the block and the colliding ball are recreated with different values.
If no collision occurs, the block and the ball keep the same value they had before (but the vector is still recreated).
We can delete these lines. Together with the one small edit to game-draw.sml described below, the segfault will stop occurring.
#### Editing game-draw.sml
In line 57 of `imperative-shell/game-draw.sml`, there is this line of code:
`val {lightBlocks, darkBlocks} = drawBlocksLine (#blocks game)`
To make the seg fault go away, we can delete this line and replace it with:
```
val lightBlocks = []
val darkBlocks = []
```
With this change and the one to `functional-core/game-update.sml` described above, we can rebuild the program with `./build-unix.sh` and run it with `./box-x-box`. The key callback will work fine now.
What the `drawBlocksLine` function does is, it traverses the `block vector vector` (which was causing issues in game-update.sml), and it creates a `Real32.real vector list` from them (one being `darkBlocks` and the other being `lightBlocks`). The results are later sent to OpenGL.
Note that the `drawBlocksLine` function is pure. It returns a `Real32.real vector list` and does no drawing/side-effecting/mutating on its own (making the name a misnomer).
---
Removing the code dealing with vectors is quite a strange solution.
The two functions, `drawBlocksLine` in game-draw.sml and `updateBlocks` ins game-update.sml, are both pure and I can't think of why they would be connected with the key callback/a segfault.
The C counterpart of this repository has both of those functions in place (unmodified) which leads me to guEss the error isn't in these functions themselves.

8
build-unix.sh Executable file
View File

@@ -0,0 +1,8 @@
#!/bin/sh
mlton -link-opt "$(pkg-config --cflags glfw3) $(pkg-config --static --libs glfw3)" \
-export-header ffi/export.h \
dot-to-dot.mlb \
ffi/glad.c \
ffi/glfw-export.c \
ffi/gles3-export.c \
ffi/glfw-key-input.c

BIN
dot-to-dot Executable file
View File

Binary file not shown.

15
dot-to-dot.mlb Normal file
View File

@@ -0,0 +1,15 @@
$(SML_LIB)/basis/mlton.mlb
$(SML_LIB)/basis/basis.mlb
$(SML_LIB)/cml/cml.mlb
ann
"allowFFI true"
in
ffi/gles3-import.sml
ffi/glfw-import.sml
ffi/glfw-key-input.sml
end
imperative-shell/constants.sml
imperative-shell/shell.sml

169
ffi/export.h Normal file
View File

@@ -0,0 +1,169 @@
#ifndef __DOT_TO_DOT_ML_H__
#define __DOT_TO_DOT_ML_H__
/* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a HPND-style license.
* See the file MLton-LICENSE for details.
*/
#ifndef _MLTON_MLTYPES_H_
#define _MLTON_MLTYPES_H_
/* We need these because in header files for exported SML functions,
* types.h is included without cenv.h.
*/
#if (defined (_AIX) || defined (__hpux__) || defined (__OpenBSD__))
#include <inttypes.h>
#elif (defined (__sun__))
#include <sys/int_types.h>
#else
#include <stdint.h>
#endif
/* ML types */
typedef unsigned char PointerAux __attribute__ ((may_alias));
typedef PointerAux* Pointer;
#define Array(t) Pointer
#define Ref(t) Pointer
#define Vector(t) Pointer
typedef int8_t Int8_t;
typedef int8_t Int8;
typedef int16_t Int16_t;
typedef int16_t Int16;
typedef int32_t Int32_t;
typedef int32_t Int32;
typedef int64_t Int64_t;
typedef int64_t Int64;
typedef float Real32_t;
typedef float Real32;
typedef double Real64_t;
typedef double Real64;
typedef uint8_t Word8_t;
typedef uint8_t Word8;
typedef uint16_t Word16_t;
typedef uint16_t Word16;
typedef uint32_t Word32_t;
typedef uint32_t Word32;
typedef uint64_t Word64_t;
typedef uint64_t Word64;
typedef Int8_t WordS8_t;
typedef Int8_t WordS8;
typedef Int16_t WordS16_t;
typedef Int16_t WordS16;
typedef Int32_t WordS32_t;
typedef Int32_t WordS32;
typedef Int64_t WordS64_t;
typedef Int64_t WordS64;
typedef Word8_t WordU8_t;
typedef Word8_t WordU8;
typedef Word16_t WordU16_t;
typedef Word16_t WordU16;
typedef Word32_t WordU32_t;
typedef Word32_t WordU32;
typedef Word64_t WordU64_t;
typedef Word64_t WordU64;
typedef WordU8_t Char8_t;
typedef WordU8_t Char8;
typedef WordU16_t Char16_t;
typedef WordU16_t Char16;
typedef WordU32_t Char32_t;
typedef WordU32_t Char32;
typedef Vector(Char8_t) String8_t;
typedef Vector(Char8_t) String8;
typedef Vector(Char16_t) String16_t;
typedef Vector(Char16_t) String16;
typedef Vector(Char32_t) String32_t;
typedef Vector(Char32_t) String32;
typedef Int32_t Bool_t;
typedef Int32_t Bool;
typedef String8_t NullString8_t;
typedef String8_t NullString8;
typedef void* CPointer;
typedef Pointer Objptr;
#endif /* _MLTON_MLTYPES_H_ */
/* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a HPND-style license.
* See the file MLton-LICENSE for details.
*/
#ifndef _MLTON_EXPORT_H_
#define _MLTON_EXPORT_H_
/* ------------------------------------------------- */
/* Symbols */
/* ------------------------------------------------- */
/* An external symbol is something not defined by the module
* (executable or library) being built. Rather, it is provided
* from a library dependency (dll, dylib, or shared object).
*
* A public symbol is defined in this module as being available
* to users outside of this module. If building a library, this
* means the symbol will be part of the public interface.
*
* A private symbol is defined within this module, but will not
* be made available outside of it. This is typically used for
* internal implementation details that should not be accessible.
*/
#if defined(_WIN32) || defined(_WIN64) || defined(__CYGWIN__)
#define EXTERNAL __declspec(dllimport)
#define PUBLIC __declspec(dllexport)
#define PRIVATE
#else
#define EXTERNAL __attribute__((visibility("default")))
#define PUBLIC __attribute__((visibility("default")))
#define PRIVATE __attribute__((visibility("hidden")))
#endif
#endif /* _MLTON_EXPORT_H_ */
#if !defined(PART_OF_DOT_TO_DOT) && \
!defined(STATIC_LINK_DOT_TO_DOT) && \
!defined(DYNAMIC_LINK_DOT_TO_DOT)
#define PART_OF_DOT_TO_DOT
#endif
#if defined(PART_OF_DOT_TO_DOT)
#define MLLIB_PRIVATE(x) PRIVATE x
#define MLLIB_PUBLIC(x) PUBLIC x
#elif defined(STATIC_LINK_DOT_TO_DOT)
#define MLLIB_PRIVATE(x)
#define MLLIB_PUBLIC(x) PUBLIC x
#elif defined(DYNAMIC_LINK_DOT_TO_DOT)
#define MLLIB_PRIVATE(x)
#define MLLIB_PUBLIC(x) EXTERNAL x
#else
#error Must specify linkage for dot_to_dot
#define MLLIB_PRIVATE(x)
#define MLLIB_PUBLIC(x)
#endif
#ifdef __cplusplus
extern "C" {
#endif
MLLIB_PUBLIC(void printFromMLton (Int32 x0, Int32 x1, Int32 x2, Int32 x3);)
#undef MLLIB_PRIVATE
#undef MLLIB_PUBLIC
#ifdef __cplusplus
}
#endif
#endif /* __DOT_TO_DOT_ML_H__ */

1463
ffi/glad.c Normal file
View File

File diff suppressed because it is too large Load Diff

2749
ffi/glad.h Normal file
View File

File diff suppressed because it is too large Load Diff

99
ffi/gles3-export.c Normal file
View File

@@ -0,0 +1,99 @@
#include "export.h"
#include "glad.h"
#include <GLFW/glfw3.h>
#include <stdbool.h>
// OpenGL constants used below
unsigned int VERTEX_SHADER = GL_VERTEX_SHADER;
unsigned int FRAGMENT_SHADER = GL_FRAGMENT_SHADER;
unsigned int TRIANGLES = GL_TRIANGLES;
unsigned int TRIANGLE_FAN = GL_TRIANGLE_FAN;
unsigned int STATIC_DRAW = GL_STATIC_DRAW;
unsigned int DYNAMIC_DRAW = GL_DYNAMIC_DRAW;
// OpenGL functions used below
void loadGlad() {
gladLoadGLLoader((GLADloadproc)glfwGetProcAddress);
}
void viewport(int width, int height) {
glViewport(0, 0, width, height);
}
void clearColor(float r, float g, float b, float a) {
glClearColor(r, g, b, a);
}
void clear() {
glClear(GL_COLOR_BUFFER_BIT);
}
unsigned int createBuffer() {
unsigned int buffer;
glGenBuffers(1, &buffer);
return buffer;
}
void bindBuffer(unsigned int buffer) {
glBindBuffer(GL_ARRAY_BUFFER, buffer);
}
void bufferData(float* vector, int vectorLength, unsigned int updateMode) {
glBufferData(GL_ARRAY_BUFFER, sizeof(float) * vectorLength, vector, updateMode);
}
unsigned int createShader(unsigned int shaderType) {
return glCreateShader(shaderType);
}
void shaderSource(unsigned int shader, const char *sourceString) {
glShaderSource(shader, 1, &sourceString, NULL);
}
void compileShader(unsigned int shader) {
glCompileShader(shader);
}
void deleteShader(unsigned int shader) {
glDeleteShader(shader);
}
void vertexAttribPointer(int location, int numVecComponents) {
glVertexAttribPointer(location, numVecComponents, GL_FLOAT, GL_FALSE, numVecComponents * sizeof(float), (void*) 0);
}
void enableVertexAttribArray(int location) {
glEnableVertexAttribArray(location);
}
unsigned int createProgram() {
return glCreateProgram();
}
void attachShader(unsigned int program, unsigned int shader) {
glAttachShader(program, shader);
}
void linkProgram(unsigned int program) {
glLinkProgram(program);
}
void useProgram(unsigned int program) {
glUseProgram(program);
}
void deleteProgram(unsigned int program) {
glDeleteProgram(program);
}
void drawArrays(unsigned int drawMode, int startIndex, int numVertices) {
glDrawArrays(drawMode, startIndex, numVertices);
}
int getUniformLocation(unsigned int program, const char *uniformName) {
glGetUniformLocation(program, uniformName);
}
void uniform4f(int uniformLocation, float a, float b, float c, float d) {
glUniform4f(uniformLocation, a, b, c, d);
}

58
ffi/gles3-import.sml Normal file
View File

@@ -0,0 +1,58 @@
structure Gles3 =
struct
type buffer = Word32.word
type shader_type = Word32.word
type shader = Word32.word
type program = Word32.word
type draw_mode = Word32.word
type update_mode = Word32.word
(* OpenGL constants used. *)
val (VERTEX_SHADER, _) =
_symbol "VERTEX_SHADER" public : ( unit -> shader_type ) * ( shader_type -> unit );
val (FRAGMENT_SHADER, _) =
_symbol "FRAGMENT_SHADER" public : ( unit -> shader_type ) * ( shader_type -> unit );
val (TRIANGLES, _) =
_symbol "TRIANGLES" public : ( unit -> draw_mode ) * ( draw_mode -> unit );
val (TRIANGLE_FAN, _) =
_symbol "TRIANGLE_FAN" public : ( unit -> draw_mode ) * ( draw_mode -> unit );
val (STATIC_DRAW, _) =
_symbol "STATIC_DRAW" public : ( unit -> update_mode ) * ( update_mode -> unit );
val (DYNAMIC_DRAW, _) =
_symbol "DYNAMIC_DRAW" public : ( unit -> update_mode ) * ( update_mode -> unit );
(* OpenGL functions used. *)
val loadGlad = _import "loadGlad" public : unit -> unit;
val viewport = _import "viewport" public : int * int -> unit;
val createBuffer = _import "createBuffer" public : unit -> buffer;
val bindBuffer = _import "bindBuffer" public : buffer -> unit;
val bufferData =
_import "bufferData" public : Real32.real vector * int * update_mode -> unit;
val createShader = _import "createShader" public : shader_type -> shader;
val compileShader = _import "compileShader" public : shader -> unit;
val deleteShader = _import "deleteShader" public : shader -> unit;
val shaderSource = _import "shaderSource" public : shader * string -> unit;
val vertexAttribPointer =
_import "vertexAttribPointer" public : int * int -> unit;
val enableVertexAttribArray =
_import "enableVertexAttribArray" public : int -> unit;
val createProgram = _import "createProgram" public : unit -> program;
val attachShader = _import "attachShader" public : program * shader -> unit;
val linkProgram = _import "linkProgram" public : program -> unit;
val useProgram = _import "useProgram" public : program -> unit;
val deleteProgram = _import "deleteProgram" public : program -> unit;
val clearColor =
_import "clearColor" public : Real32.real * Real32.real * Real32.real * Real32.real -> unit;
val clear = _import "clear" public : unit -> unit;
val drawArrays = _import "drawArrays" public : draw_mode * int * int -> unit;
val getUniformLocation =
_import "getUniformLocation" public : program * string -> int;
val uniform4f =
_import "uniform4f" public : int * Real32.real * Real32.real * Real32.real * Real32.real -> unit;
end

43
ffi/glfw-export.c Normal file
View File

@@ -0,0 +1,43 @@
#include "export.h"
#include <GLFW/glfw3.h>
#include <stdbool.h>
// GLFW constants used below
int CONTEXT_VERSION_MAJOR = GLFW_CONTEXT_VERSION_MAJOR;
int DEPRECATED = GLFW_DECORATED;
int GLFW_FFI_FALSE = GLFW_FALSE;
int SAMPLES = GLFW_SAMPLES;
// GLFW functions used below
void init() {
glfwInit();
}
void windowHint(int hint, int value) {
glfwWindowHint(hint, value);
}
GLFWwindow* createWindow(int width, int height, const char *title) {
return glfwCreateWindow(width, height, title, NULL, NULL);
}
void terminate() {
glfwTerminate();
}
void makeContextCurrent(GLFWwindow* window) {
glfwMakeContextCurrent(window);
}
bool windowShouldClose(GLFWwindow *window) {
glfwWindowShouldClose(window);
}
void pollEvents() {
glfwPollEvents();
}
void swapBuffers(GLFWwindow *window) {
glfwSwapBuffers(window);
}

25
ffi/glfw-import.sml Normal file
View File

@@ -0,0 +1,25 @@
structure Glfw =
struct
type window = MLton.Pointer.t
(* Window hint constants. *)
val (CONTEXT_VERSION_MAJOR, _) =
_symbol "CONTEXT_VERSION_MAJOR" public : ( unit -> int ) * ( int -> unit );
val (DEPRECATED, _) =
_symbol "DEPRECATED" public : ( unit -> int ) * ( int -> unit );
val (FALSE, _) =
_symbol "GLFW_FFI_FALSE" public : ( unit -> int ) * ( int -> unit );
val (SAMPLES, _) =
_symbol "SAMPLES" public : ( unit -> int ) * ( int -> unit );
(* GLFW functions. *)
val init = _import "init" public : unit -> unit;
val windowHint = _import "windowHint" public : int * int -> unit;
val createWindow =
_import "createWindow" public : int * int * string -> window;
val terminate = _import "terminate" public : unit -> unit;
val makeContextCurrent = _import "makeContextCurrent" public : window -> unit;
val windowShouldClose = _import "windowShouldClose" public : window -> bool;
val pollEvents = _import "pollEvents" public reentrant : unit -> unit;
val swapBuffers = _import "swapBuffers" public : window -> unit;
end

14
ffi/glfw-key-input.c Normal file
View File

@@ -0,0 +1,14 @@
#include "export.h"
#include <GLFW/glfw3.h>
#include <stdbool.h>
// Calls function exported from SML
void keyCallback(GLFWwindow *window, int key, int scancode, int action, int mods) {
printFromMLton(key, scancode, action, mods);
}
// Call this from MLton to register key callback with GLFW.
void setKeyCallback(GLFWwindow *window) {
glfwSetKeyCallback(window, keyCallback);
}

11
ffi/glfw-key-input.sml Normal file
View File

@@ -0,0 +1,11 @@
structure Key =
struct
type window = MLton.Pointer.t
(* Export function to C. *)
val export =
_export "printFromMLton" public : (int * int * int * int -> unit) -> unit;
(* Import function to set callback for GLFW. *)
val setCallback = _import "setKeyCallback" public reentrant : window -> unit;
end

282
ffi/khrplatform.h Normal file
View File

@@ -0,0 +1,282 @@
#ifndef __khrplatform_h_
#define __khrplatform_h_
/*
** Copyright (c) 2008-2018 The Khronos Group Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and/or associated documentation files (the
** "Materials"), to deal in the Materials without restriction, including
** without limitation the rights to use, copy, modify, merge, publish,
** distribute, sublicense, and/or sell copies of the Materials, and to
** permit persons to whom the Materials are furnished to do so, subject to
** the following conditions:
**
** The above copyright notice and this permission notice shall be included
** in all copies or substantial portions of the Materials.
**
** THE MATERIALS ARE PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
** EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
** IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
** CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
** TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
** MATERIALS OR THE USE OR OTHER DEALINGS IN THE MATERIALS.
*/
/* Khronos platform-specific types and definitions.
*
* The master copy of khrplatform.h is maintained in the Khronos EGL
* Registry repository at https://github.com/KhronosGroup/EGL-Registry
* The last semantic modification to khrplatform.h was at commit ID:
* 67a3e0864c2d75ea5287b9f3d2eb74a745936692
*
* Adopters may modify this file to suit their platform. Adopters are
* encouraged to submit platform specific modifications to the Khronos
* group so that they can be included in future versions of this file.
* Please submit changes by filing pull requests or issues on
* the EGL Registry repository linked above.
*
*
* See the Implementer's Guidelines for information about where this file
* should be located on your system and for more details of its use:
* http://www.khronos.org/registry/implementers_guide.pdf
*
* This file should be included as
* #include <KHR/khrplatform.h>
* by Khronos client API header files that use its types and defines.
*
* The types in khrplatform.h should only be used to define API-specific types.
*
* Types defined in khrplatform.h:
* khronos_int8_t signed 8 bit
* khronos_uint8_t unsigned 8 bit
* khronos_int16_t signed 16 bit
* khronos_uint16_t unsigned 16 bit
* khronos_int32_t signed 32 bit
* khronos_uint32_t unsigned 32 bit
* khronos_int64_t signed 64 bit
* khronos_uint64_t unsigned 64 bit
* khronos_intptr_t signed same number of bits as a pointer
* khronos_uintptr_t unsigned same number of bits as a pointer
* khronos_ssize_t signed size
* khronos_usize_t unsigned size
* khronos_float_t signed 32 bit floating point
* khronos_time_ns_t unsigned 64 bit time in nanoseconds
* khronos_utime_nanoseconds_t unsigned time interval or absolute time in
* nanoseconds
* khronos_stime_nanoseconds_t signed time interval in nanoseconds
* khronos_boolean_enum_t enumerated boolean type. This should
* only be used as a base type when a client API's boolean type is
* an enum. Client APIs which use an integer or other type for
* booleans cannot use this as the base type for their boolean.
*
* Tokens defined in khrplatform.h:
*
* KHRONOS_FALSE, KHRONOS_TRUE Enumerated boolean false/true values.
*
* KHRONOS_SUPPORT_INT64 is 1 if 64 bit integers are supported; otherwise 0.
* KHRONOS_SUPPORT_FLOAT is 1 if floats are supported; otherwise 0.
*
* Calling convention macros defined in this file:
* KHRONOS_APICALL
* KHRONOS_APIENTRY
* KHRONOS_APIATTRIBUTES
*
* These may be used in function prototypes as:
*
* KHRONOS_APICALL void KHRONOS_APIENTRY funcname(
* int arg1,
* int arg2) KHRONOS_APIATTRIBUTES;
*/
/*-------------------------------------------------------------------------
* Definition of KHRONOS_APICALL
*-------------------------------------------------------------------------
* This precedes the return type of the function in the function prototype.
*/
#if defined(_WIN32) && !defined(__SCITECH_SNAP__)
# define KHRONOS_APICALL __declspec(dllimport)
#elif defined (__SYMBIAN32__)
# define KHRONOS_APICALL IMPORT_C
#elif defined(__ANDROID__)
# define KHRONOS_APICALL __attribute__((visibility("default")))
#else
# define KHRONOS_APICALL
#endif
/*-------------------------------------------------------------------------
* Definition of KHRONOS_APIENTRY
*-------------------------------------------------------------------------
* This follows the return type of the function and precedes the function
* name in the function prototype.
*/
#if defined(_WIN32) && !defined(_WIN32_WCE) && !defined(__SCITECH_SNAP__)
/* Win32 but not WinCE */
# define KHRONOS_APIENTRY __stdcall
#else
# define KHRONOS_APIENTRY
#endif
/*-------------------------------------------------------------------------
* Definition of KHRONOS_APIATTRIBUTES
*-------------------------------------------------------------------------
* This follows the closing parenthesis of the function prototype arguments.
*/
#if defined (__ARMCC_2__)
#define KHRONOS_APIATTRIBUTES __softfp
#else
#define KHRONOS_APIATTRIBUTES
#endif
/*-------------------------------------------------------------------------
* basic type definitions
*-----------------------------------------------------------------------*/
#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__GNUC__) || defined(__SCO__) || defined(__USLC__)
/*
* Using <stdint.h>
*/
#include <stdint.h>
typedef int32_t khronos_int32_t;
typedef uint32_t khronos_uint32_t;
typedef int64_t khronos_int64_t;
typedef uint64_t khronos_uint64_t;
#define KHRONOS_SUPPORT_INT64 1
#define KHRONOS_SUPPORT_FLOAT 1
#elif defined(__VMS ) || defined(__sgi)
/*
* Using <inttypes.h>
*/
#include <inttypes.h>
typedef int32_t khronos_int32_t;
typedef uint32_t khronos_uint32_t;
typedef int64_t khronos_int64_t;
typedef uint64_t khronos_uint64_t;
#define KHRONOS_SUPPORT_INT64 1
#define KHRONOS_SUPPORT_FLOAT 1
#elif defined(_WIN32) && !defined(__SCITECH_SNAP__)
/*
* Win32
*/
typedef __int32 khronos_int32_t;
typedef unsigned __int32 khronos_uint32_t;
typedef __int64 khronos_int64_t;
typedef unsigned __int64 khronos_uint64_t;
#define KHRONOS_SUPPORT_INT64 1
#define KHRONOS_SUPPORT_FLOAT 1
#elif defined(__sun__) || defined(__digital__)
/*
* Sun or Digital
*/
typedef int khronos_int32_t;
typedef unsigned int khronos_uint32_t;
#if defined(__arch64__) || defined(_LP64)
typedef long int khronos_int64_t;
typedef unsigned long int khronos_uint64_t;
#else
typedef long long int khronos_int64_t;
typedef unsigned long long int khronos_uint64_t;
#endif /* __arch64__ */
#define KHRONOS_SUPPORT_INT64 1
#define KHRONOS_SUPPORT_FLOAT 1
#elif 0
/*
* Hypothetical platform with no float or int64 support
*/
typedef int khronos_int32_t;
typedef unsigned int khronos_uint32_t;
#define KHRONOS_SUPPORT_INT64 0
#define KHRONOS_SUPPORT_FLOAT 0
#else
/*
* Generic fallback
*/
#include <stdint.h>
typedef int32_t khronos_int32_t;
typedef uint32_t khronos_uint32_t;
typedef int64_t khronos_int64_t;
typedef uint64_t khronos_uint64_t;
#define KHRONOS_SUPPORT_INT64 1
#define KHRONOS_SUPPORT_FLOAT 1
#endif
/*
* Types that are (so far) the same on all platforms
*/
typedef signed char khronos_int8_t;
typedef unsigned char khronos_uint8_t;
typedef signed short int khronos_int16_t;
typedef unsigned short int khronos_uint16_t;
/*
* Types that differ between LLP64 and LP64 architectures - in LLP64,
* pointers are 64 bits, but 'long' is still 32 bits. Win64 appears
* to be the only LLP64 architecture in current use.
*/
#ifdef _WIN64
typedef signed long long int khronos_intptr_t;
typedef unsigned long long int khronos_uintptr_t;
typedef signed long long int khronos_ssize_t;
typedef unsigned long long int khronos_usize_t;
#else
typedef signed long int khronos_intptr_t;
typedef unsigned long int khronos_uintptr_t;
typedef signed long int khronos_ssize_t;
typedef unsigned long int khronos_usize_t;
#endif
#if KHRONOS_SUPPORT_FLOAT
/*
* Float type
*/
typedef float khronos_float_t;
#endif
#if KHRONOS_SUPPORT_INT64
/* Time types
*
* These types can be used to represent a time interval in nanoseconds or
* an absolute Unadjusted System Time. Unadjusted System Time is the number
* of nanoseconds since some arbitrary system event (e.g. since the last
* time the system booted). The Unadjusted System Time is an unsigned
* 64 bit value that wraps back to 0 every 584 years. Time intervals
* may be either signed or unsigned.
*/
typedef khronos_uint64_t khronos_utime_nanoseconds_t;
typedef khronos_int64_t khronos_stime_nanoseconds_t;
#endif
/*
* Dummy value used to pad enum types to 32 bits.
*/
#ifndef KHRONOS_MAX_ENUM
#define KHRONOS_MAX_ENUM 0x7FFFFFFF
#endif
/*
* Enumerated boolean type
*
* Values other than zero should be considered to be true. Therefore
* comparisons should not be made against KHRONOS_TRUE.
*/
typedef enum {
KHRONOS_FALSE = 0,
KHRONOS_TRUE = 1,
KHRONOS_BOOLEAN_ENUM_FORCE_SIZE = KHRONOS_MAX_ENUM
} khronos_boolean_enum_t;
#endif /* __khrplatform_h_ */

28
imperative-shell/constants.sml Normal file
View File

@@ -0,0 +1,28 @@
structure Constants =
struct
val boxVertexShaderString =
"#version 300 es\n\
\layout (location = 0) in vec2 apos;\n\
\void main()\n\
\{\n\
\ gl_Position = vec4(apos.x, apos.y, 0.0f, 1.0f);\n\
\}"
val boxFragmentShaderString =
"#version 300 es\n\
\precision mediump float;\n\
\out vec4 FragColor;\n\
\uniform vec4 col;\n\
\void main()\n\
\{\n\
\ FragColor = col;\n\
\}";
val initialDr: Real32.real = 217.0 / 255.0
val initialDg: Real32.real = 233.0 / 255.0
val initialDb: Real32.real = 227.0 / 255.0
val initialNr: Real32.real = 17.0 / 255.0
val initialNg: Real32.real = 77.0 / 255.0
val initialNb: Real32.real = 91.0 / 255.0
end

73
imperative-shell/shell.sml Normal file
View File

@@ -0,0 +1,73 @@
structure Shell =
struct
open CML
datatype msg = KEY of int * int * int * int
fun keyCallback mailbox (key, scancode, action, mode) =
(print "hello\n";
Mailbox.send (mailbox, (KEY (key, scancode, action, mode))))
fun callbackListener mailbox =
let
val _ =
case Mailbox.recv mailbox of
KEY (key, scancode, action, mode) =>
print (String.concat
[ "key: "
, Int.toString key
, " scancode: "
, Int.toString scancode
, " action: "
, Int.toString action
, " mode: "
, Int.toString mode
, "\n"
])
in
callbackListener mailbox
end
fun loop (window) =
if not (Glfw.windowShouldClose window) then
let
val _ = Gles3.clearColor (0.1, 0.1, 0.1, 0.1)
val _ = Gles3.clear ()
val _ = Glfw.pollEvents ()
val _ = Glfw.swapBuffers window
in
loop (window)
end
else
Glfw.terminate ()
fun main () =
let
(* Set up GLFW. *)
val _ = Glfw.init ()
val _ = Glfw.windowHint (Glfw.CONTEXT_VERSION_MAJOR (), 3)
val _ = Glfw.windowHint (Glfw.DEPRECATED (), Glfw.FALSE ())
val _ = Glfw.windowHint (Glfw.SAMPLES (), 4)
val window = Glfw.createWindow (500, 500, "MLton - box x box")
val _ = Glfw.makeContextCurrent window
val _ = Gles3.loadGlad ()
val inputMailbox = Mailbox.mailbox ()
(* Set callback sender *)
val _ = CML.spawn (fn () =>
let
val kbCallback = keyCallback inputMailbox
val _ = Key.export kbCallback
val _ = Key.setCallback window
in
()
end)
(* Set callback listener *)
val _ = CML.spawn (fn () => callbackListener inputMailbox)
in
loop (window)
end
end
val _ = RunCML.doit (Shell.main, NONE)