[m-dev.] For review: new extras package - curses binding
Robert Ernst Johann JESCHOFNIK
rejj at cat.cs.mu.OZ.AU
Fri Jan 14 15:40:54 AEDT 2000
I guess this is for review by anyone..
Estimated hours taken: 8 (including getting to know curses a bit)
Add a new directory to the extras, containing a (partial) binding to
curses.
README:
Add the brief description for the curses binding to the list of what
is contained in the extras package.
curses/Mmakefile:
curses/basics.m:
curses/mcurses.m:
curses/misc.m:
curses/user.m:
New files implementing the mercury binding to curses.
curses/sample/Mmakefile:
curses/sample/smalltest.m:
A sample program using the mercury binding to curses.
Index: README
===================================================================
RCS file: /home/mercury1/repository//mercury/extras/README,v
retrieving revision 1.5
diff -u -r1.5 README
--- README 1999/03/15 08:56:53 1.5
+++ README 2000/01/13 05:17:52
@@ -12,6 +12,9 @@
A Mercury library package containing support for
complex and imaginary numbers.
+curses A Mercury library providing a (partial) binding to
+ curses.
+
dynamic_linking
An interface to the C functions dlopen(), dlsym(), etc.
that are supported by most modern Unix systems.
Index: curses/Mmakefile
===================================================================
RCS file: Mmakefile
diff -N Mmakefile
--- /dev/null Thu Mar 4 04:20:11 1999
+++ Mmakefile Thu Jan 13 15:37:30 2000
@@ -0,0 +1,2 @@
+depend: mcurses.depend
+default_target: libmcurses
Index: curses/basics.m
===================================================================
RCS file: basics.m
diff -N basics.m
--- /dev/null Thu Mar 4 04:20:11 1999
+++ basics.m Fri Jan 14 15:15:09 2000
@@ -0,0 +1,313 @@
+%----------------------------------------------------------------------------%
+% Copyright (C) 1994-2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury Distribution.
+%----------------------------------------------------------------------------%
+
+%----------------------------------------------------------------------------%
+%
+% File: basics.m
+% Main author: conway
+% Maintained by: rejj
+% Stability: Medium
+%
+% This module defines the low-level bindings to the C library for (n)curses.
+%
+% Please note that this is still a partial binding; it does not provide
+% complete curses functionality.
+%
+% See the man pages for ncurses for detailed information about using the
+% curses libraries.
+%
+%----------------------------------------------------------------------------%
+
+:- module mcurses:basics.
+:- interface.
+
+:- import_module char, int, io, string.
+
+ % Initilise curses. This is used by curse.m, and should not be called by the
+ % programmer.
+:- pred init(io__state, io__state).
+:- mode init(di, uo) is det.
+
+ % Shutdown curses. This is required before exiting your program, or else you
+ % will be left with a practically unusable terminal.
+:- pred endwin(io__state, io__state).
+:- mode endwin(di, uo) is det.
+
+ % Initilise the colour mode for curses. This must be called before attempting
+ % to use anything with colour.
+:- pred start_colour(io__state, io__state).
+:- mode start_colour(di, uo) is det.
+
+ % Update the curses screen.
+:- pred update(io__state, io__state).
+:- mode update(di, uo) is det.
+
+ % Perform a doupdate.
+ % (see the curses man page for descriptions of update and doupdate)
+:- pred doupdate(io__state, io__state).
+:- mode doupdate(di, uo) is det.
+
+ % Clear the curses screen.
+:- pred clear(io__state, io__state).
+:- mode clear(di, uo) is det.
+
+ % cursor(X, Y, IO0, IO)
+ % places the cursor at position X,Y
+:- pred cursor(int, int, io__state, io__state).
+:- mode cursor(in, in, di, uo) is det.
+
+ % Place a string on the screen, starting at the current cursor position
+:- pred putstr(string, io__state, io__state).
+:- mode putstr(in, di, uo) is det.
+
+ % Place a single character on the screen at the current cursor position
+:- pred putchar(char, io__state, io__state).
+:- mode putchar(in, di, uo) is det.
+
+ % cols(Cols, IO0, IO)
+ % retrieves the number of columns in the screen
+:- pred cols(int, io__state, io__state).
+:- mode cols(out, di, uo) is det.
+
+ % rows(Rows, IO0, IO)
+ % retrieves the number of rows in the screen
+:- pred rows(int, io__state, io__state).
+:- mode rows(out, di, uo) is det.
+
+ % getkey(Key, IO0, IO)
+ % Wait for the next keypress from the user, and return it as Key
+:- pred getkey(int, io__state, io__state).
+:- mode getkey(out, di, uo) is det.
+
+%----------------------------------------------------------------------------%
+
+ % Functions to return scancodes for some common keypresses
+
+:- func break = int.
+:- func down = int.
+:- func up = int.
+:- func left = int.
+:- func right = int.
+:- func home = int.
+:- func backspace = int.
+:- func fn(int) = int.
+:- func pageup = int.
+:- func pagedown = int.
+
+%----------------------------------------------------------------------------%
+
+ % Functions to return colours for characters
+
+:- func black = int.
+:- func green = int.
+:- func red = int.
+:- func cyan = int.
+:- func white = int.
+:- func magenta = int.
+:- func blue = int.
+:- func yellow = int.
+
+ % Functions to return attributes for characters
+
+:- func normal = int.
+:- func standout = int.
+:- func underline = int.
+:- func reverse = int.
+:- func blink = int.
+:- func dim = int.
+:- func bold = int.
+:- func invis = int.
+:- func colour(int) = int.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module require.
+
+:- pragma c_header_code("
+ #include <curses.h>
+ #include <term.h>
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(init(IO0::di, IO::uo), "
+{
+ WINDOW *w;
+ w = initscr();
+ noecho();
+ cbreak();
+ keypad(w, TRUE);
+ IO = IO0;
+}
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(endwin(IO0::di, IO::uo),
+ "endwin();
+ IO = IO0;"
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(start_colour(IO0::di, IO::uo),
+ "start_color();
+ init_pair(COLOR_BLACK, COLOR_BLACK, COLOR_BLACK);
+ init_pair(COLOR_GREEN, COLOR_GREEN, COLOR_BLACK);
+ init_pair(COLOR_RED, COLOR_RED, COLOR_BLACK);
+ init_pair(COLOR_CYAN, COLOR_CYAN, COLOR_BLACK);
+ init_pair(COLOR_WHITE, COLOR_WHITE, COLOR_BLACK);
+ init_pair(COLOR_MAGENTA, COLOR_MAGENTA, COLOR_BLACK);
+ init_pair(COLOR_BLUE, COLOR_BLUE, COLOR_BLACK);
+ init_pair(COLOR_YELLOW, COLOR_YELLOW, COLOR_BLACK);
+ IO = IO0;"
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(doupdate(IO0::di, IO::uo), "
+ doupdate();
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(update(IO0::di, IO::uo), "
+ refresh();
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(clear(IO0::di, IO::uo), "
+ clear();
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(cursor(X::in, Y::in, IO0::di, IO::uo), "
+ move(Y, X);
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(putstr(Str::in, IO0::di, IO::uo), "
+ addstr(Str);
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(putchar(C::in, IO0::di, IO::uo), "
+ addch((chtype) C);
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(cols(C::out, IO0::di, IO::uo), "
+ C = tigetnum(""cols"");
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(rows(R::out, IO0::di, IO::uo), "
+ R = tigetnum(""lines"");
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(getkey(C::out, IO0::di, IO::uo), "
+ C = getch();
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(break = (I::out), "I = KEY_BREAK;").
+:- pragma c_code(down = (I::out), "I = KEY_DOWN;").
+:- pragma c_code(up = (I::out), "I = KEY_UP;").
+:- pragma c_code(left = (I::out), "I = KEY_LEFT;").
+:- pragma c_code(right = (I::out), "I = KEY_RIGHT;").
+:- pragma c_code(home = (I::out), "I = KEY_HOME;").
+:- pragma c_code(backspace = (I::out), "I = KEY_BACKSPACE;").
+:- pragma c_code(fn(N::in) = (I::out), "I = KEY_F(N);").
+:- pragma c_code(pageup = (I::out), "I = KEY_PPAGE;").
+:- pragma c_code(pagedown = (I::out), "I = KEY_NPAGE;").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(black = (C::out), "C = COLOR_BLACK;").
+:- pragma c_code(green = (C::out), "C = COLOR_GREEN;").
+:- pragma c_code(red = (C::out), "C = COLOR_RED;").
+:- pragma c_code(cyan = (C::out), "C = COLOR_CYAN;").
+:- pragma c_code(white = (C::out), "C = COLOR_WHITE;").
+:- pragma c_code(magenta = (C::out), "C = COLOR_MAGENTA;").
+:- pragma c_code(blue = (C::out), "C = COLOR_BLUE;").
+:- pragma c_code(yellow = (C::out), "C = COLOR_YELLOW;").
+
+%----------------------------------------------------------------------------%
+
+:- pragma c_code(normal = (A::out), "A = A_NORMAL;").
+:- pragma c_code(standout = (A::out), "A = A_STANDOUT;").
+:- pragma c_code(underline = (A::out), "A = A_UNDERLINE;").
+:- pragma c_code(reverse = (A::out), "A = A_REVERSE;").
+:- pragma c_code(blink = (A::out), "A = A_BLINK;").
+:- pragma c_code(dim = (A::out), "A = A_DIM;").
+:- pragma c_code(bold = (A::out), "A = A_BOLD;").
+:- pragma c_code(invis = (A::out), "A = A_INVIS;").
+:- pragma c_code(colour(C::in) = (A::out), "A = COLOR_PAIR(C);").
+
+%----------------------------------------------------------------------------%
+
+:- 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
+
+").
+%----------------------------------------------------------------------------%
+
Index: curses/mcurses.m
===================================================================
RCS file: mcurses.m
diff -N mcurses.m
--- /dev/null Thu Mar 4 04:20:11 1999
+++ mcurses.m Fri Jan 14 15:05:31 2000
@@ -0,0 +1,14 @@
+%----------------------------------------------------------------------------%
+% Copyright (C) 1994-2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury Distribution.
+%----------------------------------------------------------------------------%
+
+%----------------------------------------------------------------------------%
+%
+% top level of the curses binding
+%
+%----------------------------------------------------------------------------%
+:- module mcurses.
+:- interface.
+:- include_module basics, user, misc.
Index: curses/misc.m
===================================================================
RCS file: misc.m
diff -N misc.m
--- /dev/null Thu Mar 4 04:20:11 1999
+++ misc.m Fri Jan 14 15:22:34 2000
@@ -0,0 +1,51 @@
+%----------------------------------------------------------------------------%
+% Copyright (C) 1994-2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury Distribution.
+%----------------------------------------------------------------------------%
+
+%----------------------------------------------------------------------------%
+%
+% File: misc.m
+% Main author: conway
+%
+% Provides miscellaneous functionality required by user.m and basics.m
+%
+%----------------------------------------------------------------------------%
+
+:- module mcurses:misc.
+:- interface.
+
+:- import_module array, char, int, io.
+
+ % for(Accumulator, Max, Closure, StoreIn, StoreOut)
+ % perform an operation much like a `for loop' in imperative languages. For
+ % every value of Accumulator =< Max, call Closure with the current value of
+ % Accumulator.
+ %
+ % Example:
+ %
+ % for(0, 5, (pred(Num::in, IO1::di, IO2::uo) is det :-
+ % io__print(Num, IO1, IO2)
+ % ), IO0, IO)
+ %
+ % Would print "12345".
+:- pred for(int, int, pred(int, T, T), T, T).
+:- mode for(in, in, pred(in, in, out) is det, in, out) is det.
+:- mode for(in, in, pred(in, in, out) is semidet, in, out) is semidet.
+:- mode for(in, in, pred(in, di, uo) is det, di, uo) is det.
+:- mode for(in, in, pred(in, array_di, array_uo) is det,
+ array_di, array_uo) is det.
+
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+for(Min, Max, Pred, Acc0, Acc) :-
+ ( Min =< Max ->
+ Pred(Min, Acc0, Acc1),
+ for(Min+1, Max, Pred, Acc1, Acc)
+ ;
+ Acc = Acc0
+ ).
+
Index: curses/user.m
===================================================================
RCS file: user.m
diff -N user.m
--- /dev/null Thu Mar 4 04:20:11 1999
+++ user.m Fri Jan 14 15:22:07 2000
@@ -0,0 +1,615 @@
+%----------------------------------------------------------------------------%
+% Copyright (C) 1994-2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury Distribution.
+%----------------------------------------------------------------------------%
+
+%----------------------------------------------------------------------------%
+%
+% File: user.m
+% Main author: conway
+% Maintained by: rejj
+% Stability: Medium
+%
+% This module provides the user-level functionality for the (n)curses binding.
+%
+%----------------------------------------------------------------------------%
+:- module mcurses:user.
+:- interface.
+
+:- import_module char, io, list, std_util.
+
+ % The ADT used to represent a curses window.
+:- type win.
+
+ % Window options.
+:- type wopt
+ ---> border % Place a border around the window
+ ; title(string) % Give the window a title
+ .
+
+ % Character attributes.
+ % These modify the way a character is drawn on the screen. See the curses
+ % documentation for a detailed description of each attribute.
+:- type cattr
+ --->
+ normal;
+ standout;
+ underline;
+ reverse;
+ blink;
+ dim;
+ bold;
+ invis;
+ colour(colour).
+
+ % Colours available for use in displaying characters.
+ %
+ % XXX Currently, there is no functionality provided for the customisation of
+ % colours, only the 8 default colours from curses can be used.
+:- type colour
+ --->
+ black;
+ green;
+ red;
+ cyan;
+ white;
+ magenta;
+ blue;
+ yellow.
+
+ % The type used to represent a character with its attributes.
+:- type chtype == pair(char, list(cattr)).
+
+ % init(Root, IO0, IO)
+ % initilise curses, giving back the root window.
+:- pred init(win, io__state, io__state).
+:- mode init(out, di, uo) is det.
+
+ % Redraw the screen
+:- pred redraw(io__state, io__state).
+:- mode redraw(di, uo) is det.
+
+ % Refresh the screen.
+:- pred refresh(io__state, io__state).
+:- mode refresh(di, uo) is det.
+
+ % create(Parent, Options, ParentX, ParentY, NumCols, NumRows, Child, IO0, IO)
+ % create a new window, which will be a child of the window Parent. It is
+ % created at position ParentX, ParentY in the parent window, and is of size
+ % NumCols, NumRows.
+:- pred create(win, list(wopt), int, int, int, int, win, io__state, io__state).
+:- mode create(in, in, in, in, in, in, out, di, uo) is det.
+
+ % destroy the specified window.
+:- pred destroy(win, io__state, io__state).
+:- mode destroy(in, di, uo) is det.
+
+ % Hide the specified window.
+:- pred hide(win, io__state, io__state).
+:- mode hide(in, di, uo) is det.
+
+ % Show the (previously hidden) specified window
+:- pred show(win, io__state, io__state).
+:- mode show(in, di, uo) is det.
+
+ % Raise the specified window.
+:- pred raise(win, io__state, io__state).
+:- mode raise(in, di, uo) is det.
+
+ % Lower the specified window.
+:- pred lower(win, io__state, io__state).
+:- mode lower(in, di, uo) is det.
+
+ % Clear the specified window. Fills the window with spaces.
+:- pred clear(win, io__state, io__state).
+:- mode clear(in, di, uo) is det.
+
+ % place_char(Window, X, Y, (Char - Attributes), IO0, IO)
+ % Place a character into Window at position X, Y.
+:- pred place_char(win, int, int, chtype, io__state, io__state).
+:- mode place_char(in, in, in, in, di, uo) is det.
+
+ % place_string(Window, X, Y, String, IO0, IO)
+ % Place a string into Window at position X, Y.
+ %
+ % XXX Note that presently, character attributes are not supported for
+ % strings
+:- pred place_string(win, int, int, string, io__state, io__state).
+:- mode place_string(in, in, in, in, di, uo) is det.
+
+ % scroll(Window, Amount, IO0, IO)
+ % Scroll Window upwards by Amount lines.
+:- pred scroll(win, int, io__state, io__state).
+:- mode scroll(in, in, di, uo) is det.
+
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma c_header_code(
+ "#include <curses.h>
+ #include <term.h>"
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- import_module mcurses:misc, mcurses:basics.
+:- import_module array, char, int, list, require, std_util, store, string.
+
+:- type curse == store(some_store_type).
+
+:- type win == mutvar(window, some_store_type).
+
+:- type window
+ ---> win(
+ win, % parent
+ int, % width
+ int, % height
+ list(wopt),
+ array(chtype), % contents
+ list(child), % visible
+ list(child) % hidden
+ ).
+
+:- type child
+ ---> child(
+ int, % x
+ int, % y
+ win
+ ).
+
+:- type cursor
+ ---> cursor(int, int). % X, Y
+
+%----------------------------------------------------------------------------%
+
+init(Win) -->
+ init,
+ { store__init(Curse0) },
+ cols(Cols),
+ rows(Rows),
+ { array__init(Cols*Rows, ' ' - [], Data) },
+ { Func = (func(Self) = win(Self, Cols, Rows, [], Data, [], [])) },
+ { store__new_cyclic_mutvar(Func, Win, Curse0, Curse) },
+ set_curse(Curse),
+ set_root(Win),
+ refresh.
+
+%----------------------------------------------------------------------------%
+
+create(Parent, Opts, X, Y, W, H, Child) -->
+ get_win(Parent, PWindow0),
+ { PWindow0 = win(P0, W0, H0, Opts0, PData, Visi0, Hidden) },
+ { require(((pred) is semidet :-
+ X >= 0, Y >= 0,
+ X+W =< W0,
+ Y+H =< H0
+ ), "create: window out of range!") },
+ { array__init(W*H, ' ' -[], Data) },
+ { CWindow = win(P0, W, H, Opts, Data, [], []) },
+ new_win(CWindow, Child),
+ { list__append(Visi0, [child(X, Y, Child)], Visi) },
+ { PWindow = win(Parent, W0, H0, Opts0, PData, Visi, Hidden) },
+ set_win(Parent, PWindow).
+
+%----------------------------------------------------------------------------%
+
+destroy(Win) -->
+ get_win(Win, Window),
+ { Window = win(Parent, _, _, _, _, _, _) },
+ ( { Parent \= Win } -> % can't kill the root window
+ get_win(Parent, PWindow0),
+ { PWindow0 = win(PP, PC, PR, PO, PD, Visi0, Hidden) },
+ { filter((pred(Child::in) is semidet :-
+ \+ Child = child(_, _, Win)
+ ), Visi0, Visi) },
+ { PWindow = win(PP, PC, PR, PO, PD, Visi, Hidden) },
+ set_win(Parent, PWindow)
+ ;
+ []
+ ).
+
+%----------------------------------------------------------------------------%
+
+redraw -->
+ get_root(Root),
+ set_cursor(cursor(0, 0)),
+ refresh(Root),
+ doupdate.
+
+%----------------------------------------------------------------------------%
+
+refresh -->
+ get_root(Root),
+ clear,
+ set_cursor(cursor(0, 0)),
+ refresh(Root),
+ update.
+
+:- pred refresh(win, io__state, io__state).
+:- mode refresh(in, di, uo) is det.
+
+refresh(Win) -->
+ get_win(Win, Window),
+ { Window = win(_Parent, Cols, Rows, Opts, Data, Visi, _Hidden) },
+ get_cursor(cursor(X0, Y0)),
+ { solutions((pred(Ti::out) is nondet :-
+ list__member(ZZ, Opts),
+ ZZ = title(Ti)
+ ), Titles) },
+ ( { list__member(border, Opts) } ->
+ for(Y0+1, Y0+Rows, (pred(By::in, di, uo) is det -->
+ cursor(X0, By),
+ putchar('|'),
+ cursor(X0+Cols+1, By),
+ putchar('|')
+ )),
+ for(X0+1, X0+Cols, (pred(Bx::in, di, uo) is det -->
+ cursor(Bx, Y0),
+ (
+ { Titles = [] },
+ putchar('-')
+ ;
+ { Titles = [_|_] },
+ putchar('=')
+ ),
+ cursor(Bx, Y0+Rows+1),
+ putchar('-')
+ )),
+ cursor(X0, Y0), putchar('+'),
+ cursor(X0+Cols+1, Y0), putchar('+'),
+ cursor(X0, Y0+Rows+1), putchar('+'),
+ cursor(X0+Cols+1, Y0+Rows+1), putchar('+'),
+ ( { Titles = [Title0|_] } ->
+ { string__length(Title0, N0) },
+ ( { N0 > Cols-2 } ->
+ { N = Cols - 2 },
+ { split(Title0, N, Title, _) }
+ ;
+ { N = N0 },
+ { Title = Title0 }
+ ),
+ { Xst = X0 + (Cols - N)//2 },
+ cursor(Xst, Y0),
+ putstr(Title)
+ ;
+ []
+ ),
+ { A = 1 }
+ ;
+ { A = 0 }
+ ),
+ { Xb = X0+A },
+ { Yb = Y0+A },
+ for(0, Rows-1, (pred(Y::in, di, uo) is det -->
+ { Offset = Y*Cols },
+ for(0, Cols-1, (pred(X::in, di, uo) is det -->
+ cursor(Xb+X, Yb+Y),
+ { lookup(Data, X+Offset, Char - Attribs) },
+ putch(Char, Attribs)
+ ))
+ )),
+ foldl(refresh_child, Visi).
+
+:- pred refresh_child(child, io__state, io__state).
+:- mode refresh_child(in, di, uo) is det.
+
+refresh_child(child(X, Y, Win)) -->
+ get_cursor(cursor(X0, Y0)),
+ set_cursor(cursor(X0+X, Y0+Y)),
+ refresh(Win),
+ set_cursor(cursor(X0, Y0)).
+
+%----------------------------------------------------------------------------%
+
+:- pred putch(char, list(cattr), io__state, io__state).
+:- mode putch(in, in, di, uo) is det.
+
+putch(Char, []) --> putchar(Char).
+putch(Char, [A|B]) -->
+ { chtype(Char, Chtype) },
+ putch2(Chtype, [A|B]).
+
+:- pred putch2(int, list(cattr), io__state, io__state).
+:- mode putch2(in, in, di, uo) is det.
+
+putch2(Chtype, []) --> putch3(Chtype).
+putch2(Chtype0, [Attrib | Attribs], IO0, IO) :-
+ (
+ Attrib = normal,
+ mod_chtype(Chtype0, normal, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = standout,
+ mod_chtype(Chtype0, standout, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = underline,
+ mod_chtype(Chtype0, underline, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = reverse,
+ mod_chtype(Chtype0, reverse, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = blink,
+ mod_chtype(Chtype0, blink, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = dim,
+ mod_chtype(Chtype0, dim, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = bold,
+ mod_chtype(Chtype0, bold, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = invis,
+ mod_chtype(Chtype0, invis, Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ;
+ Attrib = colour(Colour0),
+ get_colour(Colour0, Colour),
+ mod_chtype(Chtype0, colour(Colour), Chtype),
+ putch2(Chtype, Attribs, IO0, IO)
+ ).
+
+:- pred putch3(int, io__state, io__state).
+:- mode putch3(in, di, uo) is det.
+:- pragma c_code(putch3(C::in, IO0::di, IO::uo),
+ "addch((chtype) C);
+ IO = IO0;"
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- pred get_colour(colour, int).
+:- mode get_colour(in, out) is det.
+
+get_colour(black, black).
+get_colour(green, green).
+get_colour(red, red).
+get_colour(cyan, cyan).
+get_colour(white, white).
+get_colour(magenta, magenta).
+get_colour(blue, blue).
+get_colour(yellow, yellow).
+
+:- pred chtype(char, int).
+:- mode chtype(in, out) is det.
+:- pragma c_code(chtype(C::in, Ch::out), "Ch = (chtype) C;").
+
+:- pred mod_chtype(int, int, int).
+:- mode mod_chtype(in, in, out) is det.
+:- pragma c_code(mod_chtype(Ch0::in, Attr::in, Ch::out),
+ "Ch = (chtype) Ch0 | Attr;"
+ ).
+
+%----------------------------------------------------------------------------%
+
+hide(Win) -->
+ get_win(Win, Window),
+ { Window = win(Parent, _, _, _, _, _, _) },
+ get_win(Parent, PWindow0),
+ { PWindow0 = win(PP, PC, PR, PO, PD, Visi0, Hidden0) },
+ { filter((pred(Child::in) is semidet :-
+ Child = child(_, _, Win)
+ ), Visi0, This, Visi) },
+ { append(This, Hidden0, Hidden) },
+ { PWindow = win(PP, PC, PR, PO, PD, Visi, Hidden) },
+ set_win(Parent, PWindow).
+
+%----------------------------------------------------------------------------%
+
+show(Win) -->
+ get_win(Win, Window),
+ { Window = win(Parent, _, _, _, _, _, _) },
+ get_win(Parent, PWindow0),
+ { PWindow0 = win(PP, PC, PR, PO, PD, Visi0, Hidden0) },
+ { filter((pred(Child::in) is semidet :-
+ Child = child(_, _, Win)
+ ), Hidden0, This, Hidden) },
+ { append(Visi0, This, Visi) },
+ { PWindow = win(PP, PC, PR, PO, PD, Visi, Hidden) },
+ set_win(Parent, PWindow).
+
+%----------------------------------------------------------------------------%
+
+raise(Win) -->
+ get_win(Win, Window),
+ { Window = win(Parent, _, _, _, _, _, _) },
+ get_win(Parent, PWindow0),
+ { PWindow0 = win(PP, PC, PR, PO, PD, Visi0, Hidden) },
+ { filter((pred(Child::in) is semidet :-
+ Child = child(_, _, Win)
+ ), Visi0, This, Rest) },
+ { append(Rest, This, Visi) },
+ { PWindow = win(PP, PC, PR, PO, PD, Visi, Hidden) },
+ set_win(Parent, PWindow).
+
+%----------------------------------------------------------------------------%
+
+lower(Win) -->
+ get_win(Win, Window),
+ { Window = win(Parent, _, _, _, _, _, _) },
+ get_win(Parent, PWindow0),
+ { PWindow0 = win(PP, PC, PR, PO, PD, Visi0, Hidden) },
+ { filter((pred(Child::in) is semidet :-
+ Child = child(_, _, Win)
+ ), Visi0, This, Rest) },
+ { append(This, Rest, Visi) },
+ { PWindow = win(PP, PC, PR, PO, PD, Visi, Hidden) },
+ set_win(Parent, PWindow).
+
+%----------------------------------------------------------------------------%
+
+clear(Win) -->
+ get_win(Win, win(Parent, Cols, Rows, Opts, Data0, Visi, Hidden)),
+ { for(0, Rows-1, (pred(Y::in, array_di, array_uo) is det -->
+ for(0, Cols-1, (pred(X::in, D0::array_di, D::array_uo) is det :-
+ set(D0, X+Y*Cols, ' ' - [], D)
+ ))
+ ), u(Data0), Data) },
+ set_win(Win, win(Parent, Cols, Rows, Opts, Data, Visi, Hidden)).
+
+%----------------------------------------------------------------------------%
+
+scroll(Win, N) -->
+ get_win(Win, win(Parent, Cols, Rows, Opts, Data0, Visi, Hidden)),
+ { require(((pred) is semidet :-
+ N > 0,
+ N < Cols
+ ), "scroll: out of range") },
+ { for(0, Rows-N-1, (pred(Y::in, array_di, array_uo) is det -->
+ for(0, Cols-1, (pred(X::in, D0::array_di, D::array_uo) is det :-
+ lookup(D0, X+(Y+N)*Cols, C),
+ set(D0, X+Y*Cols, C, D)
+ ))
+ ), u(Data0), Data1) },
+ { for(Rows-N, Rows-1, (pred(Y::in, array_di, array_uo) is det -->
+ for(0, Cols-1, (pred(X::in, D1::array_di, Q::array_uo) is det :-
+ set(D1, X+Y*Cols, ' ' - [], Q)
+ ))
+ ), Data1, Data) },
+ set_win(Win, win(Parent, Cols, Rows, Opts, Data, Visi, Hidden)).
+
+%----------------------------------------------------------------------------%
+
+place_char(Win, X, Y, C - As) -->
+ get_win(Win, win(Parent, Cols, Rows, Opts, Data0, Visi, Hidden)),
+ { require(((pred) is semidet :-
+ X >= 0, Y >= 0,
+ X < Cols, Y < Cols
+ ), "place_char: out of range") },
+ { set(u(Data0), X+Y*Cols, C - As, Data) },
+ set_win(Win, win(Parent, Cols, Rows, Opts, Data, Visi, Hidden)).
+
+:- func u(array(T)) = array(T).
+:- mode (u(in) = array_uo) is det.
+:- pragma c_code(u(A::in) = (B::array_uo), "B = A;").
+
+%----------------------------------------------------------------------------%
+
+place_string(Win, X, Y, Str) -->
+ get_win(Win, win(Parent, Cols, Rows, Opts, Data0, Visi, Hidden)),
+ { require(((pred) is semidet :-
+ X >= 0, Y >= 0,
+ X < Cols, Y < Cols
+ ), "place_string: out of range") },
+ { string__to_char_list(Str, Chars) },
+ { update_data(Chars, Y*Cols, X, X+Cols, u(Data0), Data) },
+ set_win(Win, win(Parent, Cols, Rows, Opts, Data, Visi, Hidden)).
+
+:- pred update_data(list(char), int, int, int, array(pair(char, list(cattr))),
+ array(pair(char, list(cattr)))).
+:- mode update_data(in, in, in, in, array_di, array_uo) is det.
+
+update_data([], _, _, _, Data, Data).
+update_data([C|Cs], Y, X, Xmax, Data0, Data) :-
+ ( X < Xmax ->
+ set(Data0, X+Y, C - [], Data1),
+ update_data(Cs, Y, X+1, Xmax, Data1, Data)
+ ;
+ Data = Data0
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- pred get_root(win, io__state, io__state).
+:- mode get_root(out, di, uo) is det.
+
+:- pred set_root(win, io__state, io__state).
+:- mode set_root(in, di, uo) is det.
+
+:- pragma c_header_code("
+ extern Word curse_root;
+").
+
+:- pragma c_code("
+ Word curse_root;
+").
+
+:- pragma c_code(get_root(W::out, IO0::di, IO::uo), "
+ W = curse_root;
+ IO = IO0;
+").
+
+:- pragma c_code(set_root(W::in, IO0::di, IO::uo), "
+ curse_root = W;
+ IO = IO0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pred new_win(window::in, win::out, io__state::di, io__state::uo) is det.
+
+new_win(Window, Win) -->
+ get_curse(Curse0),
+ { store__new_mutvar(Window, Win, Curse0, Curse) },
+ set_curse(Curse).
+
+:- pred get_win(win::in, window::out, io__state::di, io__state::uo) is det.
+
+get_win(Win, Window) -->
+ get_curse(Curse0),
+ { store__get_mutvar(Win, Window, Curse0, Curse) },
+ set_curse(Curse).
+
+:- pred set_win(win::in, window::in, io__state::di, io__state::uo) is det.
+
+set_win(Win, Window) -->
+ get_curse(Curse0),
+ { store__set_mutvar(Win, Window, Curse0, Curse) },
+ set_curse(Curse).
+
+%----------------------------------------------------------------------------%
+
+:- pred get_cursor(cursor::out, io__state::di, io__state::uo) is det.
+
+:- pred set_cursor(cursor::in, io__state::di, io__state::uo) is det.
+
+:- pragma c_header_code("
+ extern Word curse_cursor;
+").
+
+:- pragma c_header_code("
+ Word curse_cursor;
+").
+
+:- pragma c_code(get_cursor(C::out, I0::di, I::uo), "
+ C = curse_cursor;
+ I = I0;
+").
+
+:- pragma c_code(set_cursor(C::in, I0::di, I::uo), "
+ curse_cursor = C;
+ I = I0;
+").
+
+%----------------------------------------------------------------------------%
+
+:- pred get_curse(curse::uo, io__state::di, io__state::uo) is det.
+
+:- pred set_curse(curse::di, io__state::di, io__state::uo) is det.
+
+:- pragma c_header_code("
+ extern Word curse_store;
+").
+
+:- pragma c_header_code("
+ Word curse_store;
+").
+
+:- pragma c_code(get_curse(C::uo, I0::di, I::uo), "
+ C = curse_store;
+ I = I0;
+").
+
+:- pragma c_code(set_curse(C::di, I0::di, I::uo), "
+ curse_store = C;
+ I = I0;
+").
+
+%----------------------------------------------------------------------------%
+
Index: curses/sample/Mmakefile
===================================================================
RCS file: Mmakefile
diff -N Mmakefile
--- /dev/null Thu Mar 4 04:20:11 1999
+++ Mmakefile Fri Jan 14 15:30:03 2000
@@ -0,0 +1,16 @@
+# Specify location of the mcurses library
+MCURSES_DIR = ..
+
+# Tell mmake to use the mcurses library
+VPATH = $(MCURSES_DIR):$(MMAKE_VPATH)
+MCFLAGS = -I$(MCURSES_DIR) $(EXTRA_MCFLAGS)
+MLFLAGS = -R$(MCURSES_DIR) $(EXTRA_MLFLAGS) \
+ -L$(MCURSES_DIR)
+
+# Note that you have to tell the linker to use the mcurses library
+# AND the ncurses library (which mcurses is an interface for)
+MLLIBS = -lmcurses -lncurses $(EXTRA_MLLIBS)
+C2INITFLAGS = $(MCURSES_DIR)/mcurses.init
+
+default_target: smalltest
+depend: smalltest.depend
Index: curses/sample/smalltest.m
===================================================================
RCS file: smalltest.m
diff -N smalltest.m
--- /dev/null Thu Mar 4 04:20:11 1999
+++ smalltest.m Fri Jan 14 15:30:25 2000
@@ -0,0 +1,42 @@
+%-----------------------------------------------------------------------------%
+%
+% this file is hereby placed into the public domain by the author (rejj)
+%
+% A simple test, using the mercury binding to curses.
+%
+%-----------------------------------------------------------------------------%
+
+:- module smalltest.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+:- import_module mcurses, mcurses:basics, mcurses:user.
+:- import_module int, list, std_util.
+
+main -->
+ init(Root),
+ start_colour,
+ cols(Cols),
+ rows(Rows),
+
+ create(Root, [], 0, 0, Cols, 3, TopWindow),
+ create(Root, [], 0, 4, Cols, Rows - 4, BottomWindow),
+
+ place_string(TopWindow, 0, 2, "Hi!"),
+ place_char(BottomWindow, 10, 10, '@' - [bold, colour(yellow)]),
+ redraw,
+ getkey(_),
+
+ scroll(TopWindow, 1),
+ place_string(TopWindow, 0, 2, "Bye!"),
+ clear(BottomWindow),
+ place_char(BottomWindow, 10, 5, '@' - [bold, colour(green)]),
+ redraw,
+ getkey(_),
+
+ endwin.
--------------------------------------------------------------------------
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