[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