[m-rev.] Xlib interface for extras
Ralph Becket
rafe at cs.mu.OZ.AU
Thu Sep 23 14:15:05 AEST 2004
I've been writing a little Xlib based graphics library off and on for a
couple of months and would like to add it to extras.
Feedback gratefully received, as would be flashier applications.
-- Ralph
README:
xlib.m A very low-level Mercury wrapper around (parts of) Xlib.
easyx.m A nice little graphics library.
testeasyx.m A simple demonstration program.
moveball.m An orange ball follows the mouse pointer.
scribble.m A trivial drawing program.
bounce.m A bouncing-ball game.
easyx.m:
%-----------------------------------------------------------------------------%
% Copyright (C) 2004 The University of Melbourne.
% 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.
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
% easyx.m
% Ralph Becket <rafe at cs.mu.oz.au>
% Fri Jun 25 17:49:48 EST 2004
%
% A simple, easy-to-use wrapper around some of Xlib, good for putting
% lines and boxes on the screen and writing simple interactive graphical
% applications. This library aims for ease of use over efficiency.
%
% All drawing is done to a backing pixmap and the user must explicitly call
% easyx.flush/3 to make visible any changes since the last call to
% easyx.flush/3. Repainting after exposure events is handled automatically,
% although resizing the window does require the user to redraw.
%
% An abstract coordinate space is used, but in keeping with Xlib, the
% origin of the coordinate space is at the top-left of a window, with
% coordinates increasing down and to the right. An abstract coordinate
% value of 1.0 corresponds to the shorter of the current width or height
% of the window.
%
% Angles, where used, are measured in radians.
%
% If a deterministic predicate fails (e.g. when opening the display)
% then an exception is thrown rather than returning an error code.
%
% NOTE! This library is currently fairly unstable: users should not be
% surprised if the interface changes.
%
%-----------------------------------------------------------------------------%
:- module easyx.
:- interface.
:- import_module io.
:- import_module list.
:- import_module std_util.
:- use_module xlib.
% One must open a display in order to create a window.
%
:- type display == xlib.display_ptr.
% open_display(Display, !IO)
% Open a connection to the default display.
%
:- pred open_display(display::out, io::di, io::uo) is det.
% open_display(DisplayName, Display, !IO)
% Open a connection to the named display.
%
:- pred open_display(string::in, display::out, io::di, io::uo) is det.
% A window is a target for drawing operations and a source of
% input events (mouse and keyboard etc.)
%
:- type window.
% create_window(Display, Title, Width, Height, Orientation, Window, !IO)
% Create Window on Display, with the given Title, Width, Height and
% Orientation.
%
:- pred create_window(display::in, string::in, int::in, int::in,
window::out, io::di, io::uo) is det.
% flush(Window, !IO)
% Make all rendering to Window since the last call to flush/3 visible
% (all rendering is done to a separate drawing area; this predicate
% updates what is on the screen.)
%
:- pred flush(window::in, io::di, io::uo) is det.
% clear_window(Window, !IO)
% Clear the window using the current colour.
%
:- pred clear_window(window::in, io::di, io::uo) is det.
:- type font == xlib.font_struct_ptr.
% load_font(Window, FontName, Font, !IO)
% Load a font from the X server.
%
:- pred load_font(window::in, string::in, font::out, io::di, io::uo) is det.
% Set the font for drawing text.
%
:- pred set_font(window::in, font::in, io::di, io::uo) is det.
:- type colour == xlib.color_ptr.
% get_colour_from_name(Window, ColourName, Colour, !IO)
% Obtain the colour with the given name.
%
:- pred get_colour_from_name(window::in, string::in,
colour::out, io::di, io::uo) is det.
% get_colour_from_rgb(Window, R, G, B, Colour, !IO)
% Obtain the colour with the given RGB components (in the range
% 0.0 to 1.0), or its nearest approximation.
%
:- pred get_colour_from_rgb(window::in, float::in, float::in, float::in,
colour::out, io::di, io::uo) is det.
% set_colour(Window, Colour, !IO)
% Set the drawing colour.
%
:- pred set_colour(window::in, colour::in, io::di, io::uo) is det.
% set_colour_from_name(Window, ColourName, !IO)
% A useful shortcut.
%
:- pred set_colour_from_name(window::in, string::in, io::di, io::uo) is det.
% set_colour_from_rgb(Window, R, G, B, !IO)
% A useful shortcut.
%
:- pred set_colour_from_rgb(window::in, float::in, float::in, float::in,
io::di, io::uo) is det.
% set_text_bg_colour(Window, Colour, !IO)
% Sets the colour draw_image_text will use for the text background.
%
:- pred set_text_bg_colour(window::in, colour::in, io::di, io::uo) is det.
% Line widths can be given in pixels or abstract units.
%
:- type line_width
---> pixels(int)
; ratio(float).
% Line ends may be capped in several ways.
%
:- type cap_style
---> not_last
; butt
; round
; projecting.
% Joins between lines may be rendered in several ways.
%
:- type join_style
---> mitre
; round
; bevel.
% Line sequences and filled polygons are defined as sequences of
% {X, Y} coordinates.
%
:- type coords == list({float, float}).
% set_line_attributes(Window, LineWidth, CapStyle, JoinStyle, !IO)
% Set the line drawing attributes.
%
:- pred set_line_attributes(window::in, line_width::in, cap_style::in,
join_style::in, io::di, io::uo) is det.
% draw_text(Window, X, Y, JX, JY, String, !IO)
% Draw text String justified as follows: if the rendered text will
% occupy W width and H height, then the top left corner of the rendered
% text will appear at {X - JX * W, Y - JY * H}.
%
% The text is drawn without a background.
%
% Note that Xlib does not support rotated/scaled/distorted text.
%
:- pred draw_text(window::in, float::in, float::in, float::in, float::in,
string::in, io::di, io::uo) is det.
% draw_image_text(Window, X, Y, JX, JY, String, !IO)
% As draw_text, but the text appears on a filled rectangle
% (see set_text_bg_colour).
%
:- pred draw_image_text(window::in, float::in, float::in, float::in, float::in,
string::in, io::di, io::uo) is det.
% draw_text(Window, X, Y, String, !IO)
% draw_image_text(Window, X, Y, String, !IO)
% As their counterparts with justification arguments, but with
% JX = JY = 0.0.
%
:- pred draw_text(window::in, float::in, float::in, string::in,
io::di, io::uo) is det.
:- pred draw_image_text(window::in, float::in, float::in, string::in,
io::di, io::uo) is det.
% draw_line(Window, X1, Y1, X2, Y2, !IO)
% Draw a line from {X1, Y1} to {X2, Y2}.
%
:- pred draw_line(window::in, float::in, float::in, float::in, float::in,
io::di, io::uo) is det.
% draw_arc(Window, X, Y, RX, RY, StartAngle, ThroughAngle, !IO)
% fill_arc(Window, X, Y, RX, RY, StartAngle, ThroughAngle, !IO)
% Draw/fill an arc of an ellipse centred at {X, Y} with radii RX and RY,
% starting at StartAngle and passing through ThroughAngle.
%
:- pred draw_arc(window::in, float::in, float::in, float::in, float::in,
float::in, float::in, io::di, io::uo) is det.
:- pred fill_arc(window::in, float::in, float::in, float::in, float::in,
float::in, float::in, io::di, io::uo) is det.
% draw_circle(Window, X, Y, R, !IO)
% fill_circle(Window, X, Y, R, !IO)
% Draw/fill a circle at {X, Y} with radius R.
%
:- pred draw_circle(window::in, float::in, float::in, float::in,
io::di, io::uo) is det.
:- pred fill_circle(window::in, float::in, float::in, float::in,
io::di, io::uo) is det.
% draw_ellipse(Window, X, Y, RX, RY, !IO)
% fill_ellipse(Window, X, Y, RX, RY, !IO)
% Draw/fill an ellipse at {X, Y} with radii RX and RY.
%
:- pred draw_ellipse(window::in, float::in, float::in, float::in, float::in,
io::di, io::uo) is det.
:- pred fill_ellipse(window::in, float::in, float::in, float::in, float::in,
io::di, io::uo) is det.
% draw_rectangle(Window, X1, Y1, X2, Y2, !IO)
% fill_rectangle(Window, X1, Y1, X2, Y2, !IO)
% Draw/fill a rectangle with opposite corners at {X1, Y1} and {X2, Y2}.
%
:- pred draw_rectangle(window::in, float::in, float::in, float::in, float::in,
io::di, io::uo) is det.
:- pred fill_rectangle(window::in, float::in, float::in, float::in, float::in,
io::di, io::uo) is det.
% draw_lines(Window, Coords, !IO)
% Draw a series of lines connecting each coordinate to its successor.
%
:- pred draw_lines(window::in, coords::in, io::di, io::uo) is det.
% fill_polygon(Window, Coords, !IO)
% Fill the polygon whose vertices are given in order by Coords.
%
:- pred fill_polygon(window::in, coords::in, io::di, io::uo) is det.
% Support the construction of abstract drawing "programs". Drawings
% can be rotated, translated, scaled and mirrored.
%
% XXX At present, not all operations affect all drawing primitives.
% For instance, text neither rotates nor scales, nor do the angles
% of arcs.
%
:- type drawing_instruction
---> colour(colour)
; colour_from_name(string)
; colour_from_rgb(float, float, float)
; line_attributes(line_width, cap_style, join_style)
; font(font)
; font_from_name(string)
; line(float, float, float, float)
; rectangle(float, float, float, float)
; filled_rectangle(float, float, float, float)
; arc(float, float, float, float, float, float)
; filled_arc(float, float, float, float, float, float)
; circle(float, float, float)
; filled_circle(float, float, float)
; ellipse(float, float, float, float)
; filled_ellipse(float, float, float, float)
; lines(coords)
; filled_polygon(coords)
; text(float, float, float, float, string)
; image_text(float, float, float, float, string)
; text(float, float, string)
; image_text(float, float, string)
; translate(float, float, drawing)
; scale(float, drawing)
; scale(float, float, drawing)
; rotate(float, drawing)
; mirror_x(drawing)
; mirror_y(drawing).
:- type drawing == list(drawing_instruction).
% draw(Window, Drawing, !IO)
% Draw Drawing in Window!
%
:- pred draw(window::in, drawing::in, io::di, io::uo) is det.
% A restricted set of X events are recognised by this library.
%
:- type event
% Something has occurred (such as the window being resized)
% that requires the window contents to be redrawn.
---> expose
% button_press(X, Y, State, ButtonNo)
% A mouse button has been pressed. The mouse pointer
% is at {X, Y}, State can be interrogated to see which
% other mouse buttons and modifier keys (shift, control,
% caps lock) are currently depressed. ButtonNo is the
% number of the mouse button that caused this event.
; button_press(float, float, buttons_and_modifiers, button)
% button_release(X, Y, State, ButtonNo)
% As button_press, but indicates that a mouse button has
% been released.
; button_release(float, float, buttons_and_modifiers, button)
% key_press(X, Y, State, KeyName)
% A key has been pressed. The mouse pointer is at {X, Y},
% State indicates which mouse buttons and modifier keys are
% currently depressed, and KeyName is a string indicating
% which key caused this event. (If the shift key is held
% down when the key is pressed and the given key has a
% shifted symbol, then KeyName is the name of the shifted key
% symbol.)
%
; key_press(float, float, buttons_and_modifiers, string)
% key_release(X, Y, State, KeyName)
% As key_press, but indicated that a key has been released.
; key_release(float, float, buttons_and_modifiers, string)
% pointer_motion(X, Y, State)
% The mouse pointer has moved to {X, Y}. State indicates
% which mouse buttons and modifier keys are currently
% depressed.
; pointer_motion(float, float, buttons_and_modifiers).
:- type buttons_and_modifiers == xlib.buttons_and_modifiers.
% The left hand mouse button is usually number 1.
%
:- type button == int.
% get_next_event(Window, Event, !IO)
% Wait for the next input Event from the Window.
%
:- pred get_next_event(window::in, event::out, io::di, io::uo) is det.
% get_next_event_if_any(Window, MaybeEvent, !IO)
% Get the next input event from the Window if one is available.
%
:- pred get_next_event_if_any(window::in, maybe(event)::out, io::di, io::uo)
is det.
% Examine the State value of an event.
%
:- pred button1(buttons_and_modifiers::in) is semidet.
:- pred button2(buttons_and_modifiers::in) is semidet.
:- pred button3(buttons_and_modifiers::in) is semidet.
:- pred button4(buttons_and_modifiers::in) is semidet.
:- pred button5(buttons_and_modifiers::in) is semidet.
:- pred shift(buttons_and_modifiers::in) is semidet.
:- pred lock(buttons_and_modifiers::in) is semidet.
:- pred control(buttons_and_modifiers::in) is semidet.
:- pred mod1(buttons_and_modifiers::in) is semidet.
:- pred mod2(buttons_and_modifiers::in) is semidet.
:- pred mod3(buttons_and_modifiers::in) is semidet.
:- pred mod4(buttons_and_modifiers::in) is semidet.
:- pred mod5(buttons_and_modifiers::in) is semidet.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module exception.
:- import_module float.
:- import_module int.
:- import_module list.
:- import_module math.
:- import_module store.
:- import_module string.
:- type window
---> window(
display :: io_mutvar(display),
raw_window :: io_mutvar(raw_window),
pixmap :: io_mutvar(pixmap),
width :: io_mutvar(int),
height :: io_mutvar(int),
gc :: io_mutvar(gc),
gc_values_ptr :: io_mutvar(gc_values_ptr),
maybe_font :: io_mutvar(maybe(font)),
scaling_factor :: io_mutvar(float)
).
% Abstract types for various quantities.
%
:- type raw_window == xlib.drawable.
:- type pixmap == xlib.drawable.
:- type gc == xlib.gc.
:- type gc_values_ptr == xlib.gc_values_ptr.
:- type value_mask == xlib.value_mask.
:- type xpoints == xlib.xpoints.
%-----------------------------------------------------------------------------%
:- pred set_window_size(window::in, int::in, int::in, io::di, io::uo) is det.
:- pragma promise_pure(set_window_size/5).
set_window_size(Window, PW0, PH0, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^pixmap, OldPix, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^width, OldPW, !IO),
store.get_mutvar(Window^height, OldPH, !IO),
PW = max(1, PW0),
PH = max(1, PH0),
( if ( PW >= OldPW ; PH >= OldPH ) then
( if
impure xlib.free_pixmap(Display, OldPix),
impure NewPix = xlib.create_matching_pixmap(Display, Win)
then
store.set_mutvar(Window^pixmap, NewPix, !IO),
Pix = NewPix
else
error("set_window_size(Window, %d, %d, !IO)", [i(PW0), i(PH0)])
)
else
Pix = OldPix
),
impure xlib.fill_rectangle(Display, Pix, GC, 0, 0, PW, PH),
store.set_mutvar(Window^width, PW, !IO),
store.set_mutvar(Window^height, PH, !IO),
set_window_scaling_factor(Window, !IO).
:- pred set_window_scaling_factor(window::in, io::di, io::uo) is det.
set_window_scaling_factor(Window, !IO) :-
store.get_mutvar(Window^width, PW, !IO),
store.get_mutvar(Window^height, PH, !IO),
store.set_mutvar(Window^scaling_factor, float(min(PW, PH)), !IO).
%-----------------------------------------------------------------------------%
:- pred to_pixels(window::in, float::in, int::out, float::in, int::out,
io::di, io::uo) is det.
to_pixels(Window, A, PA, B, PB, !IO) :-
store.get_mutvar(Window^scaling_factor, ScalingFactor, !IO),
PA = truncate_to_int(A * ScalingFactor),
PB = truncate_to_int(B * ScalingFactor).
:- pred to_pixels(window::in,
float::in, int::out,
float::in, int::out,
float::in, int::out,
float::in, int::out,
io::di, io::uo) is det.
to_pixels(Window, A, PA, B, PB, C, PC, D, PD, !IO) :-
store.get_mutvar(Window^scaling_factor, ScalingFactor, !IO),
PA = truncate_to_int(A * ScalingFactor),
PB = truncate_to_int(B * ScalingFactor),
PC = truncate_to_int(C * ScalingFactor),
PD = truncate_to_int(D * ScalingFactor).
:- pred to_ratios(window::in, int::in, float::out, int::in, float::out,
io::di, io::uo) is det.
to_ratios(Window, PA, A, PB, B, !IO) :-
store.get_mutvar(Window^scaling_factor, ScalingFactor, !IO),
A = float(PA) / ScalingFactor,
B = float(PB) / ScalingFactor.
:- func a(float) = int.
a(Angle) = truncate_to_int(Angle * (180.0 * 64.0 / pi)).
:- func rgb_int(float) = int.
rgb_int(RGB) = truncate_to_int(65535.0 * RGB).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(open_display/3).
open_display(Display, !IO) :-
( if impure Display0 = xlib.open_display
then Display = Display0
else error("open_display(Display, !IO)", [])
).
:- pragma promise_pure(open_display/4).
open_display(DisplayName, Display, !IO) :-
( if impure Display0 = xlib.open_display(DisplayName)
then Display = Display0
else error("open_display(%s, Display, !IO)", [s(DisplayName)])
).
:- pragma promise_pure(flush/3).
flush(Window, !IO) :-
restore_from_backing_pixmap(Window, !IO),
store.get_mutvar(Window^display, Display, !IO),
impure xlib.flush(Display).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(create_window/7).
create_window(Display, WindowTitle, PW, PH, Window, !IO) :-
( if
impure Win = xlib.create_simple_window(Display, PW, PH),
impure Pix = xlib.create_matching_pixmap(Display, Win),
impure xlib.set_window_name(Display, Win, WindowTitle),
impure xlib.map_raised(Display, Win),
GCValuesPtr = xlib.new_gc_values_ptr,
impure GC = xlib.create_gc(Display, Win, 0, GCValuesPtr),
impure xlib.sync(Display)
then
store.new_mutvar(Display, DisplayMutvar, !IO),
store.new_mutvar(Win, WinMutvar, !IO),
store.new_mutvar(Pix, PixMutvar, !IO),
store.new_mutvar(0, WMutvar, !IO),
store.new_mutvar(0, HMutvar, !IO),
store.new_mutvar(GC, GCMutvar, !IO),
store.new_mutvar(GCValuesPtr, GCValuesPtrMutvar, !IO),
store.new_mutvar(no, MaybeFontMutvar, !IO),
store.new_mutvar(0.0, ScalingFactorMutvar, !IO),
Window = window(DisplayMutvar, WinMutvar, PixMutvar,
WMutvar, HMutvar, GCMutvar, GCValuesPtrMutvar,
MaybeFontMutvar, ScalingFactorMutvar),
set_window_size(Window, PW, PH, !IO)
else
error("create_window(Display, \"%s\", %d, %d, Window, !IO)",
[s(WindowTitle), i(PW), i(PH)])
).
:- pragma promise_pure(clear_window/3).
clear_window(Window, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^width, PW, !IO),
store.get_mutvar(Window^height, PH, !IO),
impure xlib.fill_rectangle(Display, Pix, GC, 0, 0, PW, PH).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(load_font/5).
load_font(Window, FontName, Font, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
( if impure Font0 = xlib.load_query_font(Display, FontName)
then Font = Font0
else error("load_font(Window, \"%s\", Font, !IO)",
[s(FontName)])
).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(get_colour_from_name/5).
get_colour_from_name(Window, ColourName, Colour, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
( if impure Colour0 = xlib.alloc_named_color(Display, ColourName)
then Colour = Colour0
else error("get_colour_from_name(Window, \"%s\", Colour, !IO)",
[s(ColourName)])
).
:- pragma promise_pure(get_colour_from_rgb/7).
get_colour_from_rgb(Window, R, G, B, Colour, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
( if impure Colour0 = xlib.alloc_rgb_color(Display,
rgb_int(R), rgb_int(G), rgb_int(B))
then Colour = Colour0
else error("get_colour_from_rgb(Display, %4.2f, %4.2f, %4.2f, " ++
"Colour, !IO)", [f(R), f(G), f(B)])
).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(set_colour/4).
set_colour(Window, Colour, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^gc, GC, !IO),
impure xlib.set_fg(Display, GC, Colour).
set_colour_from_name(Window, ColourName, !IO) :-
get_colour_from_name(Window, ColourName, Colour, !IO),
set_colour(Window, Colour, !IO).
set_colour_from_rgb(Window, R, G, B, !IO) :-
get_colour_from_rgb(Window, R, G, B, Colour, !IO),
set_colour(Window, Colour, !IO).
:- pragma promise_pure(set_text_bg_colour/4).
set_text_bg_colour(Window, Colour, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^gc, GC, !IO),
impure xlib.set_bg(Display, GC, Colour).
:- pragma promise_pure(set_line_attributes/6).
set_line_attributes(Window, LineWidth, CapStyle, JoinStyle, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^gc, GC, !IO),
(
LineWidth = pixels(PW0)
;
LineWidth = ratio(W),
store.get_mutvar(Window^scaling_factor, ScalingFactor, !IO),
PW0 = truncate_to_int(W * ScalingFactor)
),
PW = max(0, PW0),
( CapStyle = not_last, XLibCapStyle = xlib.cap_not_last
; CapStyle = butt, XLibCapStyle = xlib.cap_butt
; CapStyle = round, XLibCapStyle = xlib.cap_round
; CapStyle = projecting, XLibCapStyle = xlib.cap_projecting
),
( JoinStyle = mitre, XLibJoinStyle = xlib.join_mitre
; JoinStyle = round, XLibJoinStyle = xlib.join_round
; JoinStyle = bevel, XLibJoinStyle = xlib.join_bevel
),
impure xlib.set_line_attributes(Display, GC, PW, XLibCapStyle,
XLibJoinStyle).
:- pragma promise_pure(set_font/4).
set_font(Window, Font, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^gc, GC, !IO),
impure xlib.set_font(Display, GC, Font),
store.set_mutvar(Window^maybe_font, yes(Font), !IO).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(draw_text/8).
draw_text(Window, X0, Y0, JX, JY, Text, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^maybe_font, MaybeFont, !IO),
( if MaybeFont = yes(Font) then
Height = Font^xlib.height,
Width = xlib.text_width(Font, Text),
to_pixels(Window, X0, PX0, Y0, PY0, !IO),
PX = PX0 - truncate_to_int(JX * float(Width)),
PY = Font^xlib.ascent + PY0 - truncate_to_int(JY * float(Height)),
% impure xlib.draw_string(Display, Win, GC, PX, PY, Text),
impure xlib.draw_string(Display, Pix, GC, PX, PY, Text)
else
error("draw_text(Window, %f, %f, %f, %f, \"%s\", !IO): " ++
"font not set", [f(X0), f(Y0), f(JX), f(JY), s(Text)])
).
:- pragma promise_pure(draw_image_text/8).
draw_image_text(Window, X0, Y0, JX, JY, Text, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^maybe_font, MaybeFont, !IO),
( if MaybeFont = yes(Font) then
Height = Font^xlib.height,
Width = xlib.text_width(Font, Text),
to_pixels(Window, X0, PX0, Y0, PY0, !IO),
PX = PX0 - truncate_to_int(JX * float(Width)),
PY = Font^xlib.ascent + PY0 - truncate_to_int(JY * float(Height)),
% impure xlib.draw_string(Display, Win, GC, PX, PY, Text),
impure xlib.draw_image_string(Display, Pix, GC, PX, PY, Text)
else
error("draw_image_text(Window, %f, %f, %f, %f, \"%s\", !IO): " ++
"font not set", [f(X0), f(Y0), f(JX), f(JY), s(Text)])
).
draw_text(Window, X, Y, Text, !IO) :-
draw_text(Window, X, Y, 0.0, 0.0, Text, !IO).
draw_image_text(Window, X, Y, Text, !IO) :-
draw_image_text(Window, X, Y, 0.0, 0.0, Text, !IO).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(draw_arc/9).
draw_arc(Window, X, Y, RX, RY, StartAngle, ThroughAngle, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
to_pixels(Window, X, PX, Y, PY, RX, PRX, RY, PRY, !IO),
% impure xlib.draw_arc(Display, Win, GC,
% PX - PRX/2, PY - PRY/2, PRX, PRY,
% a(StartAngle), a(ThroughAngle)),
impure xlib.draw_arc(Display, Pix, GC,
PX - PRX, PY - PRY, PRX + PRX, PRY + PRX,
a(StartAngle), a(ThroughAngle)).
:- pragma promise_pure(fill_arc/9).
fill_arc(Window, X, Y, RX, RY, StartAngle, ThroughAngle, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
to_pixels(Window, X, PX, Y, PY, RX, PRX, RY, PRY, !IO),
% impure xlib.fill_arc(Display, Win, GC,
% PX - PRX/2, PY - PRY/2, PRX, PRY,
% a(StartAngle), a(ThroughAngle)),
impure xlib.fill_arc(Display, Pix, GC,
PX - PRX, PY - PRY, PRX + PRX, PRY + PRY,
a(StartAngle), a(ThroughAngle)).
draw_circle(Window, X, Y, R, !IO) :-
draw_arc(Window, X, Y, R, R, 0.0, pi + pi, !IO).
fill_circle(Window, X, Y, R, !IO) :-
fill_arc(Window, X, Y, R, R, 0.0, pi + pi, !IO).
draw_ellipse(Window, X, Y, RX, RY, !IO) :-
draw_arc(Window, X, Y, RX, RY, 0.0, pi + pi, !IO).
fill_ellipse(Window, X, Y, RX, RY, !IO) :-
fill_arc(Window, X, Y, RX, RY, 0.0, pi + pi, !IO).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(draw_line/7).
draw_line(Window, X1, Y1, X2, Y2, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
to_pixels(Window, X1, PX1, Y1, PY1, X2, PX2, Y2, PY2, !IO),
% impure xlib.draw_line(Display, Win, GC, PX1, PY1, PX2, PY2),
impure xlib.draw_line(Display, Pix, GC, PX1, PY1, PX2, PY2).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(draw_rectangle/7).
draw_rectangle(Window, X1, Y1, X2, Y2, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
to_pixels(Window, X1, PX1, Y1, PY1, X2, PX2, Y2, PY2, !IO),
% impure xlib.draw_rectangle(Display, Win, GC, PX1, PY1, PX2, PY2),
impure xlib.draw_rectangle(Display, Pix, GC, PX1, PY1, PX2, PY2).
:- pragma promise_pure(fill_rectangle/7).
fill_rectangle(Window, X1, Y1, X2, Y2, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
to_pixels(Window, X1, PX1, Y1, PY1, X2, PX2, Y2, PY2, !IO),
% impure xlib.fill_rectangle(Display, Win, GC, PX1, PY1, PX2, PY2),
impure xlib.fill_rectangle(Display, Pix, GC, PX1, PY1, PX2, PY2).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(draw_lines/4).
draw_lines(Window, Coords, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
create_xpoints(Window, Coords, XPoints, !IO),
% impure xlib.draw_lines(Display, Win, GC, XPoints),
impure xlib.draw_lines(Display, Pix, GC, XPoints).
:- pragma promise_pure(fill_polygon/4).
fill_polygon(Window, Coords, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
% store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
create_xpoints(Window, Coords, XPoints, !IO),
% impure xlib.fill_polygon(Display, Win, GC, XPoints),
impure xlib.fill_polygon(Display, Pix, GC, XPoints).
:- pred create_xpoints(window::in, coords::in, xpoints::out, io::di, io::uo)
is det.
create_xpoints(Window, Coords, XPoints, !IO) :-
to_xpts(Window, Coords, XPts, !IO),
XPoints = xlib.xpoints(XPts).
:- pred to_xpts(window::in, coords::in, list(xlib.xpoint)::out,
io::di, io::uo) is det.
to_xpts(_Window, [], [], !IO).
to_xpts( Window, [{X, Y} | XYs], [XPt | XPts], !IO) :-
to_pixels(Window, X, PX, Y, PY, !IO),
XPt = xlib.xpoint(PX, PY),
to_xpts(Window, XYs, XPts, !IO).
%-----------------------------------------------------------------------------%
:- pred restore_from_backing_pixmap(window::in, io::di, io::uo) is det.
restore_from_backing_pixmap(Window, !IO) :-
store.get_mutvar(Window^width, PW, !IO),
store.get_mutvar(Window^height, PH, !IO),
restore_from_backing_pixmap(Window, 0, 0, PW, PH, !IO).
:- pred restore_from_backing_pixmap(window::in, int::in, int::in,
int::in, int::in, io::di, io::uo) is det.
:- pragma promise_pure(restore_from_backing_pixmap/7).
restore_from_backing_pixmap(Window, PX, PY, PW, PH, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^raw_window, Win, !IO),
store.get_mutvar(Window^gc, GC, !IO),
store.get_mutvar(Window^pixmap, Pix, !IO),
impure xlib.copy_area(Display, Pix, Win, GC, PX, PY, PW, PH, PX, PY).
%-----------------------------------------------------------------------------%
:- pragma promise_pure(get_next_event/4).
get_next_event(Window, Event, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^raw_window, Win, !IO),
impure EventPtr = xlib.window_event(Display, Win),
process_event_ptr(Window, EventPtr, MaybeEvent, !IO),
(
MaybeEvent = yes(Event)
;
MaybeEvent = no,
get_next_event(Window, Event, !IO)
).
:- pragma promise_pure(get_next_event_if_any/4).
get_next_event_if_any(Window, MaybeEvent, !IO) :-
store.get_mutvar(Window^display, Display, !IO),
store.get_mutvar(Window^raw_window, Win, !IO),
( if
impure EventPtr = xlib.check_window_event(Display, Win)
then
process_event_ptr(Window, EventPtr, MaybeEvent, !IO)
else
MaybeEvent = no
).
:- pred process_event_ptr(window::in, xlib.event_ptr::in, maybe(event)::out,
io::di, io::uo) is det.
process_event_ptr(Window, EventPtr, MaybeEvent, !IO) :-
store.get_mutvar(Window^width, PW0, !IO),
store.get_mutvar(Window^height, PH0, !IO),
( if
xlib.resize_event(EventPtr, PW, PH)
then
( if ( PW \= PW0 ; PH \= PH0 ) then
set_window_size(Window, PW, PH, !IO),
MaybeEvent = yes(expose)
else
MaybeEvent = no
)
else if
xlib.expose_event(EventPtr, PX, PY, PW, PH, _Count)
then
restore_from_backing_pixmap(Window, PX, PY, PW, PH, !IO),
MaybeEvent = no
else if
xlib.button_press_event(EventPtr, PX, PY, State, Button)
then
to_ratios(Window, PX, X, PY, Y, !IO),
MaybeEvent = yes(button_press(X, Y, State, Button))
else if
xlib.button_release_event(EventPtr, PX, PY, State, Button)
then
to_ratios(Window, PX, X, PY, Y, !IO),
MaybeEvent = yes(button_release(X, Y, State, Button))
else if
xlib.key_press_event(EventPtr, PX, PY, State, KeyString)
then
to_ratios(Window, PX, X, PY, Y, !IO),
MaybeEvent = yes(key_press(X, Y, State, KeyString))
else if
xlib.key_release_event(EventPtr, PX, PY, State, KeyString)
then
to_ratios(Window, PX, X, PY, Y, !IO),
MaybeEvent = yes(key_release(X, Y, State, KeyString))
else if
xlib.pointer_motion_event(EventPtr, PX, PY, State)
then
to_ratios(Window, PX, X, PY, Y, !IO),
MaybeEvent = yes(pointer_motion(X, Y, State))
else
MaybeEvent = no
).
button1(State) :- xlib.button1(State).
button2(State) :- xlib.button2(State).
button3(State) :- xlib.button3(State).
button4(State) :- xlib.button4(State).
button5(State) :- xlib.button5(State).
shift(State) :- xlib.shift(State).
lock(State) :- xlib.lock(State).
control(State) :- xlib.control(State).
mod1(State) :- xlib.mod1(State).
mod2(State) :- xlib.mod2(State).
mod3(State) :- xlib.mod3(State).
mod4(State) :- xlib.mod4(State).
mod5(State) :- xlib.mod5(State).
%-----------------------------------------------------------------------------%
draw(Window, Instrs, !IO) :-
draw_2(Window, identity, Instrs, !IO).
:- pred draw_2(window::in, transformation::in, drawing::in, io::di, io::uo)
is det.
draw_2(Window, Matrix, Instrs, !IO) :-
list.foldl(draw_instr(Window, Matrix), Instrs, !IO).
:- pred draw_instr(window::in, transformation::in, drawing_instruction::in,
io::di, io::uo) is det.
draw_instr(Window, _ , colour(Colour), !IO) :-
set_colour(Window, Colour, !IO).
draw_instr(Window, _ , colour_from_name(ColourName), !IO) :-
get_colour_from_name(Window, ColourName, Colour, !IO),
set_colour(Window, Colour, !IO).
draw_instr(Window, _ , colour_from_rgb(R, G, B), !IO) :-
get_colour_from_rgb(Window, R, G, B, Colour, !IO),
set_colour(Window, Colour, !IO).
draw_instr(Window, _ , line_attributes(Width, CapStyle, JoinStyle), !IO) :-
set_line_attributes(Window, Width, CapStyle, JoinStyle, !IO).
draw_instr(Window, _ , font(Font), !IO) :-
set_font(Window, Font, !IO).
draw_instr(Window, _ , font_from_name(FontName), !IO) :-
load_font(Window, FontName, Font, !IO),
set_font(Window, Font, !IO).
draw_instr(Window, Matrix, line(X10, Y10, X20, Y20), !IO) :-
apply_point_transformation(Matrix, X10, Y10, X1, Y1),
apply_point_transformation(Matrix, X20, Y20, X2, Y2),
draw_line(Window, X1, Y1, X2, Y2, !IO).
draw_instr(Window, Matrix, rectangle(X1, Y1, X2, Y2), !IO) :-
( if Matrix = identity then
draw_rectangle(Window, X1, Y1, X2, Y2, !IO)
else
draw_instr(Window, Matrix, lines([{X1, Y1}, {X2, Y1}, {X2, Y2},
{X1, Y2}, {X1, Y1}]), !IO)
).
draw_instr(Window, Matrix, filled_rectangle(X1, Y1, X2, Y2), !IO) :-
( if Matrix = identity then
fill_rectangle(Window, X1, Y1, X2, Y2, !IO)
else
draw_instr(Window, Matrix, filled_polygon([{X1, Y1}, {X2, Y1},
{X2, Y2}, {X1, Y2}, {X1, Y1}]), !IO)
).
% XXX The transformation is not fully applied here.
%
draw_instr(Window, Matrix, arc(X0, Y0, RX, RY, StartAngle, ThroughAngle),
!IO) :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
draw_arc(Window, X, Y, RX, RY, StartAngle, ThroughAngle, !IO).
draw_instr(Window, Matrix, filled_arc(X0, Y0, RX0, RY0,
StartAngle, ThroughAngle), !IO) :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
apply_radii_transformation(Matrix, RX0, RY0, RX, RY),
fill_arc(Window, X, Y, RX, RY, StartAngle, ThroughAngle, !IO).
draw_instr(Window, Matrix, circle(X0, Y0, R), !IO) :-
draw_instr(Window, Matrix, arc(X0, Y0, R, R, 0.0, pi + pi), !IO).
draw_instr(Window, Matrix, filled_circle(X0, Y0, R), !IO) :-
draw_instr(Window, Matrix, filled_arc(X0, Y0, R, R, 0.0, pi + pi), !IO).
draw_instr(Window, Matrix, ellipse(X0, Y0, RX, RY), !IO) :-
draw_instr(Window, Matrix, arc(X0, Y0, RX, RY, 0.0, pi + pi), !IO).
draw_instr(Window, Matrix, filled_ellipse(X0, Y0, RX, RY), !IO) :-
draw_instr(Window, Matrix, filled_arc(X0, Y0, RX, RY, 0.0, pi + pi), !IO).
draw_instr(Window, Matrix, lines(Coords0), !IO) :-
Coords = apply_point_transformation_coords(Matrix, Coords0),
draw_lines(Window, Coords, !IO).
draw_instr(Window, Matrix, filled_polygon(Coords0), !IO) :-
Coords = apply_point_transformation_coords(Matrix, Coords0),
fill_polygon(Window, Coords, !IO).
draw_instr(Window, Matrix, text(X0, Y0, JX, JY, Text), !IO) :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
draw_text(Window, X, Y, JX, JY, Text, !IO).
draw_instr(Window, Matrix, image_text(X0, Y0, JX, JY, Text), !IO) :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
draw_image_text(Window, X, Y, JX, JY, Text, !IO).
draw_instr(Window, Matrix, text(X0, Y0, Text), !IO) :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
draw_text(Window, X, Y, Text, !IO).
draw_instr(Window, Matrix, image_text(X0, Y0, Text), !IO) :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
draw_image_text(Window, X, Y, Text, !IO).
draw_instr(Window, Matrix, translate(DX, DY, Instrs), !IO) :-
draw_2(Window, chg_translation(Matrix, DX, DY), Instrs, !IO).
draw_instr(Window, Matrix, scale(S, Instrs), !IO) :-
draw_instr(Window, Matrix, scale(S, S, Instrs), !IO).
draw_instr(Window, Matrix, scale(SX, SY, Instrs), !IO) :-
draw_2(Window, chg_scaling(Matrix, SX, SY), Instrs, !IO).
draw_instr(Window, Matrix, rotate(R, Instrs), !IO) :-
draw_2(Window, chg_rotation(Matrix, R), Instrs, !IO).
draw_instr(Window, Matrix, mirror_x(Instrs), !IO) :-
draw_2(Window, chg_mirror_x(Matrix), Instrs, !IO).
draw_instr(Window, Matrix, mirror_y(Instrs), !IO) :-
draw_2(Window, chg_mirror_y(Matrix), Instrs, !IO).
%-----------------------------------------------------------------------------%
% We support a number of transformations:
%
% Translation displacing x by a and y by b:
% ( 1 0 a )(x) (x + a)
% ( 0 1 b )(y) = (y + b)
% ( 0 0 1 )(1) ( 1 )
%
% Scaling x by a factor of c and y by a factor of d:
% ( c 0 0 )(x) (cx)
% ( 0 d 0 )(y) = (dy)
% ( 0 0 1 )(1) ( 1)
%
% Rotation through an angle theta where c = cos(theta), s = sin(theta):
% ( c -s 0 )(x) = (cx - sy)
% ( s c 0 )(y) = (sx + cy)
% ( 0 0 1 )(1) = ( 1 )
%
% Reflection about x = 0:
% (-1 0 0 )(x) (-x)
% ( 0 1 0 )(y) = ( y)
% ( 0 0 1 )(1) = ( 1)
%
% Reflection about y = 0:
% ( 1 0 0 )(x) ( x)
% ( 0 -1 0 )(y) = (-y)
% ( 0 0 1 )(1) = ( 1)
%
% Since the bottom row of each matrix is always (0 0 1) we don't bother
% storing it.
:- type transformation == {float, float, float,
float, float, float}.
:- func identity = transformation.
identity = {1.0, 0.0, 0.0,
0.0, 1.0, 0.0}.
:- func chg_translation(transformation, float, float) = transformation.
chg_translation({A, B, C, D, E, F}, DX, DY) =
{A, B, A*DX + B*DY + C, D, E, D*DX + E*DY + F}.
:- func chg_scaling(transformation, float, float) = transformation.
chg_scaling({A, B, C, D, E, F}, SX, SY) =
{A*SX, B*SY, C, D*SX, E*SY, F}.
:- func chg_rotation(transformation, float) = transformation.
chg_rotation({A, B, C, D, E, F}, R) = T :-
CR = cos(R),
SR = sin(R),
T = {A*CR + B*SR, -A*SR + B*CR, C,
D*CR + E*SR, -D*SR + E*CR, F}.
:- func chg_mirror_x(transformation) = transformation.
chg_mirror_x({A, B, C, D, E, F}) =
{-A, B, C, -D, E, F}.
:- func chg_mirror_y(transformation) = transformation.
chg_mirror_y({A, B, C, D, E, F}) =
{A, -B, C, D, -E, F}.
:- pred apply_radii_transformation(transformation::in, float::in, float::in,
float::out, float::out).
apply_radii_transformation({A, B, _, D, E, _},
RX, RY, A*RX + B*RY, D*RX + E*RY).
:- pred apply_point_transformation(transformation::in, float::in, float::in,
float::out, float::out).
apply_point_transformation({A, B, C, D, E, F},
X, Y, A*X + B*Y + C, D*X + E*Y + F).
:- func apply_point_transformation_coords(transformation, coords) = coords.
apply_point_transformation_coords(_, [] ) = [].
apply_point_transformation_coords(Matrix, [{X0, Y0} | XYs0]) =
[{X, Y} | XYs] :-
apply_point_transformation(Matrix, X0, Y0, X, Y),
XYs = apply_point_transformation_coords(Matrix, XYs0).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- pred error(string::in, list(string.poly_type)::in) is erroneous.
error(Fmt, Args) :-
throw(string.format("easyx." ++ Fmt, Args) `with_type` string).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
xlib.m:
%-----------------------------------------------------------------------------%
% Copyright (C) 2004 The University of Melbourne.
% 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.
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
% xlib.m
% Ralph Becket <rafe at cs.mu.oz.au>
% Mon Jun 21 17:48:24 EST 2004
%
% A low-level interface to parts of Xlib (this is very little more than a
% few useful symbol definitions and wrappers around various Xlib calls.)
%
%-----------------------------------------------------------------------------%
:- module xlib.
:- interface.
:- import_module list.
:- type display_ptr.
:- impure func open_display = (display_ptr::out) is semidet.
:- impure func open_display(string::in) = (display_ptr::out) is semidet.
:- impure pred flush(display_ptr::in) is det.
:- impure pred sync(display_ptr::in) is det.
:- type drawable.
:- impure func create_simple_window(display_ptr::in, int::in, int::in) =
(drawable::out) is semidet.
:- impure pred set_window_name(display_ptr::in, drawable::in, string::in)
is semidet.
:- impure pred map_raised(display_ptr::in, drawable::in) is det.
:- impure pred clear_window(display_ptr::in, drawable::in) is det.
:- impure pred resize_window(display_ptr::in, drawable::in, int::in, int::in)
is det.
:- impure func create_matching_pixmap(display_ptr::in, drawable::in) =
(drawable::out) is semidet.
:- impure pred free_pixmap(display_ptr::in, drawable::in) is det.
:- impure pred copy_area(display_ptr::in, drawable::in, drawable::in, gc::in,
int::in, int::in, int::in, int::in, int::in, int::in)
is det.
:- type gc.
:- impure func create_gc(display_ptr::in, drawable::in,
value_mask::in, gc_values_ptr::in) = (gc::out) is semidet.
:- impure pred change_gc(display_ptr::in, gc::in, value_mask::in,
gc_values_ptr::in) is det.
:- type value_mask == int.
:- func gc_fg = value_mask.
:- func gc_bg = value_mask.
:- func gc_line_width = value_mask.
:- func gc_cap_style = value_mask.
:- func gc_join_style = value_mask.
:- func gc_font = value_mask.
:- type gc_values_ptr.
:- func new_gc_values_ptr = gc_values_ptr.
:- impure pred set_gv_values_fg(gc_values_ptr::in, color_ptr::in)
is det.
:- impure pred set_gv_values_bg(gc_values_ptr::in, color_ptr::in)
is det.
:- impure pred set_gv_values_line_width(gc_values_ptr::in, int::in)
is det.
:- impure pred set_gv_values_cap_style(gc_values_ptr::in, cap_style::in)
is det.
:- impure pred set_gv_values_join_style(gc_values_ptr::in, join_style::in)
is det.
:- impure pred set_gv_values_font(gc_values_ptr::in, font_struct_ptr::in)
is det.
:- type color_ptr.
:- impure func alloc_named_color(display_ptr::in, string::in) =
(color_ptr::out) is semidet.
:- impure func alloc_rgb_color(display_ptr::in, int::in, int::in, int::in) =
(color_ptr::out) is semidet.
:- type cap_style.
:- func cap_not_last = cap_style.
:- func cap_butt = cap_style.
:- func cap_round = cap_style.
:- func cap_projecting = cap_style.
:- type join_style.
:- func join_mitre = join_style.
:- func join_miter = join_style. % Synonym for `mitre'.
:- func join_round = join_style.
:- func join_bevel = join_style.
:- type font_struct_ptr.
:- impure func load_query_font(display_ptr::in, string::in) =
(font_struct_ptr::out) is semidet.
:- func font_struct_ptr ^ ascent = int.
:- func font_struct_ptr ^ descent = int.
:- func font_struct_ptr ^ height = int.
:- func text_width(font_struct_ptr, string) = int.
:- impure pred set_fg(display_ptr::in, gc::in, color_ptr::in) is det.
:- impure pred set_bg(display_ptr::in, gc::in, color_ptr::in) is det.
:- impure pred set_line_attributes(display_ptr::in, gc::in,
int::in, cap_style::in, join_style::in) is det.
:- impure pred set_font(display_ptr::in, gc::in, font_struct_ptr::in) is det.
:- impure pred draw_string(display_ptr::in, drawable::in, gc::in,
int::in, int::in, string::in) is det.
:- impure pred draw_image_string(display_ptr::in, drawable::in, gc::in,
int::in, int::in, string::in) is det.
:- impure pred draw_line(display_ptr::in, drawable::in, gc::in,
int::in, int::in, int::in, int::in) is det.
:- impure pred draw_arc(display_ptr::in, drawable::in, gc::in,
int::in, int::in, int::in, int::in,
int::in, int::in) is det.
:- impure pred fill_arc(display_ptr::in, drawable::in, gc::in,
int::in, int::in, int::in, int::in,
int::in, int::in) is det.
:- impure pred draw_rectangle(display_ptr::in, drawable::in, gc::in,
int::in, int::in, int::in, int::in) is det.
:- impure pred fill_rectangle(display_ptr::in, drawable::in, gc::in,
int::in, int::in, int::in, int::in) is det.
:- type xpoint.
:- type xpoints.
:- func xpoint(int, int) = xpoint.
:- func xpoints(list(xpoint)) = xpoints.
:- impure pred draw_lines(display_ptr::in, drawable::in, gc::in, xpoints::in)
is det.
:- impure pred fill_polygon(display_ptr::in, drawable::in, gc::in, xpoints::in)
is det.
:- type event_ptr.
:- type buttons_and_modifiers.
:- type button_no == int.
:- type keycode.
:- impure func window_event(display_ptr::in, drawable::in) =
(event_ptr::out) is det.
:- impure func check_window_event(display_ptr::in, drawable::in) =
(event_ptr::out) is semidet.
:- pred expose_event(event_ptr::in, int::out, int::out, int::out, int::out,
int::out) is semidet.
:- pred resize_event(event_ptr::in, int::out, int::out) is semidet.
:- pred button_press_event(event_ptr::in, int::out, int::out,
buttons_and_modifiers::out, button_no::out) is semidet.
:- pred button_release_event(event_ptr::in, int::out, int::out,
buttons_and_modifiers::out, button_no::out) is semidet.
:- pred key_press_event(event_ptr::in, int::out, int::out,
buttons_and_modifiers::out, string::out) is semidet.
:- pred key_release_event(event_ptr::in, int::out, int::out,
buttons_and_modifiers::out, string::out) is semidet.
:- pred pointer_motion_event(event_ptr::in, int::out, int::out,
buttons_and_modifiers::out) is semidet.
:- pred button1(buttons_and_modifiers::in) is semidet.
:- pred button2(buttons_and_modifiers::in) is semidet.
:- pred button3(buttons_and_modifiers::in) is semidet.
:- pred button4(buttons_and_modifiers::in) is semidet.
:- pred button5(buttons_and_modifiers::in) is semidet.
:- pred shift(buttons_and_modifiers::in) is semidet.
:- pred lock(buttons_and_modifiers::in) is semidet.
:- pred control(buttons_and_modifiers::in) is semidet.
:- pred mod1(buttons_and_modifiers::in) is semidet.
:- pred mod2(buttons_and_modifiers::in) is semidet.
:- pred mod3(buttons_and_modifiers::in) is semidet.
:- pred mod4(buttons_and_modifiers::in) is semidet.
:- pred mod5(buttons_and_modifiers::in) is semidet.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module int.
%-----------------------------------------------------------------------------%
:- pragma foreign_decl("C", "#include <string.h>").
:- pragma foreign_decl("C", "#include <X11/X.h>").
:- pragma foreign_decl("C", "#include <X11/Xlib.h>").
:- pragma foreign_decl("C", "#include <X11/Xutil.h>").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", display_ptr, "Display *").
:- pragma foreign_proc("C", open_display = (DisplayPtr::out),
[will_not_call_mercury, thread_safe],
"
DisplayPtr = XOpenDisplay(NULL);
SUCCESS_INDICATOR = (DisplayPtr != NULL);
").
:- pragma foreign_proc("C", open_display(DisplayName::in) = (DisplayPtr::out),
[will_not_call_mercury, thread_safe],
"
DisplayPtr = XOpenDisplay(DisplayName);
SUCCESS_INDICATOR = (DisplayPtr != NULL);
").
:- pragma foreign_proc("C", flush(DisplayPtr::in),
[will_not_call_mercury, thread_safe],
"
XFlush(DisplayPtr);
").
:- pragma foreign_proc("C", sync(DisplayPtr::in),
[will_not_call_mercury, thread_safe],
"
XSync(DisplayPtr, 0 /* Don't discard pending events */);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", drawable, "Drawable").
:- pragma foreign_proc("C",
create_simple_window(DisplayPtr::in, W::in, H::in) = (Win::out),
[will_not_call_mercury, thread_safe],
"
XSetWindowAttributes winattrs;
winattrs.background_pixmap = None;
winattrs.bit_gravity = StaticGravity;
winattrs.win_gravity = StaticGravity;
winattrs.backing_store = NotUseful;
winattrs.event_mask = MyEventMask;
Win = XCreateWindow(
DisplayPtr,
DefaultRootWindow(DisplayPtr),
0, 0, /* x, y */
W, H,
0, /* Border width */
DefaultDepth(DisplayPtr, DefaultScreen(DisplayPtr)),
InputOutput,
CopyFromParent,
CWBackPixmap | CWBitGravity | CWWinGravity |
CWBackingStore | CWEventMask,
&winattrs
);
SUCCESS_INDICATOR =
( Win != BadAlloc
&& Win != BadMatch
&& Win != BadValue
&& Win != BadWindow
);
").
:- pragma foreign_proc("C",
set_window_name(DisplayPtr::in, Win::in, TitleText::in),
[will_not_call_mercury, thread_safe],
"
XTextProperty TitleTextProperty;
SUCCESS_INDICATOR =
XStringListToTextProperty(&TitleText, 1, &TitleTextProperty);
if (SUCCESS_INDICATOR) {
XSetWMName(DisplayPtr, Win, &TitleTextProperty);
XSetWMIconName(DisplayPtr, Win, &TitleTextProperty);
}
").
:- pragma foreign_proc("C", map_raised(DisplayPtr::in, Win::in),
[will_not_call_mercury, thread_safe],
"
XMapRaised(DisplayPtr, Win);
").
:- pragma foreign_proc("C", clear_window(DisplayPtr::in, Win::in),
[will_not_call_mercury, thread_safe],
"
XClearWindow(DisplayPtr, Win);
").
:- pragma foreign_proc("C", resize_window(DisplayPtr::in, Win::in,
W::in, H::in),
[will_not_call_mercury, thread_safe],
"
XResizeWindow(DisplayPtr, Win, W, H);
").
:- pragma foreign_proc("C",
create_matching_pixmap(DisplayPtr::in, Win::in) = (Pix::out),
[will_not_call_mercury, thread_safe],
"
XWindowAttributes winattrs;
XGetWindowAttributes(DisplayPtr, Win, &winattrs);
Pix = XCreatePixmap(DisplayPtr, Win,
winattrs.width, winattrs.height, winattrs.depth);
SUCCESS_INDICATOR =
( Win != BadAlloc
&& Win != BadDrawable
&& Win != BadValue
);
").
:- pragma foreign_proc("C", free_pixmap(DisplayPtr::in, Pix::in),
[will_not_call_mercury, thread_safe],
"
XFreePixmap(DisplayPtr, Pix);
").
:- pragma foreign_proc("C",
copy_area(DisplayPtr::in, Pix::in, Win::in, Gc::in,
X1::in, Y1::in, W::in, H::in, X2::in, Y2::in),
[will_not_call_mercury, thread_safe],
"
XCopyArea(DisplayPtr, Pix, Win, Gc, X1, Y1, W, H, X2, Y2);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", gc, "GC").
:- pragma foreign_proc("C", create_gc(DisplayPtr::in, Win::in,
ValueMask::in, GCValuesPtr::in) = (Gc::out),
[will_not_call_mercury, thread_safe],
"
Gc = XCreateGC(DisplayPtr, Win, ValueMask, GCValuesPtr);
SUCCESS_INDICATOR = (
(int) Gc != BadAlloc
&& (int) Gc != BadDrawable
&& (int) Gc != BadFont
&& (int) Gc != BadMatch
&& (int) Gc != BadPixmap
&& (int) Gc != BadValue
);
").
:- pragma foreign_proc("C", change_gc(DisplayPtr::in, Gc::in, ValueMask::in,
GCValuesPtr::in),
[will_not_call_mercury, thread_safe],
"
XChangeGC(DisplayPtr, Gc, ValueMask, GCValuesPtr);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C", gc_fg = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = GCForeground;").
:- pragma foreign_proc("C", gc_bg = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = GCBackground;").
:- pragma foreign_proc("C", gc_line_width = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = GCLineWidth;" ).
:- pragma foreign_proc("C", gc_cap_style = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = GCCapStyle;" ).
:- pragma foreign_proc("C", gc_join_style = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = GCJoinStyle;" ).
:- pragma foreign_proc("C", gc_font = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = GCFont;" ).
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", gc_values_ptr, "XGCValues *").
:- pragma foreign_proc("C", new_gc_values_ptr = (GCValuesPtr::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
GCValuesPtr = MR_GC_NEW(XGCValues);
").
:- pragma foreign_proc("C", set_gv_values_fg(GCValuesPtr::in, ColourPtr::in),
[will_not_call_mercury, thread_safe],
"
GCValuesPtr->foreground = ColourPtr->pixel;
").
:- pragma foreign_proc("C", set_gv_values_bg(GCValuesPtr::in, ColourPtr::in),
[will_not_call_mercury, thread_safe],
"
GCValuesPtr->background = ColourPtr->pixel;
").
:- pragma foreign_proc("C", set_gv_values_line_width(GCValuesPtr::in,
LineWidth::in),
[will_not_call_mercury, thread_safe],
"
GCValuesPtr->line_width = LineWidth;
").
:- pragma foreign_proc("C", set_gv_values_cap_style(GCValuesPtr::in,
CapStyle::in),
[will_not_call_mercury, thread_safe],
"
GCValuesPtr->cap_style = CapStyle;
").
:- pragma foreign_proc("C", set_gv_values_join_style(GCValuesPtr::in,
JoinStyle::in),
[will_not_call_mercury, thread_safe],
"
GCValuesPtr->join_style = JoinStyle;
").
:- pragma foreign_proc("C", set_gv_values_font(GCValuesPtr::in,
FontStructPtr::in),
[will_not_call_mercury, thread_safe],
"
GCValuesPtr->font = FontStructPtr->fid;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", color_ptr, "XColor *").
:- pragma foreign_proc("C", alloc_named_color(DisplayPtr::in, ColorName::in) =
(ColorPtr::out),
[will_not_call_mercury, thread_safe],
"
XColor ExactDefReturn;
ColorPtr = MR_GC_NEW(XColor);
SUCCESS_INDICATOR =
XAllocNamedColor(
DisplayPtr,
DefaultColormap(DisplayPtr, DefaultScreen(DisplayPtr)),
ColorName,
ColorPtr,
&ExactDefReturn
);
").
:- pragma foreign_proc("C", alloc_rgb_color(DisplayPtr::in,
R::in, G::in, B::in) = (ColorPtr::out),
[will_not_call_mercury, thread_safe],
"
ColorPtr = MR_GC_NEW(XColor);
ColorPtr->red = R;
ColorPtr->green = G;
ColorPtr->blue = B;
SUCCESS_INDICATOR =
XAllocColor(
DisplayPtr,
DefaultColormap(DisplayPtr, DefaultScreen(DisplayPtr)),
ColorPtr
);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", cap_style, "int").
:- pragma foreign_proc("C", cap_not_last = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = CapNotLast;" ).
:- pragma foreign_proc("C", cap_butt = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = CapButt;" ).
:- pragma foreign_proc("C", cap_round = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = CapRound;" ).
:- pragma foreign_proc("C", cap_projecting = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = CapProjecting;").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", join_style, "int").
join_miter = join_mitre.
:- pragma foreign_proc("C", join_mitre = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = JoinMiter;").
:- pragma foreign_proc("C", join_round = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = JoinRound;").
:- pragma foreign_proc("C", join_bevel = (X::out),
[will_not_call_mercury, thread_safe, promise_pure], "X = JoinBevel;").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", font_struct_ptr, "XFontStruct *").
:- pragma foreign_proc("C",
load_query_font(DisplayPtr::in, Name::in) = (FontStructPtr::out),
[will_not_call_mercury, thread_safe],
"
FontStructPtr = XLoadQueryFont(DisplayPtr, Name);
SUCCESS_INDICATOR = (FontStructPtr != NULL);
").
:- pragma foreign_proc("C",
ascent(FontStructPtr::in) = (X::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
X = FontStructPtr->ascent;
").
:- pragma foreign_proc("C",
descent(FontStructPtr::in) = (X::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
X = FontStructPtr->descent;
").
FontStructPtr^height = FontStructPtr^ascent + FontStructPtr^descent.
:- pragma foreign_proc("C",
text_width(FontStructPtr::in, Text::in) = (Width::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
Width = XTextWidth(FontStructPtr, Text, strlen(Text));
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C", set_fg(DisplayPtr::in, Gc::in,
ColorPtr::in),
[will_not_call_mercury, thread_safe],
"
XSetForeground(DisplayPtr, Gc, ColorPtr->pixel);
").
:- pragma foreign_proc("C", set_bg(DisplayPtr::in, Gc::in,
ColorPtr::in),
[will_not_call_mercury, thread_safe],
"
XSetBackground(DisplayPtr, Gc, ColorPtr->pixel);
").
:- pragma foreign_proc("C", set_font(DisplayPtr::in, Gc::in,
FontStructPtr::in),
[will_not_call_mercury, thread_safe],
"
XSetFont(DisplayPtr, Gc, FontStructPtr->fid);
").
:- pragma foreign_proc("C", set_line_attributes(DisplayPtr::in, Gc::in,
Width::in, CapStyle::in, JoinStyle::in),
[will_not_call_mercury, thread_safe],
"
XSetLineAttributes(DisplayPtr, Gc,
Width, LineSolid, CapStyle, JoinStyle);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
draw_string(DisplayPtr::in, Win::in, Gc::in, X::in, Y::in, Text::in),
[will_not_call_mercury, thread_safe],
"
XDrawString(DisplayPtr, Win, Gc, X, Y, Text, strlen(Text));
").
:- pragma foreign_proc("C",
draw_image_string(DisplayPtr::in, Win::in, Gc::in, X::in, Y::in, Text::in),
[will_not_call_mercury, thread_safe],
"
XDrawImageString(DisplayPtr, Win, Gc, X, Y, Text, strlen(Text));
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
draw_line(DisplayPtr::in, Win::in, Gc::in, X1::in, Y1::in, X2::in, Y2::in),
[will_not_call_mercury, thread_safe],
"
XDrawLine(DisplayPtr, Win, Gc, X1, Y1, X2, Y2);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
draw_arc(DisplayPtr::in, Win::in, Gc::in, X1::in, Y1::in, X2::in, Y2::in,
Angle1::in, Angle2::in),
[will_not_call_mercury, thread_safe],
"
XDrawArc(DisplayPtr, Win, Gc, X1, Y1, X2, Y2, Angle1, Angle2);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
fill_arc(DisplayPtr::in, Win::in, Gc::in, X1::in, Y1::in, X2::in, Y2::in,
Angle1::in, Angle2::in),
[will_not_call_mercury, thread_safe],
"
XFillArc(DisplayPtr, Win, Gc, X1, Y1, X2, Y2, Angle1, Angle2);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
draw_rectangle(DisplayPtr::in, Win::in, Gc::in,
X1::in, Y1::in, X2::in, Y2::in),
[will_not_call_mercury, thread_safe],
"
XDrawRectangle(DisplayPtr, Win, Gc, X1, Y1, X2, Y2);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C", fill_rectangle(DisplayPtr::in, Win::in, Gc::in,
X1::in, Y1::in, X2::in, Y2::in),
[will_not_call_mercury, thread_safe],
"
XFillRectangle(DisplayPtr, Win, Gc, X1, Y1, X2, Y2);
").
%-----------------------------------------------------------------------------%
:- type xpoints
---> xpoints(int, xpoint_array).
:- type xpoint_array.
:- pragma foreign_type("C", xpoint, "XPoint *").
:- pragma foreign_type("C", xpoint_array, "XPoint *").
:- pragma foreign_proc("C", xpoint(X::in, Y::in) = (XPt::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
XPt = MR_GC_NEW(XPoint);
XPt->x = X;
XPt->y = Y;
").
xpoints(XYs) = xpoints(N, XPts) :-
N = length(XYs),
XPts = xpoint_array(N, XYs).
:- func xpoint_array(int, list(xpoint)) = xpoint_array.
:- pragma foreign_proc("C", xpoint_array(N::in, XPts::in) =
(XPtArray::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
MR_Integer i;
XPtArray = MR_GC_NEW_ARRAY(XPoint, N);
for(i = 0; i < N; i++) {
XPoint *xpt = (XPoint *) MR_list_head(XPts);
XPtArray[i].x = xpt->x;
XPtArray[i].y = xpt->y;
XPts = MR_list_tail(XPts);
}
").
draw_lines(DisplayPtr, Win, Gc, xpoints(N, XPts)) :-
impure draw_lines_2(DisplayPtr, Win, Gc, XPts, N).
:- impure pred draw_lines_2(display_ptr::in, drawable::in, gc::in,
xpoint_array::in, int::in) is det.
:- pragma foreign_proc("C", draw_lines_2(DisplayPtr::in, Win::in, Gc::in,
XPts::in, N::in),
[will_not_call_mercury, thread_safe],
"
XDrawLines(DisplayPtr, Win, Gc, XPts, N, CoordModeOrigin);
").
fill_polygon(DisplayPtr, Win, Gc, xpoints(N, XPts)) :-
impure fill_polygon_2(DisplayPtr, Win, Gc, XPts, N).
:- impure pred fill_polygon_2(display_ptr::in, drawable::in, gc::in,
xpoint_array::in, int::in) is det.
:- pragma foreign_proc("C", fill_polygon_2(DisplayPtr::in, Win::in, Gc::in,
XPts::in, N::in),
[will_not_call_mercury, thread_safe],
"
XFillPolygon(DisplayPtr, Win, Gc, XPts, N, Complex, CoordModeOrigin);
").
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", event_ptr, "XEvent *").
:- type buttons_and_modifiers == int.
:- type keycode == int.
:- pragma foreign_decl("C", "
#define MyEventMask ( KeyPressMask \
| KeyReleaseMask \
| ButtonPressMask \
| ButtonReleaseMask \
| PointerMotionMask \
| ButtonMotionMask \
| ExposureMask \
| StructureNotifyMask \
)
").
:- pragma foreign_proc("C", window_event(DisplayPtr::in, Win::in) =
(EventPtr::out),
[will_not_call_mercury, thread_safe],
"
EventPtr = MR_GC_NEW(XEvent);
XWindowEvent(DisplayPtr, Win, MyEventMask, EventPtr);
").
:- pragma foreign_proc("C", check_window_event(DisplayPtr::in, Win::in) =
(EventPtr::out),
[will_not_call_mercury, thread_safe],
"
EventPtr = MR_GC_NEW(XEvent);
SUCCESS_INDICATOR = XCheckWindowEvent(DisplayPtr, Win, MyEventMask,
EventPtr);
").
:- pragma foreign_proc("C",
expose_event(EventPtr::in, X::out, Y::out, W::out, H::out, Count::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == Expose );
if (SUCCESS_INDICATOR) {
X = EventPtr->xexpose.x;
Y = EventPtr->xexpose.y;
W = EventPtr->xexpose.width;
H = EventPtr->xexpose.height;
Count = EventPtr->xexpose.count;
}
").
:- pragma foreign_proc("C", resize_event(EventPtr::in, W::out, H::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == ConfigureNotify );
if (SUCCESS_INDICATOR) {
W = EventPtr->xconfigure.width;
H = EventPtr->xconfigure.height;
}
").
:- pragma foreign_proc("C", button_press_event(EventPtr::in,
X::out, Y::out, State::out, Button::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == ButtonPress );
if (SUCCESS_INDICATOR) {
X = EventPtr->xbutton.x;
Y = EventPtr->xbutton.y;
State = EventPtr->xbutton.state;
Button = EventPtr->xbutton.button;
}
").
:- pragma foreign_proc("C", button_release_event(EventPtr::in,
X::out, Y::out, State::out, Button::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == ButtonRelease );
if (SUCCESS_INDICATOR) {
X = EventPtr->xbutton.x;
Y = EventPtr->xbutton.y;
State = EventPtr->xbutton.state;
Button = EventPtr->xbutton.button;
}
").
:- pragma foreign_proc("C", key_press_event(EventPtr::in,
X::out, Y::out, State::out,
KeysymString::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == KeyPress );
if (SUCCESS_INDICATOR) {
X = EventPtr->xkey.x;
Y = EventPtr->xkey.y;
State = EventPtr->xkey.state;
KeysymString = XKeysymToString(XKeycodeToKeysym(
EventPtr->xkey.display,
EventPtr->xkey.keycode,
((State & ShiftMask) != 0)));
if (KeysymString == NULL) {
KeysymString = XKeysymToString(XKeycodeToKeysym(
EventPtr->xkey.display,
EventPtr->xkey.keycode,
0));
}
if (KeysymString == NULL) {
KeysymString = (MR_String) \"\";
}
}
").
:- pragma foreign_proc("C", key_release_event(EventPtr::in,
X::out, Y::out, State::out,
KeysymString::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == KeyRelease );
if (SUCCESS_INDICATOR) {
X = EventPtr->xkey.x;
Y = EventPtr->xkey.y;
State = EventPtr->xkey.state;
KeysymString = XKeysymToString(XKeycodeToKeysym(
EventPtr->xkey.display,
EventPtr->xkey.keycode,
((State & ShiftMask) != 0)));
if (KeysymString == NULL) {
KeysymString = XKeysymToString(XKeycodeToKeysym(
EventPtr->xkey.display,
EventPtr->xkey.keycode,
0));
}
if (KeysymString == NULL) {
KeysymString = (MR_String) \"\";
}
}
").
:- pragma foreign_proc("C", pointer_motion_event(EventPtr::in,
X::out, Y::out, State::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = ( EventPtr->type == MotionNotify );
if (SUCCESS_INDICATOR) {
X = EventPtr->xmotion.x;
Y = EventPtr->xmotion.y;
State = EventPtr->xmotion.state;
}
").
:- pragma foreign_proc("C", button1(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Button1Mask;
").
:- pragma foreign_proc("C", button2(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Button2Mask;
").
:- pragma foreign_proc("C", button3(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Button3Mask;
").
:- pragma foreign_proc("C", button4(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Button4Mask;
").
:- pragma foreign_proc("C", button5(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Button5Mask;
").
:- pragma foreign_proc("C", shift(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & ShiftMask;
").
:- pragma foreign_proc("C", lock(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & LockMask;
").
:- pragma foreign_proc("C", control(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & ControlMask;
").
:- pragma foreign_proc("C", mod1(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Mod1Mask;
").
:- pragma foreign_proc("C", mod2(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Mod2Mask;
").
:- pragma foreign_proc("C", mod3(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Mod3Mask;
").
:- pragma foreign_proc("C", mod4(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Mod4Mask;
").
:- pragma foreign_proc("C", mod5(State::in),
[will_not_call_mercury, thread_safe, promise_pure],
"
SUCCESS_INDICATOR = State & Mod5Mask;
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
testeasyx.m:
%-----------------------------------------------------------------------------%
% testeasyx.m
% Ralph Becket <rafe at cs.mu.oz.au>
% Mon Jun 28 15:21:14 EST 2004
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%
% Example program using the easyx module. The Union Jack is drawn with a
% rotated white square placed in the middle, along with some text. Cursor
% keys move the image; `-' and `=' rotate the image; `q' quits the program.
%
% Compile this program with
%
% mmc --make testeasyx -L /usr/X11/lib -l X11
%
% ensuring that easyx.m and xlib.m are in the same directory. You may also
% need to change /usr/X11/lib to something like /usr/X11R6/lib on some
% systems.
%
%-----------------------------------------------------------------------------%
:- module testeasyx.
:- interface.
:- import_module io.
:- pred main(io :: di, io :: uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module easyx.
:- import_module float.
:- import_module list.
:- import_module math.
%-----------------------------------------------------------------------------%
main(!IO) :-
easyx.open_display(Display, !IO),
easyx.create_window(Display, "testeasyx", 300, 300, Window, !IO),
easyx.load_font(Window, "*-helvetica-*-r-*-20-*", Font, !IO),
easyx.set_font(Window, Font, !IO),
draw_window(Window, 0.0, 0.0, 0.0, !IO).
:- pred draw_window(window::in, float::in, float::in, float::in,
io::di, io::uo) is det.
draw_window(Window, X, Y, R, !IO) :-
easyx.get_colour_from_name(Window, "black", Black, !IO),
easyx.get_colour_from_name(Window, "white", White, !IO),
easyx.get_colour_from_name(Window, "red", Red, !IO),
easyx.get_colour_from_name(Window, "gray", Grey, !IO),
easyx.get_colour_from_name(Window, "blue", Blue, !IO),
easyx.draw(Window, [
colour(Blue),
filled_rectangle(0.0, 0.0, 1.0, 1.0),
translate(X + 0.5, Y + 0.5, [rotate(R, [translate(-0.5, -0.5, [
line_attributes(ratio(0.2), butt, mitre),
colour(White),
line(0.0, 0.0, 1.0, 1.0),
line(0.0, 1.0, 1.0, 0.0),
line_attributes(ratio(0.1), butt, mitre),
colour(Red),
line(0.0, 0.0, 1.0, 1.0),
line(0.0, 1.0, 1.0, 0.0),
line_attributes(ratio(0.2), butt, mitre),
colour(White),
line(0.5, 0.0, 0.5, 1.0),
line(0.0, 0.5, 1.0, 0.5),
line_attributes(ratio(0.1), butt, mitre),
colour(Red),
line(0.5, 0.0, 0.5, 1.0),
line(0.0, 0.5, 1.0, 0.5),
translate(0.5, 0.5, [rotate(0.2, [
colour(Black), rectangle(-0.3, -0.3, 0.3, 0.3),
colour(White), filled_rectangle(-0.3, -0.3, 0.3, 0.3)
])]),
colour(Red),
text(0.5, 0.5, 0.5, 0.5, "EasyX!")
])])]),
colour(Grey),
text(0.0, 1.0, 0.0, 1.0, "Q to exit")
], !IO),
easyx.flush(Window, !IO),
easyx.get_next_event(Window, Event, !IO),
io.print(Event, !IO),
io.nl(!IO),
( if Event = key_press(_, _, _, "Left")
then draw_window(Window, X - 0.1, Y, R, !IO)
else if Event = key_press(_, _, _, "Right")
then draw_window(Window, X + 0.1, Y, R, !IO)
else if Event = key_press(_, _, _, "Up")
then draw_window(Window, X, Y - 0.1, R, !IO)
else if Event = key_press(_, _, _, "Down")
then draw_window(Window, X, Y + 0.1, R, !IO)
else if Event = key_press(_, _, _, "equal")
then draw_window(Window, X, Y, R - 0.1, !IO)
else if Event = key_press(_, _, _, "minus")
then draw_window(Window, X, Y, R + 0.1, !IO)
else if not (Event = key_press(_, _, _, Q), ( Q = "q" ; Q = "Q" ))
then draw_window(Window, X, Y, R, !IO)
else true
).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
moveball.m:
%-----------------------------------------------------------------------------%
% Copyright (C) 2004 The University of Melbourne.
% 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.
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
% moveball.m
% Ralph Becket <rafe at cs.mu.oz.au>
% Fri Sep 17 16:19:38 EST 2004
%
% An orange ball follows the mouse pointer.
%
%-----------------------------------------------------------------------------%
:- module moveball.
:- interface.
:- import_module io.
:- pred main(io :: di, io :: uo) is det.
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module bool.
:- import_module easyx.
:- import_module float.
:- import_module int.
:- import_module list.
:- import_module random.
:- import_module std_util.
main(!IO) :-
easyx.open_display(Display, !IO),
easyx.create_window(Display, "moveball", 400, 400, Window, !IO),
easyx.set_line_attributes(Window, pixels(0), round, mitre, !IO),
move_ball(Window, 0.5, 0.5, !IO).
:- pred move_ball(window::in, float::in, float::in, io::di, io::uo) is det.
move_ball(Window, X0, Y0, !IO) :-
easyx.draw(Window, [
colour_from_name("black"), filled_rectangle(0.0, 0.0, 1.0, 1.0),
colour_from_name("orange"), filled_circle(X0, Y0, 0.1)
], !IO),
easyx.flush(Window, !IO),
easyx.get_next_event(Window, Event, !IO),
( if Event = pointer_motion(X, Y, _)
then move_ball(Window, X, Y, !IO)
else if Event \= key_press(_, _, _, "q")
then move_ball(Window, X0, Y0, !IO)
else true
).
scribble.m:
%-----------------------------------------------------------------------------%
% Copyright (C) 2004 The University of Melbourne.
% 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.
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
% scribble.m
% Ralph Becket <rafe at cs.mu.oz.au>
% Fri Sep 17 16:19:38 EST 2004
%
% A trivial drawing program using the easyx module. Drawing is with
% the mouse (while holding down a button). Recognised keys:
% c clear the window to black;
% C clear the window to white;
% w draw in white;
% r draw in red;
% g draw in green;
% b draw in blue;
% y draw in yellow;
% = increase the brush size;
% - decrease the brush size;
% q quit the program.
%
% Compile this program with
%
% mmc --make scribble -L /usr/X11/lib -l X11
%
% ensuring that easyx.m and xlib.m are in the same directory. You may also
% need to change /usr/X11/lib to something like /usr/X11R6/lib on some
% systems.
%
%-----------------------------------------------------------------------------%
:- module scribble.
:- interface.
:- import_module io.
:- pred main(io :: di, io :: uo) is det.
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module easyx.
:- import_module float.
:- import_module list.
:- import_module std_util.
:- type maybexy == maybe({float, float}).
main(!IO) :-
easyx.open_display(Display, !IO),
easyx.create_window(Display, "scribble", 300, 300, Window, !IO),
easyx.set_line_attributes(Window, ratio(0.01), round, round, !IO),
scribble(Window, 0.01, no, !IO).
:- pred scribble(window::in, float::in, maybe({float, float})::in,
io::di, io::uo) is det.
scribble(Window, Size0, MaybeXY0, !IO) :-
easyx.get_next_event(Window, Event, !IO),
( if sm(Event, Size0, MaybeXY0, Size, MaybeXY, Drawing) then
easyx.draw(Window, Drawing, !IO),
easyx.flush(Window, !IO),
scribble(Window, Size, MaybeXY, !IO)
else if Event \= key_press(_, _, _, "q") then
scribble(Window, Size0, MaybeXY0, !IO)
else
true
).
% The scribble state machine...
%
:- pred sm(event::in, float::in, maybexy::in, float::out, maybexy::out,
drawing::out) is semidet.
sm( key_press(_, _, _, "c"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("black"), filled_rectangle(0.0, 0.0, 1.0, 1.0)]
).
sm( key_press(_, _, _, "C"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("white"), filled_rectangle(0.0, 0.0, 1.0, 1.0)]
).
sm( key_press(_, _, _, "w"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("white")]
).
sm( key_press(_, _, _, "r"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("red")]
).
sm( key_press(_, _, _, "g"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("green")]
).
sm( key_press(_, _, _, "b"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("blue")]
).
sm( key_press(_, _, _, "y"), Size, MaybeXY, Size, MaybeXY,
[colour_from_name("yellow")]
).
sm( key_press(_, _, _, "equal"), Size, MaybeXY, Size + 0.01, MaybeXY,
[line_attributes(ratio(Size + 0.01), round, round)]
).
sm( key_press(_, _, _, "minus"), Size, MaybeXY, Size - 0.01, MaybeXY,
[line_attributes(ratio(Size - 0.01), round, round)]
).
sm( button_release(_, _, _, _), Size, _MaybeXY, Size, no,
[]
).
sm( button_press(X, Y, _, _), Size, no, Size, yes({X, Y}),
[filled_circle(X, Y, Size)]
).
sm( pointer_motion(X, Y, _), Size, yes({X0, Y0}), Size, yes({X, Y}),
[line(X0, Y0, X, Y)]
).
bounce.m:
%-----------------------------------------------------------------------------%
% Copyright (C) 2004 The University of Melbourne.
% 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.
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%---------------------------------------------------------------------------%
% bounce.m
% Ralph Becket <rafe at cs.mu.oz.au>
% Fri Sep 17 16:19:38 EST 2004
%
% A simple game written using the easyx module. Balls enter the playing
% area from the top left and must be kept in play by using the mouse-
% controlled bat to prevent them from falling off the screen. Every time
% a ball is missed, the player's bat shrinks a little. The game is over
% when there are no more balls in play.
%
% Hit `q' to quit the game at any time.
%
% To compile this game, ensure the easyx.m and xlib.m modules are in
% the same directory and then do
%
% mmc --make bounce -L /usr/X11/lib -l X11
%
% (On some systems the -L argument may need changing, e.g. to /usr/X11R6/lib.)
%
%-----------------------------------------------------------------------------%
:- module bounce.
:- interface.
:- import_module io.
:- pred main(io :: di, io :: uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module bool.
:- import_module easyx.
:- import_module float.
:- import_module int.
:- import_module list.
:- import_module random.
:- import_module std_util.
:- import_module string.
:- import_module time.
:- pragma foreign_decl("C", "#include <unistd.h>").
:- type object
---> ball(
ball_x :: float,
ball_y :: float,
ball_vx :: float,
ball_vy :: float,
ball_radius :: float,
ball_colour :: colour
)
; oops(
oops_x :: float,
oops_y :: float,
oops_colour :: colour
).
:- type objects == list(object).
:- type paddle
---> paddle(
paddle_x :: float,
paddle_y :: float,
paddle_width :: float,
paddle_colour :: colour,
paddle_score :: int
).
:- type colours == list(colour).
:- type rnd == random.supply.
:- func gravity = float.
gravity = 0.0001.
:- func odds_of_new_object = int.
odds_of_new_object = 200.
:- func initial_paddle_x = float.
initial_paddle_x = 0.5.
:- func initial_paddle_y = float.
initial_paddle_y = 0.1.
:- func initial_paddle_width = float.
initial_paddle_width = 0.2.
:- func oops_y_velocity = float.
oops_y_velocity = 0.02.
%-----------------------------------------------------------------------------%
:- pred move_objects(paddle::in, paddle::out, objects::in, objects::out)
is det.
move_objects(!Paddle, [], [] ).
move_objects(!Paddle, [Object | Objects0], Objects) :-
move_objects(!Paddle, Objects0, Objects1),
move_object(Object, !Paddle, Objects1, Objects).
:- pred move_object(object::in, paddle::in, paddle::out,
objects::in, objects::out) is det.
move_object(ball(X0, Y0, VX0, VY0, Radius, Colour), !Paddle, !Objects) :-
!.Paddle = paddle(PX, PY, PWidth0, PColour, PScore0),
X = X0 + VX0,
( if VX0 < 0.0, X - Radius < 0.0 then
VX = -VX0
else if 0.0 < VX0, 1.0 < X + Radius then
VX = -VX0
else
VX = VX0
),
Y = Y0 + VY0,
( if PX < X + Radius, X - Radius < PX + PWidth0,
Y0 - Radius > PY, PY >= Y - Radius
then
VY = -VY0 - gravity,
PScore = PScore0 + 1
else
VY = VY0 - gravity,
PScore = PScore0
),
( if Y + Radius > 0.0 then
PWidth = PWidth0,
Object = ball(X, Y, VX, VY, Radius, Colour)
else
PWidth = 0.9 * PWidth0,
Object = oops(X, Y, Colour)
),
!:Objects = [Object | !.Objects],
!:Paddle = paddle(PX, PY, PWidth, PColour, PScore).
move_object(oops(X, Y, Colour), !Paddle, !Objects) :-
( if Y > 1.1 then
true
else
!:Objects = [oops(X, Y + oops_y_velocity, Colour) | !.Objects]
).
:- func move_paddle(paddle, float) = paddle.
move_paddle(Paddle, X) = (Paddle^paddle_x := X - (Paddle^paddle_width / 2.0)).
:- func paddle_drawing(paddle) = drawing.
paddle_drawing(paddle(X, Y, Width, Colour, Score)) =
[
line_attributes(pixels(10), round, round),
colour(Colour),
line(X, 1.0 - Y, X + Width, 1.0 - Y),
text(1.0, 1.0, 1.0, 1.0, format("%d bounces", [i(Score)]))
].
:- func objects_drawing(colour, objects) = drawing.
objects_drawing(BorderColour, Objects) =
[ line_attributes(pixels(4), round, round)
| foldl(add_object_drawing(BorderColour), Objects, [])
].
:- func add_object_drawing(colour, object, drawing) = drawing.
add_object_drawing(BorderColour, ball(X, Y, _, _, Radius, Colour), Drawing) =
[
colour(BorderColour),
circle(X, 1.0 - Y, Radius),
colour(Colour),
filled_circle(X, 1.0 - Y, Radius)
| Drawing
].
add_object_drawing(_, oops(X, Y, Colour), Drawing) =
[
colour(Colour),
text(X, 1.0 - Y, "oops")
| Drawing
].
:- func new_paddle(colour) = paddle.
new_paddle(Colour) =
paddle(initial_paddle_x, initial_paddle_y, initial_paddle_width, Colour,
0).
:- pred add_new_ball(colours::in, objects::in, objects::out,
rnd::in, rnd::out) is det.
add_new_ball(Colours, Objects, [Ball | Objects], !Rnd) :-
random.random(Y0, !Rnd),
random.random(VX0, !Rnd),
random.random(R0, !Rnd),
random.random(N0, !Rnd),
X = 0.0,
Y = 0.75 + float(Y0 mod 25) / 100.0,
VX = 0.001 + float(VX0 mod 100) / 10000.0,
VY = 0.0,
R = 0.025 + float(R0 mod 25) / 1000.0,
C = index0_det(Colours, 2 + (N0 / 1000) mod (length(Colours) - 2)),
Ball = ball(X, Y, VX, VY, R, C).
%-----------------------------------------------------------------------------%
main(!IO) :-
easyx.open_display(Display, !IO),
easyx.create_window(Display, "bounce", 600, 600, Window, !IO),
easyx.load_font(Window, "*-helvetica-*-r-*-34-*", Font, !IO),
easyx.set_font(Window, Font, !IO),
easyx.set_line_attributes(Window, pixels(0), round, mitre, !IO),
easyx.get_colour_from_name(Window, "black", Black, !IO),
easyx.get_colour_from_name(Window, "white", White, !IO),
easyx.get_colour_from_name(Window, "red", Red, !IO),
easyx.get_colour_from_name(Window, "green", Green, !IO),
easyx.get_colour_from_name(Window, "blue", Blue, !IO),
easyx.get_colour_from_name(Window, "yellow", Yellow, !IO),
Colours = [Black, White, Red, Green, Blue, Yellow],
time.time(Time, !IO),
TM = localtime(Time),
random.init(60 * TM^tm_min + TM^tm_sec, Rnd0),
add_new_ball(Colours, [], Objects, Rnd0, Rnd),
Paddle = new_paddle(White),
play(Window, Colours, Paddle, _, Objects, _, Rnd, _, !IO).
:- pred play(window::in, colours::in, paddle::in, paddle::out,
objects::in, objects::out, rnd::in, rnd::out,
io::di, io::uo) is det.
play(Window, Colours, !Paddle, !Objects, !Rnd, !IO) :-
Black = index0_det(Colours, 0),
White = index0_det(Colours, 1),
easyx.set_colour(Window, Black, !IO),
easyx.clear_window(Window, !IO),
( if !.Objects \= [] then
maybe_add_object(Colours, !Objects, !Rnd)
else
easyx.set_colour(Window, White, !IO),
easyx.draw_text(Window, 0.5, 0.5, 0.5, 0.5, "Game Over", !IO)
),
move_objects(!Paddle, !Objects),
Drawing = paddle_drawing(!.Paddle) ++ objects_drawing(Black, !.Objects),
easyx.draw(Window, Drawing, !IO),
easyx.flush(Window, !IO),
u_sleep(20000, !IO),
process_events(Window, Quit, !Paddle, !IO),
( if Quit = yes
then true
else play(Window, Colours, !Paddle, !Objects, !Rnd, !IO)
).
:- pred process_events(window::in, bool::out, paddle::in, paddle::out,
io::di, io::uo) is det.
process_events(Window, Quit, !Paddle, !IO) :-
easyx.get_next_event_if_any(Window, MaybeEvent, !IO),
( if MaybeEvent = yes(key_press(_, _, _, "q")) then
Quit = yes
else if MaybeEvent = yes(pointer_motion(X, _, _)) then
!:Paddle = move_paddle(!.Paddle, X),
process_events(Window, Quit, !Paddle, !IO)
else if MaybeEvent = yes(_) then
process_events(Window, Quit, !Paddle, !IO)
else
Quit = no
).
:- pred maybe_add_object(colours::in, objects::in, objects::out,
rnd::in, rnd::out) is det.
maybe_add_object(Colours, !Objects, !Rnd) :-
random.random(N, !Rnd),
( if N mod odds_of_new_object = 0
then add_new_ball(Colours, !Objects, !Rnd)
else true
).
:- pred u_sleep(int::in, io::di, io::uo) is det.
:- pragma foreign_proc("C", u_sleep(N::in, IO0::di, IO::uo),
[will_not_call_mercury, thread_safe, promise_pure],
"
usleep(N);
IO = IO0;
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
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