[m-rev.] for review: GLUT binding for Mercury
Julien Fischer
juliensf at cs.mu.OZ.AU
Mon May 3 15:18:49 AEST 2004
The is a (partial) Mercury binding for the GL utility toolkit (GLUT).
(see www.opengl.org/resources/libraries/glut.html for more information).
This provides an alternative to togl (the tk widget we are currently
using to write OpenGL programs in Mercury). GLUT is also the library
used by a number of books on OpenGL, notably the OpenGL Programming
Guide.
I'm intending to add this to extras/graphics/glut once I've added
some more documentation, fixed up the Mmakefile and cleaned up
some of the samples. (I'll post those as a separate diff).
TODO:
- support for multiple windows
- fonts
- pop-up menus
- game mode
Julien.
%-----------------------------------------------------------------------------%
%
% file: mercury_glut.m
% author: juliensf
%
%-----------------------------------------------------------------------------%
:- module mercury_glut.
:- interface.
:- import_module glut.
%-----------------------------------------------------------------------------%
:- end_module mercury_glut.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% file: glut.m
% author: juliensf
%
% This is partial Mercury binding to the GL Utility Library (GLUT).
%
%-----------------------------------------------------------------------------%
:- module glut.
:- interface.
:- include_module callback.
:- include_module color_map.
:- include_module model.
:- include_module overlay.
:- include_module window.
:- import_module glut.window.
:- import_module bool, char, float, int, io, list, string, std_util.
%-----------------------------------------------------------------------------%
%
% Initialisation.
%
% Initialise the GLUT library.
% You must call this before calling any other GLUT procedures.
% The program will abort if there is an error.
%
:- pred glut.init(io::di, io::uo) is det.
:- type display_mode
---> rgba
; index
; single
; double
; accum
; alpha
; depth
; stencil
; multisample
; stereo
; luminance.
% Set the initial display mode.
% (See the glutInit() man page for the way that this works)
%
:- pred glut.init_display_mode(list(display_mode)::in, io::di, io::uo) is det.
% Set the initial display mode via a string.
% (See man glutInitDisplayString for details).
%
:- pred glut.init_display_string(string::in, io::di, io::uo) is det.
% glut.init_window_position(X, Y, !IO).
% Set the initial window position. `X' and `Y' are the window
% location in pixels.
%
:- pred glut.init_window_position(int::in, int::in, io::di, io::uo) is det.
% glut.init_window_size(Width, Height, !IO).
% Set the initial window size. `Width' and `Height' are the window
% dimensions in pixels.
%
:- pred glut.init_window_size(int::in, int::in, io::di, io::uo) is det.
% Enter the GLUT event processing loop.
% You need to use glut.quit/2 to get out of this.
%
:- pred glut.main_loop(io::di, io::uo) is det.
% Notify GLUT that you want quit the event processing loop
% and abort execution.
%
:- pred glut.quit(io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%
% State retrieval.
%
% Return the number of milliseconds since GLUT was initialised (or
% since this predicate was last called).
%
:- pred glut.elapsed_time(int::out, io::di, io::uo) is det.
% Returns `yes' if the current display mode is supported;
% `no' otherwise.
%
:- pred glut.display_mode_possible(bool::out, io::di, io::uo) is det.
:- type glut.state
---> screen_width
% Width of the screen in pixels.
% Zero indicates the width is unknown or unavailable.
; screen_height
% Height of the screen in pixels.
% Zero indicates the height is unknown or unavailable.
; screen_width_mm
% Width of the screen in millimetres.
% Zero indicates the width is unknown or unavailable.
; screen_height_mm
% Height of the screen in millimetres.
% Zero indicates the height is unknown or unavailable.
; init_window_x
% The X value of the initial window position.
; init_window_y.
% The Y value of the initial window position.
% Retrieves the specified GLUT state.
%
:- pred glut.get(glut.state::in, int::out, io::di, io::uo) is det.
:- type device
---> keyboard
; mouse
; spaceball
; dial_and_button_box
; tablet
; joystick.
% Returns `yes' if the we are running on a machine that has
% the specified device; `no' otherwise.
%
:- pred glut.has_device(device::in, bool::out, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module map, require.
:- pragma foreign_decl("C", "#include <GL/glut.h>").
:- pragma foreign_import_module("C", bool).
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.init(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
int argc;
argc = mercury_argc + 1;
glutInit(&argc, (char **) (mercury_argv - 1));
IO = IO0;
").
%-----------------------------------------------------------------------------%
glut.init_display_mode(Flags0, !IO) :-
Flags = list.foldr((\/), list.map(display_mode_to_int, Flags0), 0x0),
init_display_mode_2(Flags, !IO).
:- pred glut.init_display_mode_2(int::in, io::di, io::uo) is det.
:- pragma foreign_proc("C",
glut.init_display_mode_2(Flags::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutInitDisplayMode((unsigned) Flags);
IO = IO0;
").
:- func display_mode_to_int(display_mode) = int.
display_mode_to_int(rgba) = glut_rgba.
display_mode_to_int(index) = glut_index.
display_mode_to_int(single) = glut_single.
display_mode_to_int(double) = glut_double.
display_mode_to_int(accum) = glut_accum.
display_mode_to_int(alpha) = glut_alpha.
display_mode_to_int(depth) = glut_depth.
display_mode_to_int(stencil) = glut_stencil.
display_mode_to_int(multisample) = glut_multisample.
display_mode_to_int(stereo) = glut_stereo.
display_mode_to_int(luminance) = glut_luminance.
:- func glut_rgba = int.
:- pragma foreign_proc("C",
glut_rgba = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_RGBA;
").
:- func glut_index = int.
:- pragma foreign_proc("C",
glut_index = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_INDEX;
").
:- func glut_single = int.
:- pragma foreign_proc("C",
glut_single = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_SINGLE;
").
:- func glut_double = int.
:- pragma foreign_proc("C",
glut_double = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_DOUBLE;
").
:- func glut_accum = int.
:- pragma foreign_proc("C", glut_accum = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_ACCUM;
").
:- func glut_alpha = int.
:- pragma foreign_proc("C", glut_alpha = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_ACCUM;
").
:- func glut_depth = int.
:- pragma foreign_proc("C", glut_depth = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_DEPTH;
").
:- func glut_stencil = int.
:- pragma foreign_proc("C", glut_stencil = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_STENCIL;
").
:- func glut_multisample = int.
:- pragma foreign_proc("C", glut_multisample = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_MULTISAMPLE;
").
:- func glut_stereo = int.
:- pragma foreign_proc("C", glut_stereo = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_STEREO;
").
:- func glut_luminance = int.
:- pragma foreign_proc("C", glut_luminance = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_LUMINANCE;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.init_display_string(CtrlStr::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutInitDisplayString((char *) CtrlStr);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.init_window_position(X::in, Y::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutInitWindowPosition(X, Y);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.init_window_size(W::in, S::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutInitWindowSize(W, S);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.main_loop(IO0::di, IO::uo),
[may_call_mercury, promise_pure],
"
glutMainLoop();
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.quit(_IO0::di, _IO::uo),
[will_not_call_mercury, promise_pure],
"
exit(mercury_runtime_terminate());
").
%-----------------------------------------------------------------------------%
glut.get(State, Value, !IO) :-
glut.get_2(state_to_int(State), Value, !IO).
:- pred glut.get_2(int::in, int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
glut.get_2(State::in, Value::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Value = (MR_Integer) glutGet((GLenum) State);
IO = IO0;
").
:- func state_to_int(glut.state) = int.
state_to_int(screen_width) = glut_screen_width.
state_to_int(screen_height) = glut_screen_height.
state_to_int(screen_width_mm) = glut_screen_width_mm.
state_to_int(screen_height_mm) = glut_screen_height_mm.
state_to_int(init_window_x) = glut_init_window_x.
state_to_int(init_window_y) = glut_init_window_y.
:- func glut_screen_width = int.
:- pragma foreign_proc("C", glut_screen_width = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_SCREEN_WIDTH;
").
:- func glut_screen_height = int.
:- pragma foreign_proc("C", glut_screen_height = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_SCREEN_HEIGHT;
").
:- func glut_screen_width_mm = int.
:- pragma foreign_proc("C", glut_screen_width_mm = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_SCREEN_WIDTH_MM;
").
:- func glut_screen_height_mm = int.
:- pragma foreign_proc("C", glut_screen_height_mm = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_SCREEN_HEIGHT_MM;
").
:- func glut_init_window_x = int.
:- pragma foreign_proc("C", glut_init_window_x = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_INIT_WINDOW_X;
").
:- func glut_init_window_y = int.
:- pragma foreign_proc("C", glut_init_window_y = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_INIT_WINDOW_Y;
").
%-----------------------------------------------------------------------------%
glut.has_device(Device, Result, !IO) :-
glut.has_device_2(device_to_int(Device), Result, !IO).
:- pred glut.has_device_2(int::in, bool::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
glut.has_device_2(Device::in, Res::out, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
if(glutDeviceGet((GLenum) Device)) {
Res = ML_bool_return_yes();
} else {
Res = ML_bool_return_no();
}
IO = IO0;
").
:- func device_to_int(device) = int.
device_to_int(keyboard) = glut_has_keyboard.
device_to_int(mouse) = glut_has_mouse.
device_to_int(spaceball) = glut_has_spaceball.
device_to_int(dial_and_button_box) = glut_has_dial_and_button_box.
device_to_int(tablet) = glut_has_tablet.
device_to_int(joystick) = glut_has_joystick.
:- func glut_has_keyboard = int.
:- pragma foreign_proc("C", glut_has_keyboard = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_HAS_KEYBOARD;
").
:- func glut_has_mouse = int.
:- pragma foreign_proc("C", glut_has_mouse = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_HAS_MOUSE;
").
:- func glut_has_spaceball = int.
:- pragma foreign_proc("C", glut_has_spaceball = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_HAS_SPACEBALL;
").
:- func glut_has_dial_and_button_box = int.
:- pragma foreign_proc("C", glut_has_dial_and_button_box = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_HAS_DIAL_AND_BUTTON_BOX;
").
:- func glut_has_tablet = int.
:- pragma foreign_proc("C",
glut_has_tablet = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_HAS_TABLET;
").
:- func glut_has_joystick = int.
:- pragma foreign_proc("C",
glut_has_joystick = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_HAS_JOYSTICK;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.elapsed_time(Time::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Time = (MR_Integer) glutGet(GLUT_ELAPSED_TIME);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.display_mode_possible(IsPossible::out, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
if(glutGet(GLUT_DISPLAY_MODE_POSSIBLE)) {
IsPossible = ML_bool_return_yes();
} else {
IsPossible = ML_bool_return_no();
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- end_module glut.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% file: glut.window.m
% author: juliensf
%
% This module provides an interface to the GLUT window managment API.
% GLUT supports two types of windows: top-level windows and subwindows.
% Both sorts support OpenGL rendering and GLUT callbacks.
%
% XXX We do not currently support multiple windows.
%-----------------------------------------------------------------------------%
:- module glut.window.
:- interface.
%-----------------------------------------------------------------------------%
:- type window.window.
% window.create(Name, !IO).
% Create a new top-level window.
% Sets the current window to this newly created window.
%
:- pred window.create(string::in, io::di, io::uo) is det.
% window.create(Name, WindowId, !IO).
% As for window.create/3 but return the id for the newly created
% window.
:- pred window.create(string::in, window::out, io::di, io::uo) is det.
% Create a subwindow. Implicitly the the current window is set
% to the newly created subwindow.
% XXX We need a way to handle multiple windows for this to be useful.
%
%:- pred window.create_subwindow(window::in, int::in, int::in, int::in,
% int::in, window::out, io::di, io::uo) is det.
% Destroy the specified window. Does nothing if the
% specified window does not exist.
%
:- pred window.destroy(window::in, io::di, io::uo) is det.
% Mark the current window as needing to be redisplayed.
%
:- pred window.post_redisplay(io::di, io::uo) is det.
% Mark the specified window as needing to be redisplayed.
%
:- pred window.post_redisplay(window::in, io::di, io::uo) is det.
% Perform a buffer swap on the layer in use in the current window.
% If the window is not double-buffered this instruction is ignored.
%
:- pred window.swap_buffers(io::di, io::uo) is det.
% Get the identity of the current window. Returns
% `no' if no window exists or the current window has been destroyed.
%
:- pred window.id(maybe(window)::out, io::di, io::uo) is det.
% Sets the current window.
% NOTE: There is no way of knowing if this actually worked, so
% you need to call window.id/3 to make sure the current window
% is now the one you expect.
%
:- pred window.set(window::in, io::di, io::uo) is det.
% Sets the title for current window.
%
:- pred window.title(string::in, io::di, io::uo) is det.
% Set the icon title for the current window.
%
:- pred window.icon_title(string::in, io::di, io::uo) is det.
% Request a change to the position of the current window.
% NOTE: The window manager may choose to ignore this.
%
:- pred window.position(int::in, int::in, io::di, io::uo) is det.
% Request a change in the size of the current window.
% NOTE: For top-level windows the window system is free to apply
% its own policies to window sizing.
%
:- pred window.reshape(int::in, int::in, io::di, io::uo) is det.
% XXX Need support for multiple windows for this to be useful.
%:- pred window.pop(io::di, io::uo) is det.
% XXX Need support for multiple windows for this to be useful.
%:- pred window.push(io::di, io::uo) is det.
% Iconify the current window.
%
:- pred window.iconify(io::di, io::uo) is det.
% Show the current window.
% (It may not be visible if obscured by other shown windows).
%
:- pred window.show(io::di, io::uo) is det.
% Hide the current window.
%
:- pred window.hide(io::di, io::uo) is det.
% Requests that the current window be made full screen.
% (What "full screen" means in this context is dependant
% upon the windowing system).
%
:- pred window.full_screen(io::di, io::uo) is det.
:- type cursor
---> right_arrow % Arrow pointing up and to the right.
; left_arrow % Arrow pointing up and to the left.
; info % Pointing hand.
; destroy % Skull and cross bones.
; help % Question mark.
; cycle % Arrows rotating in a circle.
; wait % Wrist watch.
; text % Insertion point for text.
; crosshair % Simple cross-hair.
; up_down % Bi-directional pointing up and down.
; left_right % Bi-directional point left and right.
; top_side % Arrow pointing to top side.
; bottom_side % Arrow pointing to bottom side.
; left_side % Arrow pointing to left side.
; right_side % Arrow pointing to right side.
; top_left_corner % Arrow pointing to top left corner.
; top_right_corner % Arrow pointing to top right corner.
; bottom_right_corner % Arrow pointing to bottom right corner.
; bottom_left_corner % Arrow pointing to bottom left corner.
; full_crosshair
% Full screen cross hair cursor (if possible)
% Otherwise the same as `crosshair'.
; none % Invisible cursor.
; inherit. % Use parent window's cursor.
% Changes the cursor image for the current window.
%
:- pred window.set_cursor(cursor::in, io::di, io::uo) is det.
% Warps the pointer's location.
%
:- pred window.warp_pointer(int::in, int::in, io::di, io::uo) is det.
% Returns `yes(Id)' if `Id' is the parent window of the current
% window; `no' if the current window is a top-level window.
%
%:- pred window.get_parent(maybe(window)::out, io::di, io::uo) is det.
% Returns the number of subwindows of the current window.
%
%:- pred window.num_children(int::out, io::di, io::uo) is det.
% Returns `yes' if the current window is double buffered and `no'
% otherwise.
%
:- pred window.is_double_buffered(bool::out, io::di, io::uo) is det.
% Returns `yes' if the current layer of the current window is stereo;
% `no' otherwise.
%
:- pred window.is_stereo(bool::out, io::di, io::uo) is det.
% Returns `yes' if the current layer of the current window is RGBA mode.
%
:- pred window.is_rgba(bool::out, io::di, io::uo) is det.
% Returns `yes' if the current window has an overlay established;
% `no' otherwise.
%
:- pred window.has_overlay(bool::out, io::di, io::uo) is det.
%------------------------------------------------------------------------------%
%
% Window state.
%
:- type window.state
---> x
% Current X location in pixels.
; y
% Current Y location in pixels.
; window_width
% Width of the current window in pixels.
; window_height
% Height of the current window in pixels.
; buffer_size
% Number of bits in the current layer of
% the current window's color buffer.
; stencil_size
% Number of bits in the current layer of
% the current window's stencil buffer.
; depth_size
% Number of bits in the current layer of
% the current window's depth buffer.
; red_size
% Number of bits of red stored in the current
% layer of the current window's color buffer.
% Zero if in color index mode.
; green_size
% As above but the number of green bits.
; blue_size
% As above but the number of blue bits.
; alpha_size
% As above but the number of alpha bits.
; accum_red_size
% Number of bits of red in the accumulation
% buffer of the current layer of the current
% window. Zero if in color index mode.
; accum_green_size
% As above but the number of green bits.
; accum_blue_size
% As above but the number of blue bits.
; accum_alpha_size
% As above but the number of alpha bits.
; colormap_size
% Size of the color index colormap of the
% current layer of the current window.
% Zero if in RGBA mode.
; number_samples
% Number of samples for multisampling for the
% current layer of the current window.
; format_id.
% Window system dependent format Id for the
% current layer of the current window.
% Return the current setting of the specified parameter for the
% current window.
%
:- pred window.get(window.state::in, int::out, io::di, io::uo) is det.
%------------------------------------------------------------------------------%
%------------------------------------------------------------------------------%
:- implementation.
:- pragma foreign_decl("C", "#include <GL/glut.h>").
:- pragma foreign_import_module("C", bool).
:- type window == int.
%-----------------------------------------------------------------------------%
window.create(Name, !IO) :-
window.create(Name, _, !IO).
:- pragma foreign_proc("C",
window.create(Name::in, Win::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Win = (MR_Integer) glutCreateWindow((char *) Name);
IO = IO0;
").
% XXX This will not work properly until we can handle callbacks
% for multiple windows.
%:- pragma foreign_proc("C",
% create_subwindow(Parent::in, X::in, Y::in, W::in, H::in, Child::out,
% IO0::di, IO::uo),
% [will_not_call_mercury, promise_pure],
%"
% Child = (MR_Integer) glutCreateSubWindow((int)Parent, (int)X, (int)Y,
% (int)W, (int)H);
% IO = IO0;
%").
:- pragma foreign_proc("C",
window.destroy(Window::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutDestroyWindow(Window);
IO = IO0;
").
:- pragma foreign_proc("C",
window.post_redisplay(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutPostRedisplay();
IO = IO0;
").
:- pragma foreign_proc("C",
window.post_redisplay(Id::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutPostWindowRedisplay((int) Id);
IO = IO0;
").
:- pragma foreign_proc("C",
window.swap_buffers(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSwapBuffers();
IO = IO0;
").
window.id(MaybeWindow, !IO) :-
window.id_2(Window, !IO),
MaybeWindow = ( if Window = 0 then no else yes(Window) ).
:- pred window.id_2(int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
window.id_2(Win::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Win = (MR_Integer) glutGetWindow();
IO = IO0;
").
:- pragma foreign_proc("C",
window.set(Window::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSetWindow((int) Window);
IO = IO0;
").
:- pragma foreign_proc("C",
window.title(Title::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSetWindowTitle(Title);
IO = IO0;
").
:- pragma foreign_proc("C",
window.icon_title(Title::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSetIconTitle((char *) Title);
IO = IO0;
").
:- pragma foreign_proc("C",
window.position(X::in, Y::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutPositionWindow((int) X, (int) Y);
IO = IO0;
").
:- pragma foreign_proc("C",
window.reshape(W::in, H::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutReshapeWindow(W, H);
IO = IO0;
").
%:- pragma foreign_proc("C",
% window.pop(IO0::di, IO::uo),
% [will_not_call_mercury, promise_pure],
%"
% glutPopWindow();
% IO = IO0;
%").
%:- pragma foreign_proc("C",
% window.push(IO0::di, IO::uo),
% [will_not_call_mercury, promise_pure],
%"
% glutPushWindow();
% IO = IO0;
%").
:- pragma foreign_proc("C",
window.iconify(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutIconifyWindow();
IO = IO0;
").
:- pragma foreign_proc("C",
window.show(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutShowWindow();
IO = IO0;
").
:- pragma foreign_proc("C",
window.hide(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutHideWindow();
IO = IO0;
").
:- pragma foreign_proc("C",
window.full_screen(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutFullScreen();
IO = IO0;
").
:- func cursor_to_int(cursor) = int.
cursor_to_int(right_arrow) = glut_cursor_right_arrow.
cursor_to_int(left_arrow) = glut_cursor_left_arrow.
cursor_to_int(info) = glut_cursor_info.
cursor_to_int(destroy) = glut_cursor_destroy.
cursor_to_int(help) = glut_cursor_help.
cursor_to_int(cycle) = glut_cursor_cycle.
cursor_to_int(wait) = glut_cursor_wait.
cursor_to_int(text) = glut_cursor_text.
cursor_to_int(crosshair) = glut_cursor_crosshair.
cursor_to_int(up_down) = glut_cursor_up_down.
cursor_to_int(left_right) = glut_cursor_left_right.
cursor_to_int(top_side) = glut_cursor_top_side.
cursor_to_int(bottom_side) = glut_cursor_bottom_side.
cursor_to_int(left_side) = glut_cursor_left_side.
cursor_to_int(right_side) = glut_cursor_right_side.
cursor_to_int(top_left_corner) = glut_cursor_top_left_corner.
cursor_to_int(top_right_corner) = glut_cursor_top_right_corner.
cursor_to_int(bottom_right_corner) = glut_cursor_bottom_right_corner.
cursor_to_int(bottom_left_corner) = glut_cursor_bottom_left_corner.
cursor_to_int(full_crosshair) = glut_cursor_full_crosshair.
cursor_to_int(none) = glut_cursor_none.
cursor_to_int(inherit) = glut_cursor_inherit.
:- func glut_cursor_right_arrow = int.
:- pragma foreign_proc("C", glut_cursor_right_arrow = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_RIGHT_ARROW;
").
:- func glut_cursor_left_arrow = int.
:- pragma foreign_proc("C", glut_cursor_left_arrow = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_LEFT_ARROW;
").
:- func glut_cursor_info = int.
:- pragma foreign_proc("C", glut_cursor_info = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_INFO;
").
:- func glut_cursor_destroy = int.
:- pragma foreign_proc("C", glut_cursor_destroy = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_DESTROY;
").
:- func glut_cursor_help = int.
:- pragma foreign_proc("C", glut_cursor_help = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_HELP;
").
:- func glut_cursor_cycle = int.
:- pragma foreign_proc("C", glut_cursor_cycle = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_CYCLE;
").
:- func glut_cursor_wait = int.
:- pragma foreign_proc("C", glut_cursor_wait = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_WAIT;
").
:- func glut_cursor_text = int.
:- pragma foreign_proc("C", glut_cursor_text = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_TEXT;
").
:- func glut_cursor_crosshair = int.
:- pragma foreign_proc("C", glut_cursor_crosshair = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_CROSSHAIR;
").
:- func glut_cursor_up_down = int.
:- pragma foreign_proc("C", glut_cursor_up_down = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_UP_DOWN;
").
:- func glut_cursor_left_right = int.
:- pragma foreign_proc("C", glut_cursor_left_right = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_LEFT_RIGHT;
").
:- func glut_cursor_top_side = int.
:- pragma foreign_proc("C", glut_cursor_top_side = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_TOP_SIDE;
").
:- func glut_cursor_bottom_side = int.
:- pragma foreign_proc("C", glut_cursor_bottom_side = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_BOTTOM_SIDE;
").
:- func glut_cursor_left_side = int.
:- pragma foreign_proc("C", glut_cursor_left_side = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_LEFT_SIDE;
").
:- func glut_cursor_right_side = int.
:- pragma foreign_proc("C", glut_cursor_right_side = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_RIGHT_SIDE;
").
:- func glut_cursor_top_left_corner = int.
:- pragma foreign_proc("C", glut_cursor_top_left_corner = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_TOP_LEFT_CORNER;
").
:- func glut_cursor_top_right_corner = int.
:- pragma foreign_proc("C", glut_cursor_top_right_corner = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_TOP_RIGHT_CORNER;
").
:- func glut_cursor_bottom_right_corner = int.
:- pragma foreign_proc("C", glut_cursor_bottom_right_corner = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_BOTTOM_RIGHT_CORNER;
").
:- func glut_cursor_bottom_left_corner = int.
:- pragma foreign_proc("C", glut_cursor_bottom_left_corner = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_BOTTOM_LEFT_CORNER;
").
:- func glut_cursor_full_crosshair = int.
:- pragma foreign_proc("C", glut_cursor_full_crosshair = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_FULL_CROSSHAIR;
").
:- func glut_cursor_none = int.
:- pragma foreign_proc("C", glut_cursor_none = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_NONE;
").
:- func glut_cursor_inherit = int.
:- pragma foreign_proc("C", glut_cursor_inherit = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_CURSOR_INHERIT;
").
window.set_cursor(Cursor, !IO) :-
window.set_cursor_2(cursor_to_int(Cursor), !IO).
:- pred window.set_cursor_2(int::in, io::di, io::uo) is det.
:- pragma foreign_proc("C",
window.set_cursor_2(Cursor::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSetCursor((int) Cursor);
IO = IO0;
").
:- pragma foreign_proc("C",
window.warp_pointer(X::in, Y::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWarpPointer(X, Y);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%window.get_parent(Result, !IO) :-
% get_parent_2(Result0, !IO),
% Result = ( if Result0 = 0 then no else yes(Result0) ).
%
%:- pred get_parent_2(int::out, io::di, io::uo) is det.
%:- pragma foreign_proc("C",
% get_parent_2(Result::out, IO0::di, IO::uo),
% [will_not_call_mercury, promise_pure],
%"
% Result = (MR_Integer) glutGet(GLUT_WINDOW_PARENT);
% IO = IO0;
%").
%:- pragma foreign_proc("C",
% window.num_children(Result::out, IO0::di, IO::uo),
% [will_not_call_mercury, promise_pure],
%"
% Result = (MR_Integer) glutGet(GLUT_WINDOW_NUM_CHILDREN);
% IO = IO0;
%").
:- pragma foreign_proc("C",
window.is_double_buffered(DB::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
if(glutGet(GLUT_WINDOW_DOUBLEBUFFER)) {
DB = ML_bool_return_yes();
} else {
DB = ML_bool_return_no();
}
IO = IO0;
").
:- pragma foreign_proc("C",
window.is_stereo(Stereo::out, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
if(glutGet(GLUT_WINDOW_STEREO)) {
Stereo = ML_bool_return_yes();
} else {
Stereo = ML_bool_return_no();
}
IO = IO0;
").
:- pragma foreign_proc("C",
window.is_rgba(RGBA::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, terminates],
"
if(glutGet(GLUT_WINDOW_RGBA)) {
RGBA = ML_bool_return_yes();
} else {
RGBA = ML_bool_return_no();
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- func window_state_to_int(window.state) = int.
window_state_to_int(x) = glut_window_x.
window_state_to_int(y) = glut_window_y.
window_state_to_int(window_width) = glut_window_width.
window_state_to_int(window_height) = glut_window_height.
window_state_to_int(buffer_size) = glut_window_buffer_size.
window_state_to_int(stencil_size) = glut_window_stencil_size.
window_state_to_int(depth_size) = glut_window_depth_size.
window_state_to_int(red_size) = glut_window_red_size.
window_state_to_int(green_size) = glut_window_green_size.
window_state_to_int(blue_size) = glut_window_blue_size.
window_state_to_int(alpha_size) = glut_window_alpha_size.
window_state_to_int(accum_red_size) = glut_window_accum_red_size.
window_state_to_int(accum_green_size) = glut_window_accum_green_size.
window_state_to_int(accum_blue_size) = glut_window_accum_blue_size.
window_state_to_int(accum_alpha_size) = glut_window_accum_alpha_size.
window_state_to_int(colormap_size) = glut_window_colormap_size.
window_state_to_int(number_samples) = glut_window_num_samples.
window_state_to_int(format_id) = glut_window_format_id.
window.get(State, Value, !IO) :-
window.get_2(window_state_to_int(State), Value, !IO).
:- pred window.get_2(int::in, int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
window.get_2(State::in, Value::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Value = (MR_Integer) glutGet((GLenum) State);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- func glut_window_x = int.
:- pragma foreign_proc("C", glut_window_x = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_X;
").
:- func glut_window_y = int.
:- pragma foreign_proc("C", glut_window_y = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_Y;
").
:- func glut_window_width = int.
:- pragma foreign_proc("C", glut_window_width = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_WIDTH;
").
:- func glut_window_height = int.
:- pragma foreign_proc("C", glut_window_height = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_HEIGHT;
").
:- func glut_window_buffer_size = int.
:- pragma foreign_proc("C", glut_window_buffer_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_BUFFER_SIZE;
").
:- func glut_window_stencil_size = int.
:- pragma foreign_proc("C", glut_window_stencil_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_STENCIL_SIZE;
").
:- func glut_window_depth_size = int.
:- pragma foreign_proc("C", glut_window_depth_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_DEPTH_SIZE;
").
:- func glut_window_red_size = int.
:- pragma foreign_proc("C", glut_window_red_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_RED_SIZE;
").
:- func glut_window_green_size = int.
:- pragma foreign_proc("C", glut_window_green_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_GREEN_SIZE;
").
:- func glut_window_blue_size = int.
:- pragma foreign_proc("C", glut_window_blue_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_BLUE_SIZE;
").
:- func glut_window_alpha_size = int.
:- pragma foreign_proc("C", glut_window_alpha_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_ALPHA_SIZE;
").
:- func glut_window_accum_red_size = int.
:- pragma foreign_proc("C", glut_window_accum_red_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_ACCUM_RED_SIZE;
").
:- func glut_window_accum_green_size = int.
:- pragma foreign_proc("C", glut_window_accum_green_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_ACCUM_GREEN_SIZE;
").
:- func glut_window_accum_blue_size = int.
:- pragma foreign_proc("C", glut_window_accum_blue_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_ACCUM_BLUE_SIZE;
").
:- func glut_window_accum_alpha_size = int.
:- pragma foreign_proc("C", glut_window_accum_alpha_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_ACCUM_ALPHA_SIZE;
").
:- func glut_window_colormap_size = int.
:- pragma foreign_proc("C", glut_window_colormap_size = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_COLORMAP_SIZE;
").
:- func glut_window_num_samples = int.
:- pragma foreign_proc("C", glut_window_num_samples = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_NUM_SAMPLES;
").
:- func glut_window_format_id = int.
:- pragma foreign_proc("C", glut_window_format_id = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_WINDOW_FORMAT_ID;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
window.has_overlay(Result::out, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
if (glutLayerGet(GLUT_HAS_OVERLAY)) {
Result = ML_bool_return_yes();
} else {
Result = ML_bool_return_no();
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- end_module glut.window.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% file: glut.callback.m
% author: juliensf
%
% This module contains predicates for (un)registering glut callbacks.
%
%-----------------------------------------------------------------------------%
:- module glut.callback.
:- interface.
%-----------------------------------------------------------------------------%
% Registers the display callback for the current window.
% This is called whenever GLUT determines that the window needs
% to be redisplayed. You can call glut.window.post_redisplay/2
% to force the window to be redrawn.
%
:- pred callback.display_func(pred(io, io), io, io).
:- mode callback.display_func(pred(di, uo) is det, di, uo)is det.
% Unregisters the display callback for the current window.
%
:- pred callback.disable_display_func(io::di, io::uo) is det.
% Registers the rehsape callback for the current window.
% The reshape callback is Reshape(Width, Height, !IO).
% `Width' and `Height' specify the new window size measured
% in pixels.
%
:- pred callback.reshape_func(pred(int, int, io, io), io, io).
:- mode callback.reshape_func(pred(in, in, di, uo) is det, di, uo) is det.
% Unregisters the reshape callback for the current window.
%
:- pred callback.disable_reshape_func(io::di, io::uo) is det.
% Registers the keyboard callback for the current window.
% This is called whenver a key is pressed.
% The keyboard callback is Keyboard(Key, X, Y, !IO). `Key'
% is the ASCII value of the key pressed. `X' and `Y' are the
% mouse coordinates at the time the key is pressed.
%
:- pred callback.keyboard_func(pred(char, int, int, io, io), io, io).
:- mode callback.keyboard_func(pred(in, in, in, di, uo) is det, di, uo) is det.
% Unregisters the keyboard callback for the current window.
%
:- pred callback.disable_keyboard_func(io::di, io::uo) is det.
:- type button ---> left ; middle ; right.
:- type button_state ---> up ; down.
% Registers the mouse callback for the current window.
% This is called whenever the state of one of the mouse buttons
% changes (ie. a button is pressed or released). The mouse
% callback is MouseFunc(Button, State, X, Y, !IO). `Button'
% is the identity of the button, `State' indicates whether the
% button was pressed or released. `X' and `Y' give the mouse pointer
% coordinates at the time of the button event.
%
:- pred callback.mouse_func(pred(button, button_state, int, int, io, io),
io, io).
:- mode callback.mouse_func(pred(in, in, in, in, di, uo) is det, di, uo)
is det.
% Unregisters the mouse callback for the current window.
%
:- pred callback.disable_mouse_func(io::di, io::uo) is det.
% Registers the mouse motion callback for the current window.
% The motion callback is called if the mouse is moved while
% one of the buttons is pressed.
%
:- pred callback.motion_func(pred(int, int, io, io), io, io).
:- mode callback.motion_func(pred(in, in, di, uo) is det, di, uo) is det.
% Unregisters the mouse motion callback for the current window.
%
:- pred callback.disable_motion_func(io::di, io::uo) is det.
% Registers the passive motion callback for the current window.
% The passive motion callback is called if the mouse is moved while
% no mouse buttons are pressed.
%
:- pred callback.passive_motion_func(pred(int, int, io, io), io, io).
:- mode callback.passive_motion_func(pred(in, in, di, uo) is det, di, uo)
is det.
% Unregisters the passive motion callback for the current window.
%
:- pred callback.disable_passive_motion_func(io::di, io::uo) is det.
:- type entry_state ---> left ; entered.
% Registers the entry callback for the current window.
% This is called whenever the mouse pointer enters/leaves the
% current window.
%
:- pred callback.entry_func(pred(entry_state, io, io), io, io).
:- mode callback.entry_func(pred(in, di, uo) is det, di, uo) is det.
% Unregisters the entry callback for the current window.
%
:- pred callback.disable_entry_func(io::di, io::uo) is det.
:- type visibility ---> visible ; not_visible.
% Register the visibility callback for the current window.
% This visibility callback is whenever the visibility of a
% window changes.
%
:- pred callback.visibility_func(pred(visibility, io, io), io, io).
:- mode callback.visibility_func(pred(in, di, uo) is det, di, uo) is det.
% Unregister the visibility callback for the current window.
%
:- pred callback.disable_visibility_func(io::di, io::uo) is det.
% Register the global idle callback. The idle callback is called
% continuously when the are no other events to be processed.
%
:- pred callback.idle_func(pred(io, io), io, io).
:- mode callback.idle_func(pred(di, uo) is det, di, uo) is det.
% Unregister the global idle callback.
%
:- pred callback.disable_idle_func(io::di, io::uo) is det.
% NYI.
%:- pred callback.timer_func(pred(io, io), int).
%:- mode callback.timer_func(pred(di, uo) is det.
:- type special_key
---> f1
; f2
; f3
; f4
; f5
; f6
; f7
; f8
; f9
; f10
; f11
; f12
; left
; up
; right
; down
; page_up
; page_down
; home
; end
; insert.
% Register the special keyboard callback for the current window.
% This is called when one of the function or arrow keys is pressed.
%
:- pred callback.special_func(pred(special_key, int, int, io, io), io, io).
:- mode callback.special_func(pred(in, in, in, di, uo) is det, di, uo) is det.
% Unregister the special keyboard callback for the current window.
%
:- pred callback.disable_special_func(io::di, io::uo) is det.
% Register the special keyboard up callbcak for the current window.
% This is called when one fo the function or arrow keys is released.
%
:- pred callback.special_up_func(pred(special_key, int, int, io, io), io, io).
:- mode callback.special_up_func(pred(in, in, in, di, uo) is det, di, uo)
is det.
% Unregister the special keyboard up callback for the current window.
%
:- pred callback.disable_special_up_func(io::di, io::uo) is det.
% Register the keyboard_up callback for the current window.
% This is called whenever a key is released. The arguments
% of the callback predicate are the same as the keyboard callback.
%
:- pred callback.keyboard_up_func(pred(char, int, int, io, io), io, io).
:- mode callback.keyboard_up_func(pred(in, in, in, di, uo) is det, di, uo)
is det.
% Unregister the keyuboard_up callback for the current window.
%
:- pred callback.disable_keyboard_up_func(io::di, io::uo) is det.
% Register the overlay display callback for the current window.
% This is called whenever GLUT determines that the overlay plane
% for the current window needs to be redrawn.
%
:- pred callback.overlay_display_func(pred(io, io), io, io).
:- mode callback.overlay_display_func(pred(di, uo) is det, di, uo) is det.
% Unregister the overlay display callback for the current window.
%
:- pred callback.overlay_display_func(io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module io, int.
:- pragma foreign_decl("C", "
#include <stdio.h>
#include <GL/glut.h>
").
%-----------------------------------------------------------------------------%
% Global callbacks.
:- pragma foreign_decl("C", "
void MGLUT_idle_callback(void);
extern MR_Word mglut_idle_callback;
").
% Window specific callbacks.
:- pragma foreign_decl("C", "
void MGLUT_display_callback(void);
void MGLUT_reshape_callback(int, int);
void MGLUT_keyboard_callback(unsigned char, int, int);
void MGLUT_mouse_callback(int, int, int, int);
void MGLUT_motion_callback(int, int);
void MGLUT_passive_motion_callback(int, int);
void MGLUT_entry_callback(int);
void MGLUT_visibility_callback(int);
void MGLUT_special_callback(int, int, int);
void MGLUT_special_up_callback(int, int, int);
void MGLUT_keyboard_up_callback(unsigned char, int, int);
void MGLUT_overlay_display_callback(void);
extern MR_Word mglut_display_callback;
extern MR_Word mglut_reshape_callback;
extern MR_Word mglut_keyboard_callback;
extern MR_Word mglut_mouse_callback;
extern MR_Word mglut_entry_callback;
extern MR_Word mglut_visibility_callback;
extern MR_Word mglut_motion_callback;
extern MR_Word mglut_passive_motion_callback;
extern MR_Word mglut_special_callback;
extern MR_Word mglut_special_up_callback;
extern MR_Word mglut_keyboard_up_callback;
extern MR_Word mglut_overlay_display_callback;
").
:- pragma foreign_code("C", "
/* XXX If we ever support multiple windows remember that the idle
* callback is global.
*/
MR_Word mglut_idle_callback;
MR_Word mglut_display_callback;
MR_Word mglut_reshape_callback;
MR_Word mglut_keyboard_callback;
MR_Word mglut_mouse_callback;
MR_Word mglut_motion_callback;
MR_Word mglut_passive_motion_callback;
MR_Word mglut_entry_callback;
MR_Word mglut_visibility_callback;
MR_Word mglut_special_callback;
MR_Word mglut_special_up_callback;
MR_Word mglut_keyboard_up_callback;
MR_Word mglut_overlay_display_callback;
").
%-----------------------------------------------------------------------------%
%
% Display callbacks.
%
:- pragma foreign_proc("C",
callback.display_func(DisplayFunc::pred(di, uo) is det, IO0::di,
IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_display_callback = DisplayFunc;
glutDisplayFunc(MGLUT_display_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_display_callback(void)
{
MGLUT_do_display_callback(mglut_display_callback);
}
").
:- pragma export(do_display_callback(pred(di, uo) is det, di, uo),
"MGLUT_do_display_callback").
:- pred do_display_callback(pred(io, io), io, io).
:- mode do_display_callback(pred(di, uo) is det, di, uo) is det.
do_display_callback(DisplayFunc, !IO) :- DisplayFunc(!IO).
:- pragma foreign_proc("C",
disable_display_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutDisplayFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Reshape callbacks.
%
:- pragma foreign_proc("C",
callback.reshape_func(Reshape::pred(in, in, di, uo) is det, IO0::di,
IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_reshape_callback = Reshape;
glutReshapeFunc(MGLUT_reshape_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_reshape_callback(int width, int height)
{
MGLUT_do_reshape_callback(mglut_reshape_callback, width, height);
}
").
:- pragma export(do_reshape_callback(pred(in, in, di, uo) is det, in, in, di,
uo), "MGLUT_do_reshape_callback").
:- pred do_reshape_callback(pred(int, int, io, io), int, int, io, io).
:- mode do_reshape_callback(pred(in, in, di, uo) is det, in, in, di, uo) is det.
do_reshape_callback(ReshapeFunc, Width, Height, !IO) :-
ReshapeFunc(Width, Height, !IO).
:- pragma foreign_proc("C",
disable_reshape_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutReshapeFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Keyboard callbacks.
%
:- pragma foreign_proc("C",
keyboard_func(KeyboardFunc::pred(in, in, in, di, uo) is det, IO0::di,
IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_keyboard_callback = KeyboardFunc;
glutKeyboardFunc(MGLUT_keyboard_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_keyboard_callback(unsigned char scan_code, int x, int y)
{
MGLUT_do_keyboard_callback(mglut_keyboard_callback,
(MR_Char) scan_code, (MR_Integer) x, (MR_Integer) y);
}
").
:- pragma export(do_keyboard_callback(pred(in, in, in, di, uo) is det,
in, in, in, di, uo), "MGLUT_do_keyboard_callback").
:- pred do_keyboard_callback(pred(char, int, int, io, io), char, int, int,
io, io).
:- mode do_keyboard_callback(pred(in, in, in, di, uo) is det, in, in, in,
di, uo) is det.
do_keyboard_callback(KeyBoardFunc, ScanCode, X, Y, !IO) :-
KeyBoardFunc(ScanCode, X, Y, !IO).
:- pragma foreign_proc("C",
disable_keyboard_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutKeyboardFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Mouse callbacks.
%
:- pragma foreign_proc("C",
mouse_func(MouseFunc::pred(in, in, in, in, di, uo) is det, IO0::di,
IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_mouse_callback = MouseFunc;
glutMouseFunc(MGLUT_mouse_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_mouse_callback(int button, int state, int x, int y)
{
MGLUT_do_mouse_callback(mglut_mouse_callback, (MR_Integer) button,
(MR_Integer) state, (MR_Integer) x, (MR_Integer) y);
}
").
:- pragma export(do_mouse_callback(pred(in, in, in, in, di, uo) is det,
in, in, in, in, di, uo), "MGLUT_do_mouse_callback").
:- pred do_mouse_callback(pred(button, button_state, int, int, io, io),
int, int, int, int, io, io).
:- mode do_mouse_callback(pred(in, in, in, in, di, uo) is det, in, in, in,
in, di, uo) is det.
do_mouse_callback(MouseFunc, Button0, State0, X, Y, !IO) :-
( if Button0 = glut_left_button then Button = left
else if Button0 = glut_middle_button then Button = middle
else if Button0 = glut_right_button then Button = right
else error("Unknown mouse button.")
),
( if State0 = glut_up then State = up
else if State0 = glut_down then State = down
else error("Unknown mouse button state.")
),
MouseFunc(Button, State, X, Y, !IO).
:- func glut_left_button = int.
:- pragma foreign_proc("C", glut_left_button = (V::out),
[will_not_call_mercury, promise_pure, thread_safe], "
V = (MR_Integer) GLUT_LEFT_BUTTON;
").
:- func glut_middle_button = int.
:- pragma foreign_proc("C", glut_middle_button = (V::out),
[will_not_call_mercury, promise_pure, thread_safe], "
V = (MR_Integer) GLUT_MIDDLE_BUTTON;
").
:- func glut_right_button = int.
:- pragma foreign_proc("C", glut_right_button = (V::out),
[will_not_call_mercury, promise_pure, thread_safe], "
V = (MR_Integer) GLUT_RIGHT_BUTTON;
").
:- func glut_up = int.
:- pragma foreign_proc("C", glut_up = (V::out),
[will_not_call_mercury, promise_pure, thread_safe], "
V = (MR_Integer) GLUT_UP;
").
:- func glut_down = int.
:- pragma foreign_proc("C", glut_down = (V::out),
[will_not_call_mercury, promise_pure, thread_safe], "
V = (MR_Integer) GLUT_DOWN;
").
:- pragma foreign_proc("C", disable_mouse_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure], "
glutMouseFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Motion callback.
%
:- pragma foreign_proc("C",
motion_func(MotionFunc::pred(in, in, di, uo) is det, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_motion_callback = MotionFunc;
glutMotionFunc(MGLUT_motion_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_motion_callback(int x, int y)
{
MGLUT_do_motion_callback(mglut_motion_callback, (MR_Integer) x,
(MR_Integer) y);
}
").
:- pragma export(do_motion_callback(pred(in, in, di, uo) is det, in, in,
di, uo), "MGLUT_do_motion_callback").
:- pred do_motion_callback(pred(int, int, io, io), int, int, io, io).
:- mode do_motion_callback(pred(in, in, di, uo) is det, in, in, di, uo) is det.
do_motion_callback(MotionFunc, X, Y, !IO) :- MotionFunc(X, Y, !IO).
:- pragma foreign_proc("C",
disable_motion_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutMotionFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Passive motion callbacks.
%
:- pragma foreign_proc("C",
passive_motion_func(PassiveMotionFunc::pred(in, in, di, uo) is det,
IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_passive_motion_callback = PassiveMotionFunc;
glutPassiveMotionFunc(MGLUT_passive_motion_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_passive_motion_callback(int x, int y)
{
MGLUT_do_passive_motion_callback(mglut_passive_motion_callback,
(MR_Integer) x, (MR_Integer) y);
}
").
:- pragma export(do_passive_motion_callback(pred(in, in, di, uo) is det,
in, in, di, uo), "MGLUT_do_passive_motion_callback").
:- pred do_passive_motion_callback(pred(int, int, io, io), int, int, io, io).
:- mode do_passive_motion_callback(pred(in, in, di, uo) is det, in, in,
di, uo) is det.
do_passive_motion_callback(PassiveMotionFunc, X, Y, !IO) :-
PassiveMotionFunc(X, Y, !IO).
:- pragma foreign_proc("C",
disable_passive_motion_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutPassiveMotionFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
entry_func(EntryFunc::pred(in, di, uo) is det, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
mglut_entry_callback = EntryFunc;
glutEntryFunc(MGLUT_entry_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_entry_callback(int state)
{
MGLUT_do_entry_callback(mglut_entry_callback, state);
}").
:- pragma export(do_entry_callback(pred(in, di, uo) is det, in, di, uo),
"MGLUT_do_entry_callback").
:- pred do_entry_callback(pred(entry_state, io, io), int, io, io).
:- mode do_entry_callback(pred(in, di, uo) is det, in, di, uo) is det.
do_entry_callback(EntryFunc, State0, !IO) :-
( if State0 = glut_left then State = left
else if State0 = glut_entered then State = entered
else error("Unable to determine entry state.")
),
EntryFunc(State, !IO).
:- pragma foreign_proc("C",
disable_entry_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutEntryFunc(NULL);
IO = IO0;
").
:- func glut_left = int.
:- pragma foreign_proc("C", glut_left = (Value::out),
[will_not_call_mercury, promise_pure],
"
Value = (MR_Integer) GLUT_LEFT;
").
:- func glut_entered = int.
:- pragma foreign_proc("C", glut_entered = (Value::out),
[will_not_call_mercury, promise_pure],
"
Value = (MR_Integer) GLUT_ENTERED;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
visibility_func(VisibilityFunc::pred(in, di, uo) is det, IO0::di,
IO::uo),
[will_not_call_mercury, promise_pure],
"
mglut_visibility_callback = VisibilityFunc;
glutVisibilityFunc(MGLUT_visibility_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_visibility_callback(int state)
{
MGLUT_do_visibility_callback(mglut_visibility_callback, state);
}").
:- pragma export(do_visibility_callback(pred(in, di, uo) is det, in, di, uo),
"MGLUT_do_visibility_callback").
:- pred do_visibility_callback(pred(visibility, io, io), int, io, io).
:- mode do_visibility_callback(pred(in, di, uo) is det, in, di, uo) is det.
do_visibility_callback(VisibilityFunc, State0, !IO) :-
( if State0 = glut_visible then State = visible
else if State0 = glut_not_visible then State = not_visible
else error("Unable to determine visibility.")
),
VisibilityFunc(State, !IO).
:- pragma foreign_proc("C",
disable_visibility_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutVisibilityFunc(NULL);
IO = IO0;
").
:- func glut_visible = int.
:- pragma foreign_proc("C", glut_visible = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_VISIBLE;
").
:- func glut_not_visible = int.
:- pragma foreign_proc("C", glut_not_visible = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_NOT_VISIBLE;
").
%-----------------------------------------------------------------------------%
%
% Idle callback.
%
:- pragma foreign_proc("C",
idle_func(Closure::pred(di, uo) is det, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_idle_callback = Closure;
glutIdleFunc(MGLUT_idle_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_idle_callback(void)
{
MGLUT_do_idle_callback(mglut_idle_callback);
}").
:- pragma export(do_idle_callback(pred(di, uo) is det, di, uo),
"MGLUT_do_idle_callback").
:- pred do_idle_callback(pred(io, io), io, io).
:- mode do_idle_callback(pred(di, uo) is det, di, uo) is det.
do_idle_callback(IdleFunc, !IO) :- IdleFunc(!IO).
:- pragma foreign_proc("C",
disable_idle_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutIdleFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Keyboard up callbacks.
%
:- pragma foreign_proc("C",
keyboard_up_func(KeyUpFunc::pred(in, in, in, di ,uo) is det, IO0::di,
IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_keyboard_up_callback = KeyUpFunc;
glutKeyboardUpFunc(MGLUT_keyboard_up_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_keyboard_up_callback(unsigned char scan_code, int x, int y)
{
MGLUT_do_keyboard_up_callback(mglut_keyboard_up_callback,
(MR_Char) scan_code, (MR_Integer) x, (MR_Integer) y);
}").
:- pragma export(do_keyboard_up_callback(pred(in, in, in, di, uo) is det,
in, in, in, di, uo), "MGLUT_do_keyboard_up_callback").
:- pred do_keyboard_up_callback(pred(char, int, int, io, io), char, int, int,
io, io).
:- mode do_keyboard_up_callback(pred(in,in,in,di,uo) is det, in, in, in, di,
uo) is det.
do_keyboard_up_callback(KeyBoardUpFunc, ScanCode, X, Y, !IO) :-
KeyBoardUpFunc(ScanCode, X, Y, !IO).
:- pragma foreign_proc("C",
disable_keyboard_up_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutKeyboardFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Overlay display callbacks.
%
:- pragma foreign_proc("C",
overlay_display_func(OverlayFunc::pred(di, uo) is det, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_overlay_display_callback = OverlayFunc;
glutOverlayDisplayFunc(MGLUT_overlay_display_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_overlay_display_callback(void)
{
MGLUT_do_overlay_display_callback(mglut_overlay_display_callback);
}").
:- pragma export(do_overlay_display_callback(pred(di, uo) is det, di, uo),
"MGLUT_do_overlay_display_callback").
:- pred do_overlay_display_callback(pred(io, io), io, io).
:- mode do_overlay_display_callback(pred(di, uo) is det, di, uo) is det.
do_overlay_display_callback(OverlayDisplayFunc, !IO) :-
OverlayDisplayFunc(!IO).
:- pragma foreign_proc("C",
overlay_display_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutOverlayDisplayFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Special keyboard callbacks.
%
:- pragma foreign_proc("C",
callback.special_func(SpecialFunc::pred(in, in, in, di, uo) is det,
IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_special_callback = SpecialFunc;
glutSpecialFunc(MGLUT_special_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_special_callback(int key, int x, int y)
{
MGLUT_do_special_callback(mglut_special_callback, (MR_Integer) key,
(MR_Integer) x, (MR_Integer) y);
}
").
:- pragma export(do_special_callback(pred(in, in, in ,di, uo) is det,
in, in, in, di, uo), "MGLUT_do_special_callback").
:- pred do_special_callback(pred(special_key, int, int, io, io),
int, int, int, io, io).
:- mode do_special_callback(pred(in,in,in,di,uo) is det, in, in, in, di, uo)
is det.
do_special_callback(Special, Key, X, Y, !IO) :-
Special(int_to_special_key(Key), X, Y, !IO).
:- pragma foreign_proc("C",
callback.disable_special_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSpecialFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Special keyboard up callbacks.
%
:- pragma foreign_proc("C",
callback.special_up_func(SpecialFunc::pred(in, in, in, di, uo) is det,
IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
mglut_special_up_callback = SpecialFunc;
glutSpecialUpFunc(MGLUT_special_up_callback);
IO = IO0;
").
:- pragma foreign_code("C", "
void MGLUT_special_up_callback(int key, int x, int y)
{
MGLUT_do_special_up_callback(mglut_special_up_callback,
(MR_Integer) key, (MR_Integer) x, (MR_Integer) y);
}").
:- pragma export(do_special_up_callback(pred(in, in, in ,di, uo) is det,
in, in, in, di, uo), "MGLUT_do_special_up_callback").
:- pred do_special_up_callback(pred(special_key, int, int, io, io),
int, int, int, io, io).
:- mode do_special_up_callback(pred(in,in,in,di,uo) is det, in, in, in, di, uo)
is det.
do_special_up_callback(SpecialUpFunc, Key, X, Y, !IO) :-
SpecialUpFunc(int_to_special_key(Key), X, Y, !IO).
:- pragma foreign_proc("C",
callback.disable_special_up_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSpecialUpFunc(NULL);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%
% Constants for special keyboard callbacks.
%
:- func int_to_special_key(int) = special_key.
int_to_special_key(KeyCode) = Key :-
( if KeyCode = glut_key_f1 then Key = f1
else if KeyCode = glut_key_f2 then Key = f2
else if KeyCode = glut_key_f3 then Key = f3
else if KeyCode = glut_key_f4 then Key = f4
else if KeyCode = glut_key_f5 then Key = f5
else if KeyCode = glut_key_f6 then Key = f6
else if KeyCode = glut_key_f7 then Key = f7
else if KeyCode = glut_key_f8 then Key = f8
else if KeyCode = glut_key_f9 then Key = f9
else if KeyCode = glut_key_f10 then Key = f10
else if KeyCode = glut_key_f11 then Key = f11
else if KeyCode = glut_key_f12 then Key = f12
else if KeyCode = glut_key_left then Key = left
else if KeyCode = glut_key_up then Key = up
else if KeyCode = glut_key_right then Key = right
else if KeyCode = glut_key_down then Key = down
else if KeyCode = glut_key_page_up then Key = page_up
else if KeyCode = glut_key_page_down then Key = page_down
else if KeyCode = glut_key_home then Key = home
else if KeyCode = glut_key_end then Key = end
else if KeyCode = glut_key_insert then Key = insert
else error("Unknown special key encountered.")
).
:- func glut_key_f1 = int.
:- pragma foreign_proc("C", glut_key_f1 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F1;
").
:- func glut_key_f2 = int.
:- pragma foreign_proc("C", glut_key_f2 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F2;
").
:- func glut_key_f3 = int.
:- pragma foreign_proc("C", glut_key_f3 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F3;
").
:- func glut_key_f4 = int.
:- pragma foreign_proc("C", glut_key_f4 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F4;
").
:- func glut_key_f5 = int.
:- pragma foreign_proc("C", glut_key_f5 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F5;
").
:- func glut_key_f6 = int.
:- pragma foreign_proc("C", glut_key_f6 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F6;
").
:- func glut_key_f7 = int.
:- pragma foreign_proc("C", glut_key_f7 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F7;
").
:- func glut_key_f8 = int.
:- pragma foreign_proc("C", glut_key_f8 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F8;
").
:- func glut_key_f9 = int.
:- pragma foreign_proc("C", glut_key_f9 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F9;
").
:- func glut_key_f10 = int.
:- pragma foreign_proc("C", glut_key_f10 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F10;
").
:- func glut_key_f11 = int.
:- pragma foreign_proc("C", glut_key_f11 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F11;
").
:- func glut_key_f12 = int.
:- pragma foreign_proc("C", glut_key_f12 = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_F12;
").
:- func glut_key_left = int.
:- pragma foreign_proc("C", glut_key_left = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_LEFT;
").
:- func glut_key_up = int.
:- pragma foreign_proc("C", glut_key_up = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_UP;
").
:- func glut_key_right = int.
:- pragma foreign_proc("C", glut_key_right = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_RIGHT;
").
:- func glut_key_down = int.
:- pragma foreign_proc("C", glut_key_down = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_DOWN;
").
:- func glut_key_page_up = int.
:- pragma foreign_proc("C", glut_key_page_up = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_PAGE_UP;
").
:- func glut_key_page_down = int.
:- pragma foreign_proc("C", glut_key_page_down = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_PAGE_DOWN;
").
:- func glut_key_home = int.
:- pragma foreign_proc("C", glut_key_home = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_HOME;
").
:- func glut_key_end = int.
:- pragma foreign_proc("C", glut_key_end = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_END;
").
:- func glut_key_insert = int.
:- pragma foreign_proc("C", glut_key_insert = (V::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
V = (MR_Integer) GLUT_KEY_INSERT;
").
%-----------------------------------------------------------------------------%
:- end_module glut.callback.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% file: glut.color_map.m
% author: juliensf
%
% This module contains routines for manipulating colormaps when using
% color index mode. This is necessary since OpenGL does not include any
% means of doing this.
%
%-----------------------------------------------------------------------------%
:- module glut.color_map.
:- interface.
%-----------------------------------------------------------------------------%
:- type component ---> red ; blue ; green.
% color_map.set_color(Index, Red, Blue, Green, !IO).
% Set the colormap entry for the given index.
%
:- pred color_map.set_color(int::in, float::in, float::in, float::in,
io::di, io::uo) is det.
% color_map.get_color(Index, Component, Value, !IO).
% Retrieve the value for the given component for the given
% color index colormap entry.
%
:- pred color_map.get_color(int::in, component::in, float::out,
io::di, io::uo) is det.
% Copy the logical colormap for the layer in use from the specified
% window to the current window.
% XXX Not useful until we support multiple windows.
%
:- pred color_map.copy(window::in, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- pragma foreign_decl("C", "#include <GL/glut.h>").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
color_map.set_color(I::in, R::in, G::in, B::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSetColor((int) I, (GLfloat) R, (GLfloat) G, (GLfloat) B);
IO = IO0;
").
color_map.get_color(Index, Component, Value, !IO) :-
get_color_2(Index, component_to_int(Component), Value, !IO).
:- pred get_color_2(int::in, int::in, float::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
get_color_2(I::in, C::in, V::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
V = (MR_Float) glutGetColor((int) I, (int) C);
IO = IO0;
").
:- func component_to_int(component) = int.
component_to_int(red) = glut_red.
component_to_int(green) = glut_green.
component_to_int(blue) = glut_blue.
:- func glut_red = int.
:- pragma foreign_proc("C", glut_red = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_RED;
").
:- func glut_green = int.
:- pragma foreign_proc("C", glut_green = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_GREEN;
").
:- func glut_blue = int.
:- pragma foreign_proc("C", glut_blue = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_BLUE;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
color_map.copy(WinId::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutCopyColormap((int) WinId);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- end_module glut.color_map.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% file: glut.model.m
% author: juliensf
%
%-----------------------------------------------------------------------------%
:- module glut.model.
:- interface.
%-----------------------------------------------------------------------------%
% Most of the predicates in this module come in two flavours.
% The model.wire_* ones draw a wireframe object. The corresponding
% model.solid_* predicate draws a solid version of the same model.
% None of these predicates make use of display lists.
% model.*_cube(Size, !IO).
% `Size' is the length of each edge.
%
:- pred model.wire_cube(float::in, io::di, io::uo) is det.
:- pred model.solid_cube(float::in, io::di, io::uo) is det.
% model.*_sphere(Radius, Slices, Stacks, !IO).
% `Slices' is the number of subdivisions around the z-axis.
% `Stacks' is the number of subdivisions along the z-axis.
%
:- pred model.wire_sphere(float::in, int::in, int::in, io::di, io::uo) is det.
:- pred model.solid_sphere(float::in, int::in, int::in, io::di, io::uo) is det.
% model.*_torus(Inner, Outer, Sides, Rings, !IO).
% `Inner' is the inner radius of the torus.
% `Outer' is the outer radius of the torus.
% `Sides' is the number of sides for each radial section.
% `Rings' is the number of radial divisions for the torus.
%
:- pred model.wire_torus(float::in, float::in, int::in, int::in,
io::di, io::uo) is det.
:- pred model.solid_torus(float::in, float::in, int::in, int::in,
io::di, io::uo) is det.
% model.*_cone(Base, Height, Slices, Stacks, !IO).
% `Base' is the radius of the base of the cone.
% `Height' is the height of the cone.
% `Slices' is the number of subdivisions around the z-axis.
% `Stacks' is the number of subdivisions along the z-axis.
%
:- pred model.wire_cone(float::in, float::in, int::in, int::in,
io::di, io::uo) is det.
:- pred model.solid_cone(float::in, float::in, int::in, int::in,
io::di, io::uo) is det.
% model.*_teapot(Size).
% `Size' is the relative size of the teapot.
%
:- pred model.wire_teapot(float::in, io::di, io::uo) is det.
:- pred model.solid_teapot(float::in, io::di, io::uo) is det.
%
% The rest of these are fairly self-explanatory.
%
:- pred model.wire_icosahedron(io::di, io::uo) is det.
:- pred model.solid_icosahedron(io::di, io::uo) is det.
:- pred model.wire_octahedron(io::di, io::uo) is det.
:- pred model.solid_octahedron(io::di, io::uo) is det.
:- pred model.wire_tetrahedron(io::di, io::uo) is det.
:- pred model.solid_tetrahedron(io::di, io::uo) is det.
:- pred model.wire_dodecahedron(io::di, io::uo) is det.
:- pred model.solid_dodecahedron(io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- pragma foreign_decl("C", "#include <GL/glut.h>").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
glut.model.wire_cube(Size::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireCube((GLdouble) Size);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_cube(Size::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidCube((GLdouble) Size);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_sphere(Radius::in, Slices::in, Stacks::in, IO0::di,
IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireSphere((GLdouble) Radius, (GLint) Slices, (GLint) Stacks);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_sphere(Radius::in, Slices::in, Stacks::in, IO0::di,
IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidSphere((GLdouble) Radius, (GLint) Slices, (GLint) Stacks);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_torus(InRad::in, OutRad::in, Sides::in, Rings::in,
IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireTorus((GLdouble) InRad, (GLdouble) OutRad, (GLint) Sides,
(GLint) Rings);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_torus(InRad::in, OutRad::in, Sides::in, Rings::in,
IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidTorus((GLdouble) InRad, (GLdouble) OutRad, (GLint) Sides,
(GLint) Rings);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_icosahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireIcosahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_icosahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidIcosahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_octahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireOctahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_octahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidOctahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_tetrahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireTetrahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_tetrahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidTetrahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_dodecahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireDodecahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_dodecahedron(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidDodecahedron();
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_cone(Base::in, Height::in, Slices::in, Stacks::in,
IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireCone((GLdouble) Base, (GLdouble) Height, (GLint) Slices,
(GLint) Stacks);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_cone(Base::in, Height::in, Slices::in, Stacks::in,
IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidCone((GLdouble) Base, (GLdouble) Height, (GLint) Slices,
(GLint) Stacks);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.wire_teapot(Size::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutWireTeapot((GLdouble) Size);
IO = IO0;
").
:- pragma foreign_proc("C",
glut.model.solid_teapot(Size::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutSolidTeapot((GLdouble) Size);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- end_module glut.model.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% file: glut.overlay.m
% author: juliensf
%
% This module provides an interface to the GLUT overlay API.
%
%-----------------------------------------------------------------------------%
:- module glut.overlay.
:- interface.
:- import_module glut.window.
:- import_module bool, std_util.
%-----------------------------------------------------------------------------%
:- type layer ---> normal ; overlay.
% Returns `yes' of it is possible to establish an overlay for the
% current window; `no' otherwise.
%
:- pred overlay.possible(bool::out, io::di, io::uo) is det.
% Establish an overlay for the current window. Returns `ok'
% if an overlay was established or error otherwise.
%
:- pred overlay.establish(maybe_error::out, io::di, io::uo) is det.
% Establish an overlay for the current window.
% Aborts program if an overlay cannot be established.
%
:- pred overlay.unsafe_establish(io::di, io::uo) is det.
% Remove the overlay from the current window. If the current
% window does not have an overlay then this does nothing.
%
:- pred overlay.remove(io::di, io::uo) is det.
% Mark the overlay of the current window as needing to be
% redisplayed.
%
:- pred overlay.post_redisplay(io::di, io::uo) is det.
% Mark the overlay of the specified window as needing to be
% redisplayed.
%
:- pred overlay.post_redisplay(window::in, io::di, io::uo) is det.
% Change the layer in use for the current window.
%
:- pred overlay.use_layer(layer::in, maybe_error::out, io::di, io::uo) is det.
% Return the layer in use for the current window.
%
:- pred overlay.layer_in_use(layer::out, io::di, io::uo) is det.
% Shows the overlay for the current window.
%
:- pred overlay.show(io::di, io::uo) is det.
% Hides the overlay for the current window.
%
:- pred overlay.hide(io::di, io::uo) is det.
% Returns `yes' if the normal plane of the current window
% has been damaged since the last display callback.
%
:- pred overlay.normal_damaged(bool::out, io::di, io::uo) is det.
% Returns `no' if the current window has no overlay.
% Otherwise returns `yes(IsDamaged)' where `IsDamaged'
% is the status of the current window's overlay since the
% last display callback.
%
:- pred overlay.overlay_damaged(maybe(bool)::out, io::di, io::uo) is det.
% Returns `no' if the current window has no overlay.
% Otherwise returns `yes(Index)' where `Index' is the
% transparent color index for the overlay of the current window.
%
:- pred overlay.transparent_index(maybe(int)::out, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- pragma foreign_decl("C", "#include <GL/glut.h>").
:- pragma foreign_import_module("C", bool).
%-----------------------------------------------------------------------------%
:- func glut_normal = int.
:- pragma foreign_proc("C",
glut_normal = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_NORMAL;
").
:- func glut_overlay = int.
:- pragma foreign_proc("C",
glut_overlay = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
Value = (MR_Integer) GLUT_OVERLAY;
").
:- func layer_to_int(layer) = int.
layer_to_int(normal) = glut_normal.
layer_to_int(overlay) = glut_overlay.
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.possible(Result::out, IO0::di, IO::uo),
[may_call_mercury, promise_pure, terminates],
"
if (glutLayerGet(GLUT_OVERLAY_POSSIBLE)) {
Result = ML_bool_return_yes();
} else {
Result = ML_bool_return_no();
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
overlay.establish(Result, !IO) :-
overlay.establish_2(Result0, !IO),
Result = ( Result0 = 1 -> ok ; error("Unable to establish overlay.") ).
:- pred overlay.establish_2(int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
overlay.establish_2(Result::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
if (glutLayerGet(GLUT_OVERLAY_POSSIBLE)) {
glutEstablishOverlay();
Result = 1;
} else {
Result = 0;
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.unsafe_establish(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutEstablishOverlay();
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.remove(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutRemoveOverlay();
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.post_redisplay(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutPostOverlayRedisplay();
IO = IO0;
").
:- pragma foreign_proc("C",
overlay.post_redisplay(Window::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutPostWindowOverlayRedisplay((int) Window);
IO = IO0;
").
%-----------------------------------------------------------------------------%
overlay.use_layer(Layer, Result, !IO) :-
overlay.use_layer_2(layer_to_int(Layer), Result0, !IO),
( Result0 = 1 -> Result = ok
; Result0 = 0 -> Result = error("Unable to change layer.")
; error("Unknown result from layer change.")
).
:- pred overlay.use_layer_2(int::in, int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
overlay.use_layer_2(Layer::in, Result::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
if ((GLenum) Layer == GLUT_NORMAL) {
glutUseLayer(GLUT_NORMAL);
Result = 1;
} else {
if (glutLayerGet(GLUT_HAS_OVERLAY)) {
glutUseLayer(GLUT_OVERLAY);
Result = 1;
} else {
Result = 0;
}
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
overlay.layer_in_use(Layer, !IO) :-
overlay.layer_in_use_2(Layer0, !IO),
( Layer0 = glut_normal -> Layer = normal
; Layer0 = glut_overlay -> Layer = overlay
; error("Unable to determine which layer is in use.")
).
:- pred overlay.layer_in_use_2(int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
overlay.layer_in_use_2(Layer::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Layer = (MR_Integer) glutLayerGet(GLUT_LAYER_IN_USE);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.show(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutShowOverlay();
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.hide(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
glutHideOverlay();
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
overlay.normal_damaged(Result::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
if (glutLayerGet(GLUT_NORMAL_DAMAGED)) {
Result = ML_bool_return_yes();
} else {
Result = ML_bool_return_no();
}
IO = IO0;
").
overlay.overlay_damaged(Result, !IO) :-
overlay.overlay_damaged_2(Result0, !IO),
( Result0 = 0 -> Result = no
; Result0 = 1 -> Result = yes(no)
; Result0 = 2 -> Result = yes(yes)
; error("Uknown value returned from overlay.overlay_damaged_2/3.")
).
% Returns `0' if there is no overlay
% `1' if the overlay is undamaged
% `2' if the overlay is damaged
%
:- pred overlay.overlay_damaged_2(int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
overlay.overlay_damaged_2(Result::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
MR_Integer r;
r = glutLayerGet(GLUT_OVERLAY_DAMAGED);
if (r == -1) {
Result = 0;
} else if (r == 0) {
Result = 1;
} else {
Result = 2;
}
IO = IO0;
").
%-----------------------------------------------------------------------------%
overlay.transparent_index(MaybeIndex, !IO) :-
overlay.transparent_index_2(Result, !IO),
( Result = -1 -> MaybeIndex = no
; Result >= 0 -> MaybeIndex = yes(Result)
; error("Unknown value returned from overlay.tranparent_index_2/3.")
).
:- pred overlay.transparent_index_2(int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
overlay.transparent_index_2(Index::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure],
"
Index = (MR_Integer) glutLayerGet(GLUT_TRANSPARENT_INDEX);
IO = IO0;
").
%-----------------------------------------------------------------------------%
:- end_module glut.overlay.
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list