[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