[m-dev.] New ncurses binding

Ralph Becket rbeck at microsoft.com
Wed Jan 24 02:18:36 AEDT 2001


Estimated hours taken: 4

This is a somewhat more comprehensive ncurses binding that also
uses the panel library to provide windowing facilities (rather
than doing it in Mercury).  I have attempted to make only minimal
changes to the C interface and removed a level of indirection from
accessing the panel interface.

extras/curs/curs.m:
	The basic ncurses binding; includes curs__panel which handles
	the windowing operations.

extras/curs/Mmakefile:
	Mmakefile for the above.

extras/curs/samples/demo.m:
	Small demonstration of curs in action.

extras/curs/samples/Mmakefile:
	Mmakefile for the above.

========================
extras/curs/curs.m:
%
----------------------------------------------------------------------------
%
% curs.m
% Ralph Becket <rbeck at microsoft.com>
% Thu Jan 11 13:47:25 GMT 2001
% vim: ts=4 sw=4 et tw=0 wm=0 ff=unix ft=mercury
%
%
%   THIS FILE IS HEREBY CONTRIBUTED TO THE MERCURY PROJECT TO
%   BE RELEASED UNDER WHATEVER LICENCE IS DEEMED APPROPRIATE
%   BY THE ADMINISTRATORS OF THE MERCURY PROJECT.
%
%
% Simplified Mercury interface to the ncurses and panel libraries.
%
% This is largely inspired by Tomas Conway and Robert Jeschofnik's
% mcurses module; it is intended to more closely match the facilities
% offered by the ncurses package and leave the issue of window management
% to the ncurses and panel libraries rather than doing so in Mercury.
%
% XXX This module no error checking.
%
% NOTE You will need to include `-lpanel -lncurses' in MLLIBS when
% linking against this module.
%
%
----------------------------------------------------------------------------
%

:- module curs.

:- interface.

:- import_module io, string, char, int.



    % Start a curses session (colour, unbuffered input, no echoing, 
    % invisible cursor if possible, scrolling on when output past
    % the bottom of the main display and any windows).
    %
:- pred start(io__state::di, io__state::uo) is det.

    % Close a curses session; necessary to return the tty to a sensible
    % state.
    %
:- pred stop(io__state::di, io__state::uo) is det.

    % A wrapper predicate that handles calling start and stop.
    %
% :- pred session(pred(io__state::di, io__state::uo) is det,
            % io__state::di, io__state::uo) is det.
:- pred session(pred(io__state, io__state), io__state, io__state).
:- mode session(pred(di, uo) is det, di, uo) is det.

    % Number of rows and columns on the physical screen.
    %
:- pred rows_cols(int::out, int::out, io__state::di, io__state::uo) is det.

    % Move the virtual cursor to given row and column; (0, 0) are the
    % coordinates for the upper left hand corner of the display.
    %
:- pred move(int::in, int::in, io__state::di, io__state::uo) is det.

    % Clear the whole display.
    %
:- pred clear(io__state::di, io__state::uo) is det.

    % Output a character (with the given attributes) and advance the cursor.
    % Note that char codes are passed rather than plain chars.
    %
:- pred addch(attr::in, int::in, io__state::di, io__state::uo) is det.

    % Output a string (with the given attributes) and advance the cursor.
    %
:- pred addstr(attr::in, string::in, io__state::di, io__state::uo) is det.

    % Turn on/off or set attributes that will be applied by default.
    %
:- pred attr_on(attr::in, io__state::di, io__state::uo) is det.
:- pred attr_off(attr::in, io__state::di, io__state::uo) is det.
:- pred attr_set(attr::in, io__state::di, io__state::uo) is det.

    % Update the display.  Changes made to the display are not made
    % visible until doupdate is called.
    %
:- pred doupdate(io__state::di, io__state::uo) is det.

    % Read a character from the keyboard (unbuffered) and translate it
    % if necessary.
    %
:- pred getch(int::out, io__state::di, io__state::uo) is det.



    % Draws a border around the inside edge of the display.
    %
:- pred border(io__state::di, io__state::uo) is det.

    % Draws an horizontal line of char codes C length N moving to the right.
    %
:- pred hline(int::in, int::in, io__state::di, io__state::uo) is det.

    % Draws a vertical line of char codes C length N moving down.
    %
:- pred vline(int::in, int::in, io__state::di, io__state::uo) is det.



    % Various key code translations outside the normal ASCII range.
    %
:- func key_down = int.
:- func key_up = int.
:- func key_left = int.
:- func key_right = int.
:- func key_home = int.
:- func key_backspace = int.
:- func key_f(int) = int.               % Function key no. (0 to 63).
:- func key_del = int.
:- func key_ins = int.
:- func key_pageup = int.
:- func key_pagedown = int.
:- func key_a1 = int.                   % Key pad upper left.
:- func key_a3 = int.                   % Key pad upper right.
:- func key_b2 = int.                   % Key pad middle centre.
:- func key_c1 = int.                   % Key pad lower left.
:- func key_c3 = int.                   % Key pad lower right.
:- func key_enter = int.                % Key pad enter.
:- func key_end = int.
:- func key_resize = int.               % Resize event.



    % Special char codes (not always available).
    %
                                        % Default   Description
                                        % -------   -----------
:- func acs_block = int.                % #         solid square block
:- func acs_board = int.                % #         board of squares
:- func acs_btee = int.                 % +         bottom tee
:- func acs_bullet = int.               % o         bullet
:- func acs_ckboard = int.              % :         checker board (stipple)
:- func acs_darrow = int.               % v         arrow pointing down
:- func acs_degree = int.               % '         degree symbol
:- func acs_diamond = int.              % +         diamond
:- func acs_gequal = int.               % >         greater-than-or-equal-to
:- func acs_hline = int.                % -         horizontal line
:- func acs_lantern = int.              % #         lantern symbol
:- func acs_larrow = int.               % <         arrow pointing left
:- func acs_lequal = int.               % <         less-than-or-equal-to
:- func acs_llcorner = int.             % +         lower left-hand corner
:- func acs_lrcorner = int.             % +         lower right-hand corner
:- func acs_ltee = int.                 % +         left tee
:- func acs_nequal = int.               % !         not-equal
:- func acs_pi = int.                   % *         greek pi
:- func acs_plminus = int.              % #         plus/minus
:- func acs_plus = int.                 % +         plus
:- func acs_rarrow = int.               % >         arrow pointing right
:- func acs_rtee = int.                 % +         right tee
:- func acs_s1 = int.                   % -         scan line 1
:- func acs_s3 = int.                   % -         scan line 3
:- func acs_s7 = int.                   % -         scan line 7
:- func acs_s9 = int.                   % _         scan line 9
:- func acs_sterling = int.             % f         pound-sterling symbol
:- func acs_ttee = int.                 % +         top tee
:- func acs_uarrow = int.               % ^         arrow pointing up
:- func acs_ulcorner = int.             % +         upper left-hand corner
:- func acs_urcorner = int.             % +         upper right-hand corner
:- func acs_vline = int.                % |         vertical line



    % Character attributes.
    %
:- type attr.

:- func attr + attr = attr.             % Combines attributes.

:- func normal = attr.
:- func standout = attr.
:- func underline = attr.
:- func reverse = attr.
:- func blink = attr.
:- func dim = attr.
:- func bold = attr.
:- func invis = attr.
:- func fg_bg(colour, colour) = attr.   % Provide the appropriate colour
pair no

    % Colour attributes.
    %
:- type colour.

:- func black = colour.
:- func red = colour.
:- func green = colour.
:- func yellow = colour.
:- func blue = colour.
:- func magenta = colour.
:- func cyan = colour.
:- func white = colour.

    %
------------------------------------------------------------------------ %
    %
------------------------------------------------------------------------ %

        % Panels are windows over the main display; they may be
        % stacked, moved, ordered and hidden.  Contents of panels
        % closer to the top of the stack obscure the parts of panels
        % they overlap that are lower in the stack.
        %
    :- module panel.

    :- interface.



    :- type panel.

        % new(Rows, Cols, Row, Col, Attr, Panel) creates a new panel
        % Panel whose size is given by (Rows, Cols) and whose position
        % on the display is given by (Row, Col).  The new panel starts
        % visible and at the top of the stack.  The default attributes
        % for the panel are set to Attr.
        %
    :- pred new(int::in, int::in, int::in, int::in, attr::in, panel::out,
                io__state::di, io__state::uo) is det.

        % Destroy a panel.
        %
    :- pred delete(panel::in, io__state::di, io__state::uo) is det.

        % Raise/lower a panel to the top/bottom of the stack.
        %
    :- pred raise(panel::in, io__state::di, io__state::uo) is det.

    :- pred lower(panel::in, io__state::di, io__state::uo) is det.

        % Hide/reveal a panel (revealing places it at the top of the stack).
        %
    :- pred hide(panel::in, io__state::di, io__state::uo) is det.

    :- pred reveal(panel::in, io__state::di, io__state::uo) is det.

        % Move a panel to (Row, Col) on the display.
        %
    :- pred relocate(panel::in, int::in, int::in,
                io__state::di, io__state::uo) is det.

        % Clear a panel.
        %
    :- pred clear(panel::in, io__state::di, io__state::uo) is det.

        % Move the virtual cursor to given row and column; (0, 0) are the
        % coordinates for the upper left hand corner of the panel.
        %
    :- pred move(panel::in, int::in, int::in,
                io__state::di, io__state::uo) is det.

        % Add a char/string to a panel with the given attributes.
        % Note that char codes are passed rather than plain chars.
        %
    :- pred addch(panel::in, attr::in, int::in,
                io__state::di, io__state::uo) is det.

    :- pred addstr(panel::in, attr::in, string::in,
                io__state::di, io__state::uo) is det.

        % Turn on/off or set attributes that will be applied by default.
        %
    :- pred attr_on(panel::in, attr::in, io__state::di, io__state::uo) is
det.
    :- pred attr_off(panel::in, attr::in, io__state::di, io__state::uo) is
det.
    :- pred attr_set(panel::in, attr::in, io__state::di, io__state::uo) is
det.

        % Update the display (also calls doupdate).
        % NOTE that doupdate does not call update_panels.
        %
    :- pred update_panels(io__state::di, io__state::uo) is det.



        % Draws a border around the inside edge of the display.
        %
    :- pred border(panel::in, io__state::di, io__state::uo) is det.

        % Draws an horizontal line of length N moving to the right.
        %
    :- pred hline(panel::in, int::in, int::in,
                io__state::di, io__state::uo) is det.

        % Draws a vertical line of length N moving down.
        %
    :- pred vline(panel::in, int::in, int::in,
                io__state::di, io__state::uo) is det.

    :- end_module panel.

    %
------------------------------------------------------------------------ %
    %
------------------------------------------------------------------------ %

%
----------------------------------------------------------------------------
%
%
----------------------------------------------------------------------------
%

:- implementation.

:- type attr == int.

:- type color == int.

%---------------------------------------------------------------------------
-%

    % Untimely ripp'd from Thomas Conway and Robert Jeschofnik's
    % basics.m module in their ncurses interface.

:- pragma c_code("

#ifdef CONSERVATIVE_GC

/*      
** The addresses of the closures that we pass to curses
** will be stored by curses in malloc()'ed memory.
** However, it is essential that these pointers be
** visible to the garbage collector, otherwise it will
** think that the closures are unreferenced and reuse the storage.
** Hence we redefine malloc() and friends to call GC_malloc().
*/

void *malloc(size_t s)
{
        return GC_MALLOC(s);
}

void *calloc(size_t s, size_t n)
{
        void *t;
        t = GC_MALLOC(s*n);
        memset(t, 0, s*n);
        return t;
}

void *realloc(void *ptr, size_t s)
{
        return GC_REALLOC(ptr, s);
}

void free(void *ptr)
{
        GC_FREE(ptr);
}

#endif

").

%---------------------------------------------------------------------------
-%

:- pragma c_header_code("

#include <ncurses.h>
#include <panel.h>

        /*
        ** XXX We assume 64 available colour pairs and that the COLOR_s
        ** are assigned 0..7 (this is true in ncurses.h)
        */
#define FG_BG(fg, bg)          (((fg) << 3) | (bg))

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( start(IO0::di, IO::uo),
    [will_not_call_mercury], "

    initscr();                          /* Start the show */

    start_color();                      /* Enable colour */

    nonl();                             /* Don't translate \n */
    scrollok(stdscr, TRUE);             /* Scroll when output past bottom */
    leaveok(stdscr, TRUE);              /* Turn off the cursor */
    keypad(stdscr, TRUE);               /* Translate compound input chars */
    noecho();                           /* Don't echo typed characters */
    cbreak();                           /* Disable line buffering */

                                        /* Set up default colour pairs */
init_pair(FG_BG(COLOR_BLACK, COLOR_BLACK),      COLOR_BLACK, COLOR_BLACK);
init_pair(FG_BG(COLOR_BLACK, COLOR_RED),        COLOR_BLACK, COLOR_RED);
init_pair(FG_BG(COLOR_BLACK, COLOR_GREEN),      COLOR_BLACK, COLOR_GREEN);
init_pair(FG_BG(COLOR_BLACK, COLOR_YELLOW),     COLOR_BLACK, COLOR_YELLOW);
init_pair(FG_BG(COLOR_BLACK, COLOR_BLUE),       COLOR_BLACK, COLOR_BLUE);
init_pair(FG_BG(COLOR_BLACK, COLOR_MAGENTA),    COLOR_BLACK, COLOR_MAGENTA);
init_pair(FG_BG(COLOR_BLACK, COLOR_CYAN),       COLOR_BLACK, COLOR_CYAN);
init_pair(FG_BG(COLOR_BLACK, COLOR_WHITE),      COLOR_BLACK, COLOR_WHITE);
init_pair(FG_BG(COLOR_RED, COLOR_BLACK),        COLOR_RED, COLOR_BLACK);
init_pair(FG_BG(COLOR_RED, COLOR_RED),          COLOR_RED, COLOR_RED);
init_pair(FG_BG(COLOR_RED, COLOR_GREEN),        COLOR_RED, COLOR_GREEN);
init_pair(FG_BG(COLOR_RED, COLOR_YELLOW),       COLOR_RED, COLOR_YELLOW);
init_pair(FG_BG(COLOR_RED, COLOR_BLUE),         COLOR_RED, COLOR_BLUE);
init_pair(FG_BG(COLOR_RED, COLOR_MAGENTA),      COLOR_RED, COLOR_MAGENTA);
init_pair(FG_BG(COLOR_RED, COLOR_CYAN),         COLOR_RED, COLOR_CYAN);
init_pair(FG_BG(COLOR_RED, COLOR_WHITE),        COLOR_RED, COLOR_WHITE);
init_pair(FG_BG(COLOR_GREEN, COLOR_BLACK),      COLOR_GREEN, COLOR_BLACK);
init_pair(FG_BG(COLOR_GREEN, COLOR_RED),        COLOR_GREEN, COLOR_RED);
init_pair(FG_BG(COLOR_GREEN, COLOR_GREEN),      COLOR_GREEN, COLOR_GREEN);
init_pair(FG_BG(COLOR_GREEN, COLOR_YELLOW),     COLOR_GREEN, COLOR_YELLOW);
init_pair(FG_BG(COLOR_GREEN, COLOR_BLUE),       COLOR_GREEN, COLOR_BLUE);
init_pair(FG_BG(COLOR_GREEN, COLOR_MAGENTA),    COLOR_GREEN, COLOR_MAGENTA);
init_pair(FG_BG(COLOR_GREEN, COLOR_CYAN),       COLOR_GREEN, COLOR_CYAN);
init_pair(FG_BG(COLOR_GREEN, COLOR_WHITE),      COLOR_GREEN, COLOR_WHITE);
init_pair(FG_BG(COLOR_YELLOW, COLOR_BLACK),     COLOR_YELLOW, COLOR_BLACK);
init_pair(FG_BG(COLOR_YELLOW, COLOR_RED),       COLOR_YELLOW, COLOR_RED);
init_pair(FG_BG(COLOR_YELLOW, COLOR_GREEN),     COLOR_YELLOW, COLOR_GREEN);
init_pair(FG_BG(COLOR_YELLOW, COLOR_YELLOW),    COLOR_YELLOW, COLOR_YELLOW);
init_pair(FG_BG(COLOR_YELLOW, COLOR_BLUE),      COLOR_YELLOW, COLOR_BLUE);
init_pair(FG_BG(COLOR_YELLOW, COLOR_MAGENTA),   COLOR_YELLOW,
COLOR_MAGENTA);
init_pair(FG_BG(COLOR_YELLOW, COLOR_CYAN),      COLOR_YELLOW, COLOR_CYAN);
init_pair(FG_BG(COLOR_YELLOW, COLOR_WHITE),     COLOR_YELLOW, COLOR_WHITE);
init_pair(FG_BG(COLOR_BLUE, COLOR_BLACK),       COLOR_BLUE, COLOR_BLACK);
init_pair(FG_BG(COLOR_BLUE, COLOR_RED),         COLOR_BLUE, COLOR_RED);
init_pair(FG_BG(COLOR_BLUE, COLOR_GREEN),       COLOR_BLUE, COLOR_GREEN);
init_pair(FG_BG(COLOR_BLUE, COLOR_YELLOW),      COLOR_BLUE, COLOR_YELLOW);
init_pair(FG_BG(COLOR_BLUE, COLOR_BLUE),        COLOR_BLUE, COLOR_BLUE);
init_pair(FG_BG(COLOR_BLUE, COLOR_MAGENTA),     COLOR_BLUE, COLOR_MAGENTA);
init_pair(FG_BG(COLOR_BLUE, COLOR_CYAN),        COLOR_BLUE, COLOR_CYAN);
init_pair(FG_BG(COLOR_BLUE, COLOR_WHITE),       COLOR_BLUE, COLOR_WHITE);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_BLACK),    COLOR_MAGENTA, COLOR_BLACK);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_RED),      COLOR_MAGENTA, COLOR_RED);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_GREEN),    COLOR_MAGENTA, COLOR_GREEN);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_YELLOW),   COLOR_MAGENTA,
COLOR_YELLOW);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_BLUE),     COLOR_MAGENTA, COLOR_BLUE);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_MAGENTA),  COLOR_MAGENTA,
COLOR_MAGENTA);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_CYAN),     COLOR_MAGENTA, COLOR_CYAN);
init_pair(FG_BG(COLOR_MAGENTA, COLOR_WHITE),    COLOR_MAGENTA, COLOR_WHITE);
init_pair(FG_BG(COLOR_CYAN, COLOR_BLACK),       COLOR_CYAN, COLOR_BLACK);
init_pair(FG_BG(COLOR_CYAN, COLOR_RED),         COLOR_CYAN, COLOR_RED);
init_pair(FG_BG(COLOR_CYAN, COLOR_GREEN),       COLOR_CYAN, COLOR_GREEN);
init_pair(FG_BG(COLOR_CYAN, COLOR_YELLOW),      COLOR_CYAN, COLOR_YELLOW);
init_pair(FG_BG(COLOR_CYAN, COLOR_BLUE),        COLOR_CYAN, COLOR_BLUE);
init_pair(FG_BG(COLOR_CYAN, COLOR_MAGENTA),     COLOR_CYAN, COLOR_MAGENTA);
init_pair(FG_BG(COLOR_CYAN, COLOR_CYAN),        COLOR_CYAN, COLOR_CYAN);
init_pair(FG_BG(COLOR_CYAN, COLOR_WHITE),       COLOR_CYAN, COLOR_WHITE);
init_pair(FG_BG(COLOR_WHITE, COLOR_BLACK),      COLOR_WHITE, COLOR_BLACK);
init_pair(FG_BG(COLOR_WHITE, COLOR_RED),        COLOR_WHITE, COLOR_RED);
init_pair(FG_BG(COLOR_WHITE, COLOR_GREEN),      COLOR_WHITE, COLOR_GREEN);
init_pair(FG_BG(COLOR_WHITE, COLOR_YELLOW),     COLOR_WHITE, COLOR_YELLOW);
init_pair(FG_BG(COLOR_WHITE, COLOR_BLUE),       COLOR_WHITE, COLOR_BLUE);
init_pair(FG_BG(COLOR_WHITE, COLOR_MAGENTA),    COLOR_WHITE, COLOR_MAGENTA);
init_pair(FG_BG(COLOR_WHITE, COLOR_CYAN),       COLOR_WHITE, COLOR_CYAN);
init_pair(FG_BG(COLOR_WHITE, COLOR_WHITE),      COLOR_WHITE, COLOR_WHITE);

    IO = IO0;
").

%
----------------------------------------------------------------------------
%

:- pragma c_code( stop(IO0::di, IO::uo),
    [will_not_call_mercury], "

    endwin();
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

session(P) -->
    start,
    P,
    stop.

%
----------------------------------------------------------------------------
%

:- pragma c_code( rows_cols(Rows::out, Cols::out, IO0::di, IO::uo),
    [will_not_call_mercury], "

    getmaxyx(stdscr, Rows, Cols);
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( move(Row::in, Col::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    move(Row, Col);
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( clear(IO0::di, IO::uo),
    [will_not_call_mercury], "

    clear();
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( addch(Attr::in, CharCode::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    addch((chtype)Attr | (chtype)CharCode);
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

addstr(Attr, Str) -->
    string__foldl(
        ( pred(Char::in, di, uo) is det --> addch(Attr, char__to_int(Char))
),
        Str
    ).

%
----------------------------------------------------------------------------
%

:- pragma c_code( attr_on(Attr::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    attron(Attr);
    IO = IO0;

").
:- pragma c_code( attr_off(Attr::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    attroff(Attr);
    IO = IO0;

").
:- pragma c_code( attr_set(Attr::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    attrset(Attr);
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( doupdate(IO0::di, IO::uo),
    [will_not_call_mercury], "

    doupdate();
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( getch(CharCode::out, IO0::di, IO::uo),
    [will_not_call_mercury], "

    CharCode = getch();
    IO = IO0;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( key_down = (K::out),
    [will_not_call_mercury], "
    K = KEY_DOWN;
").
:- pragma c_code( key_up = (K::out),
    [will_not_call_mercury], "
    K = KEY_UP;
").
:- pragma c_code( key_left = (K::out),
    [will_not_call_mercury], "
    K = KEY_LEFT;
").
:- pragma c_code( key_right = (K::out),
    [will_not_call_mercury], "
    K = KEY_RIGHT;
").
:- pragma c_code( key_home = (K::out),
    [will_not_call_mercury], "
    K = KEY_HOME;
").
:- pragma c_code( key_backspace = (K::out),
    [will_not_call_mercury], "
    K = KEY_BACKSPACE;
").
:- pragma c_code( key_f(N::in) = (K::out),
    [will_not_call_mercury], "
    K = KEY_F( N);
").
:- pragma c_code( key_del = (K::out),
    [will_not_call_mercury], "
    K = KEY_DC;
").
:- pragma c_code( key_ins = (K::out),
    [will_not_call_mercury], "
    K = KEY_IC;
").
:- pragma c_code( key_pageup = (K::out),
    [will_not_call_mercury], "
    K = KEY_NPAGE;
").
:- pragma c_code( key_pagedown = (K::out),
    [will_not_call_mercury], "
    K = KEY_PPAGE;
").
:- pragma c_code( key_a1 = (K::out),
    [will_not_call_mercury], "
    K = KEY_A1;
").
:- pragma c_code( key_a3 = (K::out),
    [will_not_call_mercury], "
    K = KEY_A3;
").
:- pragma c_code( key_b2 = (K::out),
    [will_not_call_mercury], "
    K = KEY_B2;
").
:- pragma c_code( key_c1 = (K::out),
    [will_not_call_mercury], "
    K = KEY_C1;
").
:- pragma c_code( key_c3 = (K::out),
    [will_not_call_mercury], "
    K = KEY_C3;
").
:- pragma c_code( key_enter = (K::out),
    [will_not_call_mercury], "
    K = KEY_ENTER;
").
:- pragma c_code( key_end = (K::out),
    [will_not_call_mercury], "
    K = KEY_END;
").
:- pragma c_code( key_resize = (K::out),
    [will_not_call_mercury], "
    K = KEY_RESIZE;
").

%
----------------------------------------------------------------------------
%

:- pragma c_code( acs_block = (C::out),
    [will_not_call_mercury], "
    C = ACS_BLOCK;
").
:- pragma c_code( acs_board = (C::out),
    [will_not_call_mercury], "
    C = ACS_BOARD;
").
:- pragma c_code( acs_btee = (C::out),
    [will_not_call_mercury], "
    C = ACS_BTEE;
").
:- pragma c_code( acs_bullet = (C::out),
    [will_not_call_mercury], "
    C = ACS_BULLET;
").
:- pragma c_code( acs_ckboard = (C::out),
    [will_not_call_mercury], "
    C = ACS_CKBOARD;
").
:- pragma c_code( acs_darrow = (C::out),
    [will_not_call_mercury], "
    C = ACS_DARROW;
").
:- pragma c_code( acs_degree = (C::out),
    [will_not_call_mercury], "
    C = ACS_DEGREE;
").
:- pragma c_code( acs_diamond = (C::out),
    [will_not_call_mercury], "
    C = ACS_DIAMOND;
").
:- pragma c_code( acs_gequal = (C::out),
    [will_not_call_mercury], "
    C = ACS_GEQUAL;
").
:- pragma c_code( acs_hline = (C::out),
    [will_not_call_mercury], "
    C = ACS_HLINE;
").
:- pragma c_code( acs_lantern = (C::out),
    [will_not_call_mercury], "
    C = ACS_LANTERN;
").
:- pragma c_code( acs_larrow = (C::out),
    [will_not_call_mercury], "
    C = ACS_LARROW;
").
:- pragma c_code( acs_lequal = (C::out),
    [will_not_call_mercury], "
    C = ACS_LEQUAL;
").
:- pragma c_code( acs_llcorner = (C::out),
    [will_not_call_mercury], "
    C = ACS_LLCORNER;
").
:- pragma c_code( acs_lrcorner = (C::out),
    [will_not_call_mercury], "
    C = ACS_LRCORNER;
").
:- pragma c_code( acs_ltee = (C::out),
    [will_not_call_mercury], "
    C = ACS_LTEE;
").
:- pragma c_code( acs_nequal = (C::out),
    [will_not_call_mercury], "
    C = ACS_NEQUAL;
").
:- pragma c_code( acs_pi = (C::out),
    [will_not_call_mercury], "
    C = ACS_PI;
").
:- pragma c_code( acs_plminus = (C::out),
    [will_not_call_mercury], "
    C = ACS_PLMINUS;
").
:- pragma c_code( acs_plus = (C::out),
    [will_not_call_mercury], "
    C = ACS_PLUS;
").
:- pragma c_code( acs_rarrow = (C::out),
    [will_not_call_mercury], "
    C = ACS_RARROW;
").
:- pragma c_code( acs_rtee = (C::out),
    [will_not_call_mercury], "
    C = ACS_RTEE;
").
:- pragma c_code( acs_s1 = (C::out),
    [will_not_call_mercury], "
    C = ACS_S1;
").
:- pragma c_code( acs_s3 = (C::out),
    [will_not_call_mercury], "
    C = ACS_S3;
").
:- pragma c_code( acs_s7 = (C::out),
    [will_not_call_mercury], "
    C = ACS_S7;
").
:- pragma c_code( acs_s9 = (C::out),
    [will_not_call_mercury], "
    C = ACS_S9;
").
:- pragma c_code( acs_sterling = (C::out),
    [will_not_call_mercury], "
    C = ACS_STERLING;
").
:- pragma c_code( acs_ttee = (C::out),
    [will_not_call_mercury], "
    C = ACS_TTEE;
").
:- pragma c_code( acs_uarrow = (C::out),
    [will_not_call_mercury], "
    C = ACS_UARROW;
").
:- pragma c_code( acs_ulcorner = (C::out),
    [will_not_call_mercury], "
    C = ACS_ULCORNER;
").
:- pragma c_code( acs_urcorner = (C::out),
    [will_not_call_mercury], "
    C = ACS_URCORNER;
").
:- pragma c_code( acs_vline = (C::out),
    [will_not_call_mercury], "
    C = ACS_VLINE;
").

%
----------------------------------------------------------------------------
%

:- pragma c_code( curs:((Attr1::in) + (Attr2::in)) = (Attr::out),
    [will_not_call_mercury], "

    Attr = (chtype)Attr1 | (chtype)Attr2;

").

%
----------------------------------------------------------------------------
%

:- pragma c_code( normal = (A::out),
    [will_not_call_mercury], "
    A = A_NORMAL;
").
:- pragma c_code( standout = (A::out),
    [will_not_call_mercury], "
    A = A_STANDOUT;
").
:- pragma c_code( underline = (A::out),
    [will_not_call_mercury], "
    A = A_UNDERLINE;
").
:- pragma c_code( reverse = (A::out),
    [will_not_call_mercury], "
    A = A_REVERSE;
").
:- pragma c_code( blink = (A::out),
    [will_not_call_mercury], "
    A = A_BLINK;
").
:- pragma c_code( dim = (A::out),
    [will_not_call_mercury], "
    A = A_DIM;
").
:- pragma c_code( bold = (A::out),
    [will_not_call_mercury], "
    A = A_BOLD;
").
:- pragma c_code( invis = (A::out),
    [will_not_call_mercury], "
    A = A_INVIS;
").
:- pragma c_code( fg_bg(Fg::in, Bg::in) = (A::out),
    [will_not_call_mercury], "
    A = COLOR_PAIR(FG_BG(Fg, Bg));
").

%
----------------------------------------------------------------------------
%

:- pragma c_code( black = (C::out),
    [will_not_call_mercury], "
    C = COLOR_BLACK;
").
:- pragma c_code( red = (C::out),
    [will_not_call_mercury], "
    C = COLOR_RED;
").
:- pragma c_code( green = (C::out),
    [will_not_call_mercury], "
    C = COLOR_GREEN;
").
:- pragma c_code( yellow = (C::out),
    [will_not_call_mercury], "
    C = COLOR_YELLOW;
").
:- pragma c_code( blue = (C::out),
    [will_not_call_mercury], "
    C = COLOR_BLUE;
").
:- pragma c_code( magenta = (C::out),
    [will_not_call_mercury], "
    C = COLOR_MAGENTA;
").
:- pragma c_code( cyan = (C::out),
    [will_not_call_mercury], "
    C = COLOR_CYAN;
").
:- pragma c_code( white = (C::out),
    [will_not_call_mercury], "
    C = COLOR_WHITE;
").

%
----------------------------------------------------------------------------
%

:- pragma c_code( border(IO0::di, IO::uo),
    [will_not_call_mercury], "

    border(0, 0, 0, 0, 0, 0, 0, 0);
    IO = IO0;

").

:- pragma c_code( hline(C::in, N::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    hline(C, N);
    IO = IO0;

").

:- pragma c_code( vline(C::in, N::in, IO0::di, IO::uo),
    [will_not_call_mercury], "

    vline(C, N);
    IO = IO0;

").

    %
------------------------------------------------------------------------ %
    %
------------------------------------------------------------------------ %

    :- module panel.

    :- implementation.

    :- type panel == c_pointer.

    %
------------------------------------------------------------------------ %

    :- pragma c_header_code("

    #include <ncurses.h>
    #include <panel.h>

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( new(Rows::in, Cols::in, Row::in, Col::in, Attr::in,
                            Panel::out, IO0::di, IO::uo),
        [will_not_call_mercury], "

        WINDOW *w = newwin(Rows, Cols, Row, Col);
        scrollok(w, TRUE);
        wattrset(w, Attr);
        wclear(w);
        (PANEL *)Panel = new_panel(w);

        IO = IO0;
    
    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( delete(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        delwin(panel_window((PANEL *)Panel));
        del_panel((PANEL *)Panel);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( raise(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        top_panel((PANEL *)Panel);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( lower(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        bottom_panel((PANEL *)Panel);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( hide(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        hide_panel((PANEL *)Panel);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( reveal(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        show_panel((PANEL *)Panel);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( relocate(Panel::in, Row::in, Col::in, IO0::di,
IO::uo),
        [will_not_call_mercury], "

        move_panel((PANEL *)Panel, Row, Col);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( clear(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wclear(panel_window((PANEL *)Panel));

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( move(Panel::in, Row::in, Col::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wmove(panel_window((PANEL *)Panel), Row, Col);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( addch(Panel::in, Attr::in, CharCode::in, IO0::di,
IO::uo),
        [will_not_call_mercury], "

        waddch(panel_window((PANEL *)Panel), (chtype)Attr |
(chtype)CharCode);

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    addstr(Panel, Attr, Str) -->
        string__foldl(
            ( pred(Char::in, di, uo) is det -->
                addch(Panel, Attr, char__to_int(Char))
            ),
            Str
        ).

    %
------------------------------------------------------------------------ %

    :- pragma c_code( attr_on(Panel::in, Attr::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wattron(panel_window((PANEL *)Panel), Attr);
        IO = IO0;

    ").
    :- pragma c_code( attr_off(Panel::in, Attr::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wattroff(panel_window((PANEL *)Panel), Attr);
        IO = IO0;

    ").
    :- pragma c_code( attr_set(Panel::in, Attr::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wattrset(panel_window((PANEL *)Panel), Attr);
        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( update_panels(IO0::di, IO::uo),
        [will_not_call_mercury], "

        update_panels();
        doupdate();

        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- pragma c_code( border(Panel::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wborder(panel_window((PANEL *)Panel), 0, 0, 0, 0, 0, 0, 0, 0);
        IO = IO0;

    ").

    :- pragma c_code( hline(Panel::in, C::in, N::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        whline(panel_window((PANEL *)Panel), C, N);
        IO = IO0;

    ").

    :- pragma c_code( vline(Panel::in, C::in, N::in, IO0::di, IO::uo),
        [will_not_call_mercury], "

        wvline(panel_window((PANEL *)Panel), C, N);
        IO = IO0;

    ").

    %
------------------------------------------------------------------------ %

    :- end_module panel.

    %
------------------------------------------------------------------------ %
    %
------------------------------------------------------------------------ %

%
----------------------------------------------------------------------------
%
%
----------------------------------------------------------------------------
%
================================
extras/curs/Mmakefile
# Do the following:
#
# $ mmake depend
# $ mmake
#
# And to install...
#
# $ mmake install

# Edit this if you want to install the library elsewhere.
INSTALL_PREFIX = $(HOME)/local/mercury

MAIN_TARGET = libcurs
depend: curs.depend
install: $(MAIN_TARGET).install
================================
extras/curs/samples/demo.m
%
----------------------------------------------------------------------------
%
% Ralph Becket <rbeck at microsoft.com>
% Tue Jan 23 10:05:05 GMT 2001
% vim: ts=4 sw=4 et tw=0 wm=0 ff=unix ft=mercury
%
%
%   THIS FILE IS HEREBY CONTRIBUTED TO THE MERCURY PROJECT TO
%   BE RELEASED UNDER WHATEVER LICENCE IS DEEMED APPROPRIATE
%   BY THE ADMINISTRATORS OF THE MERCURY PROJECT.
%
%
%
----------------------------------------------------------------------------
%

:- module demo.

:- interface.

:- import_module io.



:- pred main(io__state::di, io__state::uo) is det.

%
----------------------------------------------------------------------------
%
%
----------------------------------------------------------------------------
%

:- implementation.

:- import_module int, list, string, curs, curs__panel.

:- type panel_data
    --->    panel_data(
                panel   ::  panel,
                row     ::  int,
                col     ::  int
            ).

%
----------------------------------------------------------------------------
%

main -->

    start,

    rows_cols(Rows, Cols),
    { MidRow = Rows // 2 },
    { MidCol = Cols // 2 },
    { PanelRows = MidRow // 2 },
    { PanelCols = MidCol // 2 },

    move(0, 0),
    addstr(normal, string__format("display size: %dx%d", [i(Rows),
i(Cols)])),
    move(1, 0),
    addstr(normal, "1 2 3 4 : select & raise panel"),
    move(2, 0),
    addch(normal, acs_larrow), addch(normal, 0' ),
    addch(normal, acs_darrow), addch(normal, 0' ),
    addch(normal, acs_uarrow), addch(normal, 0' ),
    addch(normal, acs_rarrow), addch(normal, 0' ),
    addstr(normal, ": move panel"),
    move(3, 0),
    addstr(normal, "      q : quit"),

    { R1 = MidRow - PanelRows - 1, C1 = MidCol - PanelCols - 1 },
    { R2 = MidRow - PanelRows - 2, C2 = MidCol             - 2 },
    { R3 = MidRow             - 3, C3 = MidCol - PanelCols - 3 },
    { R4 = MidRow             - 4, C4 = MidCol             - 4 },

    new(PanelRows, PanelCols, R1, C1, fg_bg(black, yellow), Panel1),
    new(PanelRows, PanelCols, R2, C2, fg_bg(white, blue  ), Panel2),
    new(PanelRows, PanelCols, R3, C3, fg_bg(black, green ), Panel3),
    new(PanelRows, PanelCols, R4, C4, fg_bg(white, red   ), Panel4),

    border(Panel1), move(Panel1, 0, 1), addstr(Panel1, normal, " 1 "),
    border(Panel2), move(Panel2, 0, 1), addstr(Panel2, normal, " 2 "),
    border(Panel3), move(Panel3, 0, 1), addstr(Panel3, normal, " 3 "),
    border(Panel4), move(Panel4, 0, 1), addstr(Panel4, normal, " 4 "),

    { PanelData = [
        panel_data(Panel1, R1, C1),
        panel_data(Panel2, R2, C2),
        panel_data(Panel3, R3, C3),
        panel_data(Panel4, R4, C4)
    ] },

    main_loop(1, PanelData),

    stop.

%
----------------------------------------------------------------------------
%

:- pred main_loop(int, list(panel_data), io__state, io__state).
:- mode main_loop(in, in, di, uo) is det.

main_loop(P, PanelData) -->

    update_panels,

    getch(K),

    (      if { K = key_left  } then move_panel(P, PanelData,  0, -1)
      else if { K = key_right } then move_panel(P, PanelData,  0,  1)
      else if { K = key_up    } then move_panel(P, PanelData, -1,  0)
      else if { K = key_down  } then move_panel(P, PanelData,  1,  0)
      else if { K = 0'1       } then raise_panel(1, PanelData)
      else if { K = 0'2       } then raise_panel(2, PanelData)
      else if { K = 0'3       } then raise_panel(3, PanelData)
      else if { K = 0'4       } then raise_panel(4, PanelData)
      else if { K = 0'q       } then []
      else main_loop(P, PanelData)
    ).

%
----------------------------------------------------------------------------
%

:- pred move_panel(int, list(panel_data), int, int, io__state, io__state).
:- mode move_panel(in, in, in, in, di, uo) is det.

move_panel(P, PanelData0, DR, DC) -->
    { PD0 = list__index1_det(PanelData0, P) },
    { PD  = ((PD0
                    ^ row := PD0 ^ row + DR)
                    ^ col := PD0 ^ col + DC) },
    { PanelData = list__replace_nth_det(PanelData0, P, PD) },
    relocate(PD ^ panel, PD ^ row, PD ^ col),
    main_loop(P, PanelData).

%
----------------------------------------------------------------------------
%

:- pred raise_panel(int, list(panel_data), io__state, io__state).
:- mode raise_panel(in, in, di, uo) is det.

raise_panel(P, PanelData) -->
    { PD = list__index1_det(PanelData, P) },
    raise(PD ^ panel),
    main_loop(P, PanelData).

%
----------------------------------------------------------------------------
%
%
----------------------------------------------------------------------------
%
===================================
extras/curs/samples/Mmakefile
CURS_DIR = ..

MAIN_TARGET = demo
depend: $(MAIN_TARGET).depend

VPATH = $(CURS_DIR):$(MMAKE_VPATH)
MCFLAGS = -I$(CURS_DIR)
MLFLAGS = -R$(CURS_DIR) -L$(CURS_DIR)
MLLIBS = -lcurs -lpanel -lncurses
C2INITFLAGS = $(CURS_DIR)/curs.init
===================================

--
Ralph Becket      |      MSR Cambridge      |      rbeck at microsoft.com 
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------



More information about the developers mailing list