mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-14 13:23:53 +00:00
Code Issues Projects Releases Wiki Activity

Use foreign enumerations in (most of) the GLUT binding.

Browse Source 
Estimated hours taken: 1
Branches: main

Use foreign enumerations in (most of) the GLUT binding.
This reduces the lines of source code by approx. 13%.

extras/graphics/mercury_glut/glut.m:
extras/graphics/mercury_glut/glut.callback.m:
extras/graphics/mercury_glut/glut.color_map.m:
extras/graphics/mercury_glut/glut.font.m:
extras/graphics/mercury_glut/glut.overlay.m:
extras/graphics/mercury_glut/glut.window.m:
	Use foreign enumerations to translate between Mercury and C
	enumerations.

	Add some missing `tabled_for_io' attributes.

	Add a `can_pass_as_mercury_type' attribute to a foreign type.
This commit is contained in:
Julien Fischer
2007-08-31 08:43:05 +00:00
parent c48874173c
commit ed04c9a0c8
6 changed files with 150 additions and 609 deletions
Download Patch File Download Diff File Expand all files Collapse all files

356
extras/graphics/mercury_glut/glut.callback.m
View File

@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et % vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% Copyright (C) 2004-2006 The University of Melbourne. % Copyright (C) 2004-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General % This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution. % Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -56,9 +56,14 @@
% %
:- pred callback.disable_keyboard_func(io::di, io::uo) is det. :- pred callback.disable_keyboard_func(io::di, io::uo) is det.
:- type button ---> left ; middle ; right. :- type button
---> left
; middle
; right.
:- type button_state ---> up ; down. :- type button_state
---> up
; down.
% Registers the mouse callback for the current window. % Registers the mouse callback for the current window.
% This is called whenever the state of one of the mouse buttons % This is called whenever the state of one of the mouse buttons
@@ -100,7 +105,9 @@
% %
:- pred callback.disable_passive_motion_func(io::di, io::uo) is det. :- pred callback.disable_passive_motion_func(io::di, io::uo) is det.
:- type entry_state ---> left ; entered. :- type entry_state
---> left
; entered.
% Registers the entry callback for the current window. % Registers the entry callback for the current window.
% This is called whenever the mouse pointer enters/leaves the % This is called whenever the mouse pointer enters/leaves the
@@ -113,7 +120,9 @@
% %
:- pred callback.disable_entry_func(io::di, io::uo) is det. :- pred callback.disable_entry_func(io::di, io::uo) is det.
:- type visibility ---> visible ; not_visible. :- type visibility
---> visible
; not_visible.
% Register the visibility callback for the current window. % Register the visibility callback for the current window.
% This visibility callback is whenever the visibility of a % This visibility callback is whenever the visibility of a
@@ -433,54 +442,30 @@ void MGLUT_mouse_callback(int button, int state, int x, int y)
in, in, in, in, di, uo), in, in, in, in, di, uo),
"MGLUT_do_mouse_callback"). "MGLUT_do_mouse_callback").
:- pred do_mouse_callback(pred(button, button_state, int, int, io, io), :- pred do_mouse_callback(pred(button, button_state, int, int, io, io),
int, int, int, int, io, io). button, button_state, int, int, io, io).
:- mode do_mouse_callback(pred(in, in, in, in, di, uo) is det, in, in, in, :- mode do_mouse_callback(pred(in, in, in, in, di, uo) is det, in, in, in,
in, di, uo) is det. in, di, uo) is det.
do_mouse_callback(MouseFunc, Button0, State0, X, Y, !IO) :- do_mouse_callback(MouseFunc, Button, ButtonState, X, Y, !IO) :-
( if Button0 = glut_left_button then Button = left MouseFunc(Button, ButtonState, X, Y, !IO).
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_enum("C", button/0,
:- pragma foreign_proc("C", glut_left_button = (V::out), [
[will_not_call_mercury, promise_pure, thread_safe], " left - "GLUT_LEFT_BUTTON",
V = (MR_Integer) GLUT_LEFT_BUTTON; middle - "GLUT_MIDDLE_BUTTON",
"). right - "GLUT_RIGHT_BUTTON"
]).
:- func glut_middle_button = int. :- pragma foreign_enum("C", button_state/0,
:- pragma foreign_proc("C", glut_middle_button = (V::out), [
[will_not_call_mercury, promise_pure, thread_safe], " up - "GLUT_UP",
V = (MR_Integer) GLUT_MIDDLE_BUTTON; down - "GLUT_DOWN"
"). ]).
:- func glut_right_button = int. :- pragma foreign_proc("C",
:- pragma foreign_proc("C", glut_right_button = (V::out), disable_mouse_func(IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, thread_safe], " [will_not_call_mercury, promise_pure, tabled_for_io],
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); glutMouseFunc(NULL);
IO = IO0; IO = IO0;
"). ").
@@ -585,15 +570,11 @@ void MGLUT_entry_callback(int state)
:- pragma foreign_export("C", :- pragma foreign_export("C",
do_entry_callback(pred(in, di, uo) is det, in, di, uo), do_entry_callback(pred(in, di, uo) is det, in, di, uo),
"MGLUT_do_entry_callback"). "MGLUT_do_entry_callback").
:- pred do_entry_callback(pred(entry_state, io, io), int, io, io). :- pred do_entry_callback(pred(entry_state, io, io), entry_state, io, io).
:- mode do_entry_callback(pred(in, di, uo) is det, in, di, uo) is det. :- mode do_entry_callback(pred(in, di, uo) is det, in, di, uo) is det.
do_entry_callback(EntryFunc, State0, !IO) :- do_entry_callback(EntryFunc, EntryState, !IO) :-
( if State0 = glut_left then State = left EntryFunc(EntryState, !IO).
else if State0 = glut_entered then State = entered
else error("Unable to determine entry state.")
),
EntryFunc(State, !IO).
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
disable_entry_func(IO0::di, IO::uo), disable_entry_func(IO0::di, IO::uo),
@@ -603,26 +584,18 @@ do_entry_callback(EntryFunc, State0, !IO) :-
IO = IO0; IO = IO0;
"). ").
:- func glut_left = int. :- pragma foreign_enum("C", entry_state/0,
:- pragma foreign_proc("C", glut_left = (Value::out), [
[will_not_call_mercury, promise_pure], left - "GLUT_LEFT",
" entered - "GLUT_ENTERED"
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", :- pragma foreign_proc("C",
visibility_func(VisibilityFunc::pred(in, di, uo) is det, IO0::di, visibility_func(VisibilityFunc::pred(in, di, uo) is det, IO0::di,
IO::uo), IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],
" "
mglut_visibility_callback = VisibilityFunc; mglut_visibility_callback = VisibilityFunc;
glutVisibilityFunc(MGLUT_visibility_callback); glutVisibilityFunc(MGLUT_visibility_callback);
@@ -638,37 +611,25 @@ void MGLUT_visibility_callback(int state)
:- pragma foreign_export("C", :- pragma foreign_export("C",
do_visibility_callback(pred(in, di, uo) is det, in, di, uo), do_visibility_callback(pred(in, di, uo) is det, in, di, uo),
"MGLUT_do_visibility_callback"). "MGLUT_do_visibility_callback").
:- pred do_visibility_callback(pred(visibility, io, io), int, io, io). :- pred do_visibility_callback(pred(visibility, io, io), visibility, io, io).
:- mode do_visibility_callback(pred(in, di, uo) is det, in, di, uo) is det. :- mode do_visibility_callback(pred(in, di, uo) is det, in, di, uo) is det.
do_visibility_callback(VisibilityFunc, State0, !IO) :- do_visibility_callback(VisibilityFunc, Visibility, !IO) :-
( if State0 = glut_visible then State = visible VisibilityFunc(Visibility, !IO).
else if State0 = glut_not_visible then State = not_visible
else error("Unable to determine visibility.")
),
VisibilityFunc(State, !IO).
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
disable_visibility_func(IO0::di, IO::uo), disable_visibility_func(IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure, tabled_for_io],
" "
glutVisibilityFunc(NULL); glutVisibilityFunc(NULL);
IO = IO0; IO = IO0;
"). ").
:- func glut_visible = int. :- pragma foreign_enum("C", visibility/0,
:- pragma foreign_proc("C", glut_visible = (Value::out), [
[will_not_call_mercury, promise_pure, thread_safe], visible - "GLUT_VISIBLE",
" not_visible - "GLUT_NOT_VISIBLE"
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;
").
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% %
@@ -677,7 +638,7 @@ do_visibility_callback(VisibilityFunc, State0, !IO) :-
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
idle_func(Closure::pred(di, uo) is det, IO0::di, IO::uo), idle_func(Closure::pred(di, uo) is det, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure, tabled_for_io],
" "
mglut_idle_callback = Closure; mglut_idle_callback = Closure;
glutIdleFunc(MGLUT_idle_callback); glutIdleFunc(MGLUT_idle_callback);
@@ -700,7 +661,7 @@ do_idle_callback(IdleFunc, !IO) :- IdleFunc(!IO).
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
disable_idle_func(IO0::di, IO::uo), disable_idle_func(IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure, tabled_for_io],
" "
glutIdleFunc(NULL); glutIdleFunc(NULL);
IO = IO0; IO = IO0;
@@ -813,12 +774,12 @@ void MGLUT_special_callback(int key, int x, int y)
in, in, in, di, uo), in, in, in, di, uo),
"MGLUT_do_special_callback"). "MGLUT_do_special_callback").
:- pred do_special_callback(pred(special_key, int, int, io, io), :- pred do_special_callback(pred(special_key, int, int, io, io),
int, int, int, io, io). special_key, int, int, io, io).
:- mode do_special_callback(pred(in,in,in,di,uo) is det, in, in, in, di, uo) :- mode do_special_callback(pred(in, in, in, di, uo) is det,
is det. in, in, in, di, uo) is det.
do_special_callback(Special, Key, X, Y, !IO) :- do_special_callback(Special, Key, X, Y, !IO) :-
Special(int_to_special_key(Key), X, Y, !IO). Special(Key, X, Y, !IO).
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
callback.disable_special_func(IO0::di, IO::uo), callback.disable_special_func(IO0::di, IO::uo),
@@ -855,12 +816,12 @@ void MGLUT_special_up_callback(int key, int x, int y)
in, in, in, di, uo), in, in, in, di, uo),
"MGLUT_do_special_up_callback"). "MGLUT_do_special_up_callback").
:- pred do_special_up_callback(pred(special_key, int, int, io, io), :- pred do_special_up_callback(pred(special_key, int, int, io, io),
int, int, int, io, io). special_key, int, int, io, io).
:- mode do_special_up_callback(pred(in,in,in,di,uo) is det, in, in, in, di, uo) :- mode do_special_up_callback(pred(in,in,in,di,uo) is det, in, in, in, di, uo)
is det. is det.
do_special_up_callback(SpecialUpFunc, Key, X, Y, !IO) :- do_special_up_callback(SpecialUpFunc, Key, X, Y, !IO) :-
SpecialUpFunc(int_to_special_key(Key), X, Y, !IO). SpecialUpFunc(Key, X, Y, !IO).
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
callback.disable_special_up_func(IO0::di, IO::uo), callback.disable_special_up_func(IO0::di, IO::uo),
@@ -871,184 +832,31 @@ do_special_up_callback(SpecialUpFunc, Key, X, Y, !IO) :-
"). ").
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
%
% Constants for special keyboard callbacks
%
:- func int_to_special_key(int) = special_key. :- pragma foreign_enum("C", special_key/0,
[
int_to_special_key(KeyCode) = Key :- f1 - "GLUT_KEY_F1",
( if KeyCode = glut_key_f1 then Key = f1 f2 - "GLUT_KEY_F2",
else if KeyCode = glut_key_f2 then Key = f2 f3 - "GLUT_KEY_F3",
else if KeyCode = glut_key_f3 then Key = f3 f4 - "GLUT_KEY_F4",
else if KeyCode = glut_key_f4 then Key = f4 f5 - "GLUT_KEY_F5",
else if KeyCode = glut_key_f5 then Key = f5 f6 - "GLUT_KEY_F6",
else if KeyCode = glut_key_f6 then Key = f6 f7 - "GLUT_KEY_F7",
else if KeyCode = glut_key_f7 then Key = f7 f8 - "GLUT_KEY_F8",
else if KeyCode = glut_key_f8 then Key = f8 f9 - "GLUT_KEY_F9",
else if KeyCode = glut_key_f9 then Key = f9 f10 - "GLUT_KEY_F10",
else if KeyCode = glut_key_f10 then Key = f10 f11 - "GLUT_KEY_F11",
else if KeyCode = glut_key_f11 then Key = f11 f12 - "GLUT_KEY_F12",
else if KeyCode = glut_key_f12 then Key = f12 left - "GLUT_KEY_LEFT",
else if KeyCode = glut_key_left then Key = left up - "GLUT_KEY_UP",
else if KeyCode = glut_key_up then Key = up right - "GLUT_KEY_RIGHT",
else if KeyCode = glut_key_right then Key = right down - "GLUT_KEY_DOWN",
else if KeyCode = glut_key_down then Key = down page_up - "GLUT_KEY_PAGE_UP",
else if KeyCode = glut_key_page_up then Key = page_up page_down - "GLUT_KEY_PAGE_DOWN",
else if KeyCode = glut_key_page_down then Key = page_down home - "GLUT_KEY_HOME",
else if KeyCode = glut_key_home then Key = home end - "GLUT_KEY_END",
else if KeyCode = glut_key_end then Key = end insert - "GLUT_KEY_INSERT"
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. :- end_module glut.callback.

40
extras/graphics/mercury_glut/glut.color_map.m
View File

@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et % vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% Copyright (C) 2004-2006 The University of Melbourne. % Copyright (C) 2004-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General % This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution. % Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -70,44 +70,20 @@
IO = IO0; 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", :- pragma foreign_proc("C",
get_color_2(I::in, C::in, V::out, IO0::di, IO::uo), get_color(I::in, C::in, V::out, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],
" "
V = (MR_Float) glutGetColor((int) I, (int) C); V = (MR_Float) glutGetColor((int) I, (int) C);
IO = IO0; IO = IO0;
"). ").
:- func component_to_int(component) = int. :- pragma foreign_enum("C", component/0,
[
component_to_int(red) = glut_red. red - "GLUT_RED",
component_to_int(green) = glut_green. green - "GLUT_GREEN",
component_to_int(blue) = glut_blue. 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;
").
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%

4
extras/graphics/mercury_glut/glut.font.m
View File

@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et % vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% Copyright (C) 2004-2006 The University of Melbourne. % Copyright (C) 2004-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General % This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution. % Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -87,7 +87,7 @@
"). ").
:- type font_ptr. :- type font_ptr.
:- pragma foreign_type("C", font_ptr, "void *"). :- pragma foreign_type("C", font_ptr, "void *", [can_pass_as_mercury_type]).
%----------------------------------------------------------------------------% %----------------------------------------------------------------------------%
% %

134
extras/graphics/mercury_glut/glut.m
View File

@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et % vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% Copyright (C) 2004-2006 The University of Melbourne. % Copyright (C) 2004-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General % This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution. % Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -335,77 +335,38 @@ display_mode_to_int(luminance) = glut_luminance.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
glut.get(State, Value, !IO) :- :- pragma foreign_enum("C", glut.state/0,
glut.get_2(state_to_int(State), Value, !IO). [
screen_width - "GLUT_SCREEN_WIDTH",
screen_height - "GLUT_SCREEN_HEIGHT",
screen_width_mm - "GLUT_SCREEN_WIDTH_MM",
screen_height_mm - "GLUT_SCREEN_HEIGHT_MM",
init_window_x - "GLUT_INIT_WINDOW_X",
init_window_y - "GLUT_INIT_WINDOW_Y"
]).
:- pred glut.get_2(int::in, int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
glut.get_2(State::in, Value::out, IO0::di, IO::uo), glut.get(State::in, Value::out, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],
" "
Value = (MR_Integer) glutGet((GLenum) State); Value = (MR_Integer) glutGet((GLenum) State);
IO = IO0; 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) :- :- pragma foreign_enum("C", glut.device/0,
glut.has_device_2(device_to_int(Device), Result, !IO). [
keyboard - "GLUT_HAS_KEYBOARD",
mouse - "GLUT_HAS_MOUSE",
spaceball - "GLUT_HAS_SPACEBALL",
dial_and_button_box - "GLUT_HAS_DIAL_AND_BUTTON_BOX",
tablet - "GLUT_HAS_TABLET",
joystick - "GLUT_HAS_JOYSTICK"
]).
:- pred glut.has_device_2(int::in, bool::out, io::di, io::uo) is det.
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
glut.has_device_2(Device::in, Res::out, IO0::di, IO::uo), glut.has_device(Device::in, Res::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure], [will_not_call_mercury, promise_pure],
" "
if(glutDeviceGet((GLenum) Device)) { if(glutDeviceGet((GLenum) Device)) {
@@ -416,59 +377,6 @@ glut.has_device(Device, Result, !IO) :-
IO = IO0; 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", :- pragma foreign_proc("C",

41
extras/graphics/mercury_glut/glut.overlay.m
View File

@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et % vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% Copyright (C) 2004-2006 The University of Melbourne. % Copyright (C) 2004-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General % This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution. % Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -105,26 +105,11 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
:- func glut_normal = int. :- pragma foreign_enum("C", layer/0,
:- pragma foreign_proc("C", [
glut_normal = (Value::out), normal - "GLUT_NORMAL",
[will_not_call_mercury, promise_pure, thread_safe], overlay - "GLUT_OVERLAY"
" ]).
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.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -201,13 +186,13 @@ overlay.establish(Result, !IO) :-
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
overlay.use_layer(Layer, Result, !IO) :- overlay.use_layer(Layer, Result, !IO) :-
overlay.use_layer_2(layer_to_int(Layer), Result0, !IO), overlay.use_layer_2(Layer, Result0, !IO),
( Result0 = 1 -> Result = ok ( Result0 = 1 -> Result = ok
; Result0 = 0 -> Result = error("Unable to change layer.") ; Result0 = 0 -> Result = error("Unable to change layer.")
; error("Unknown result from layer change.") ; error("Unknown result from layer change.")
). ).
:- pred overlay.use_layer_2(int::in, int::out, io::di, io::uo) is det. :- pred overlay.use_layer_2(layer::in, int::out, io::di, io::uo) is det.
:- pragma foreign_proc("C", :- pragma foreign_proc("C",
overlay.use_layer_2(Layer::in, Result::out, IO0::di, IO::uo), overlay.use_layer_2(Layer::in, Result::out, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],
@@ -228,16 +213,8 @@ overlay.use_layer(Layer, Result, !IO) :-
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
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", :- pragma foreign_proc("C",
overlay.layer_in_use_2(Layer::out, IO0::di, IO::uo), overlay.layer_in_use(Layer::out, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],
" "
Layer = (MR_Integer) glutLayerGet(GLUT_LAYER_IN_USE); Layer = (MR_Integer) glutLayerGet(GLUT_LAYER_IN_USE);

180
extras/graphics/mercury_glut/glut.window.m
View File

@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et % vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
% Copyright (C) 2004-2006 The University of Melbourne. % Copyright (C) 2004-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General % This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution. % Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
@@ -430,6 +430,9 @@ window.id(MaybeWindow, !IO) :-
IO = IO0; IO = IO0;
"). ").
% NOTE: we don't use a foreign enumeration for this type because we
% may eventually support user-defined cursors.
%
:- func cursor_to_int(cursor) = int. :- func cursor_to_int(cursor) = int.
cursor_to_int(right_arrow) = glut_cursor_right_arrow. cursor_to_int(right_arrow) = glut_cursor_right_arrow.
@@ -689,33 +692,30 @@ window.set_cursor(Cursor, !IO) :-
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
:- func window_state_to_int(window.state) = int. :- pragma foreign_enum("C", window.state/0,
[
x - "GLUT_WINDOW_X",
y - "GLUT_WINDOW_Y",
window_width - "GLUT_WINDOW_WIDTH",
window_height - "GLUT_WINDOW_HEIGHT",
buffer_size - "GLUT_WINDOW_BUFFER_SIZE",
stencil_size - "GLUT_WINDOW_STENCIL_SIZE",
depth_size - "GLUT_WINDOW_DEPTH_SIZE",
red_size - "GLUT_WINDOW_RED_SIZE",
green_size - "GLUT_WINDOW_GREEN_SIZE",
blue_size - "GLUT_WINDOW_BLUE_SIZE",
alpha_size - "GLUT_WINDOW_ALPHA_SIZE",
accum_red_size - "GLUT_WINDOW_ACCUM_RED_SIZE",
accum_green_size - "GLUT_WINDOW_ACCUM_GREEN_SIZE",
accum_blue_size - "GLUT_WINDOW_ACCUM_BLUE_SIZE",
accum_alpha_size - "GLUT_WINDOW_ACCUM_ALPHA_SIZE",
colormap_size - "GLUT_WINDOW_COLORMAP_SIZE",
number_samples - "GLUT_WINDOW_NUM_SAMPLES",
format_id - "GLUT_WINDOW_FORMAT_ID"
]).
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", :- pragma foreign_proc("C",
window.get_2(State::in, Value::out, IO0::di, IO::uo), window.get(State::in, Value::out, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],
" "
Value = (MR_Integer) glutGet((GLenum) State); Value = (MR_Integer) glutGet((GLenum) State);
@@ -724,134 +724,6 @@ window.get(State, Value, !IO) :-
%-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%
:- 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", :- pragma foreign_proc("C",
window.has_overlay(Result::out, IO0::di, IO::uo), window.has_overlay(Result::out, IO0::di, IO::uo),
[will_not_call_mercury, tabled_for_io, promise_pure], [will_not_call_mercury, tabled_for_io, promise_pure],