diff --git a/extra/curses/curses-tests.factor b/extra/curses/curses-tests.factor index bd98a7aff1..d03935630f 100644 --- a/extra/curses/curses-tests.factor +++ b/extra/curses/curses-tests.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors curses kernel threads tools.test ; +USING: accessors calendar curses kernel threads tools.test +strings sequences ; IN: curses.tests : hello-curses ( -- ) - [ - curses-window new - "mainwin" >>name - add-curses-window + [ + "Hello Curses!" [ + dup curses-move curses-addch + ] each-index + curses-refresh - "mainwin" "hi" curses-printf - - 2000000 sleep + 2 seconds sleep ] with-curses ; curses-ok? [ diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index dfb1b8672a..aef0057773 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -1,56 +1,36 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.strings assocs byte-arrays -combinators continuations destructors fry io.encodings.8-bit -io io.encodings.string io.encodings.utf8 kernel locals math -namespaces prettyprint sequences classes.struct -strings threads curses.ffi unix.ffi ; +classes.struct combinators continuations curses.ffi destructors +fry io io.encodings.8-bit io.encodings.string io.encodings.utf8 +io.streams.c kernel libc locals math memoize multiline +namespaces prettyprint sequences strings threads ; IN: curses -SYMBOL: curses-windows SYMBOL: current-window -CONSTANT: ERR -1 -CONSTANT: FALSE 0 -CONSTANT: TRUE 1 -: >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline +CONSTANT: COLOR_BLACK 0 +CONSTANT: COLOR_RED 1 +CONSTANT: COLOR_GREEN 2 +CONSTANT: COLOR_YELLO 3 +CONSTANT: COLOR_BLUE 4 +CONSTANT: COLOR_MAGEN 5 +CONSTANT: COLOR_CYAN 6 +CONSTANT: COLOR_WHITE 7 + +: >BOOLEAN ( ? -- TRUE/FALSE ) TRUE FALSE ? ; inline -ERROR: duplicate-window window ; -ERROR: unnamed-window window ; -ERROR: window-not-found window ; ERROR: curses-failed ; ERROR: unsupported-curses-terminal ; -: get-window ( string -- window ) - dup curses-windows get at* - [ nip ] [ drop window-not-found ] if ; - -: window-ptr ( string -- window ) get-window ptr>> ; - : curses-error ( n -- ) ERR = [ curses-failed ] when ; : curses-ok? ( -- ? ) { 0 1 2 } [ isatty 0 = not ] all? ; -: with-curses ( quot -- ) - curses-ok? [ unsupported-curses-terminal ] unless - H{ } clone curses-windows [ - initscr curses-error - [ - curses-windows get values [ dispose ] each - nocbreak curses-error - echo curses-error - endwin curses-error - ] [ ] cleanup - ] with-variable ; inline - -: with-window ( name quot -- ) - [ window-ptr current-window ] dip with-variable ; inline - -TUPLE: curses-window - name - parent-name +TUPLE: curses-window < disposable ptr + parent-window { lines integer initial: 0 } { columns integer initial: 0 } { y integer initial: 0 } @@ -64,99 +44,189 @@ TUPLE: curses-window { leaveok initial: f } idcok idlok immedok - { keypad initial: f } ; + { keypad initial: t } -M: curses-window dispose ( window -- ) + { encoding initial: utf8 } ; + +: ( -- window ) + curses-window new-disposable ; + +M: curses-window dispose* ( window -- ) ptr>> delwin curses-error ; > [ unnamed-window ] unless* - curses-windows get 2dup key? - [ duplicate-window ] [ set-at ] if ; - -: delete-window ( window -- ) - curses-windows get 2dup key? - [ delete-at ] [ drop window-not-found ] if ; - : window-params ( window -- lines columns y x ) { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ; -: setup-window ( window -- ) +: set-cbreak/raw ( cbreak raw -- ) + [ drop raw ] [ + [ cbreak ] [ nocbreak ] if + ] if curses-error ; + +: apply-options ( window -- ) { - [ - dup - dup parent-name>> [ - window-ptr swap window-params derwin - ] [ - window-params newwin - ] if* [ curses-error ] keep >>ptr drop - ] - [ cbreak>> [ cbreak ] [ nocbreak ] if curses-error ] + [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ] [ echo>> [ echo ] [ noecho ] if curses-error ] - [ raw>> [ raw ] [ noraw ] if curses-error ] [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ] [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ] [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ] - [ add-window ] } cleave ; +SYMBOL: n-registered-colors + +MEMO: register-color ( fg bg -- n ) + [ n-registered-colors get ] 2dip init_pair curses-error + n-registered-colors [ get ] [ inc ] bi ; + PRIVATE> -: add-curses-window ( window -- ) - [ setup-window ] [ ] [ dispose ] cleanup ; - -: (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ; -: wnrefresh ( window -- ) window-ptr (curses-window-refresh) ; -: curses-refresh ( -- ) current-window get (curses-window-refresh) ; - -: (curses-wprint) ( window-ptr string -- ) - waddstr curses-error ; - -: curses-nwrite ( window string -- ) - [ window-ptr ] dip (curses-wprint) ; - -: curses-wprint ( window string -- ) - [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ; - -: curses-printf ( window string -- ) - [ window-ptr dup dup ] dip (curses-wprint) - "\n" (curses-wprint) - (curses-window-refresh) ; - -: curses-writef ( window string -- ) - [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ; - -:: (curses-read) ( window-ptr n encoding -- string ) - n :> buf - window-ptr buf n wgetnstr curses-error - buf encoding alien>string ; - -: curses-read ( window n -- string ) - utf8 [ window-ptr ] 2dip (curses-read) ; - -: curses-erase ( window -- ) window-ptr werase curses-error ; - -: move-cursor ( window-name y x -- ) +: setup-window ( window -- window ) [ - window-ptr c-window memory>struct - { - [ ] - [ (curses-window-refresh) ] - [ _curx>> ] - [ _cury>> ] - } cleave - ] 2dip mvcur curses-error (curses-window-refresh) ; + dup + dup parent-window>> [ + ptr>> swap window-params derwin + ] [ + window-params newwin + ] if* [ curses-error ] keep >>ptr &dispose + ] [ apply-options ] bi ; -: delete-line ( window-name y -- ) - [ window-ptr dup ] dip - 0 wmove curses-error wdeleteln curses-error ; +: with-window ( window quot -- ) + [ current-window ] dip with-variable ; inline -: insert-blank-line ( window-name y -- ) - [ window-ptr dup ] dip - 0 wmove curses-error winsertln curses-error ; + + +: with-curses ( window quot -- ) + curses-ok? [ unsupported-curses-terminal ] unless + [ + [ + initscr curses-pointer-error + >>ptr dup apply-options + ] dip + erase curses-error + init-colors + [ + [ endwin curses-error ] [ ] cleanup + ] curry with-window + ] with-destructors ; inline + + + str + window-ptr str n wgetnstr curses-error + str encoding alien>string + ] with-destructors ; inline + +: (window-curses-getch) ( window -- key ) + wgetch [ curses-error ] keep ; + +: (window-curses-move) ( y x window-ptr -- ) + -rot wmove curses-error ; inline + +: (window-insert-blank-line) ( y window-ptr -- ) + [ 0 swap (window-curses-move) ] + [ winsertln curses-error ] bi ; inline + +: (window-curses-addch) ( ch window-ptr -- ) + swap waddch curses-error ; inline + +PRIVATE> + +: window-curses-refresh ( window -- ) ptr>> (window-curses-refresh) ; +: curses-refresh ( -- ) current-window get window-curses-refresh ; + +: window-curses-write ( string window -- ) + ptr>> (window-curses-write) ; +: curses-write ( string -- ) + current-window get window-curses-write ; + +: window-curses-nl ( window -- ) + [ "\n" ] dip ptr>> (window-curses-write) ; +: curses-nl ( -- ) + current-window get window-curses-nl ; + +: window-curses-print ( string window -- ) + ptr>> [ (window-curses-write) ] + [ "\n" swap (window-curses-write) ] bi ; +: curses-print ( string -- ) + current-window get window-curses-print ; + +: window-curses-print-refresh ( string window -- ) + ptr>> [ (window-curses-write) ] + [ "\n" swap (window-curses-write) ] + [ (window-curses-refresh) ] tri ; +: curses-print-refresh ( string -- ) + current-window get window-curses-print-refresh ; + +: window-curses-write-refresh ( string window -- ) + ptr>> [ (window-curses-write) ] [ (window-curses-refresh) ] bi ; +: curses-write-refresh ( string -- ) + current-window get window-curses-write-refresh ; + +: window-curses-read ( n window -- string ) + [ encoding>> ] [ ptr>> ] bi (window-curses-read) ; +: curses-read ( n -- string ) + current-window get window-curses-read ; + +: window-curses-getch ( window -- key ) + ptr>> (window-curses-getch) ; +: curses-getch ( -- key ) + current-window get window-curses-getch ; + +: window-curses-erase ( window -- ) + ptr>> werase curses-error ; +: curses-erase ( -- ) + current-window get window-curses-erase ; + +: window-curses-move ( y x window -- ) + ptr>> [ (window-curses-move) ] [ (window-curses-refresh) ] bi ; +: curses-move ( y x -- ) + current-window get window-curses-move ; + +: window-delete-line ( y window -- ) + ptr>> [ 0 swap (window-curses-move) ] + [ wdeleteln curses-error ] bi ; +: delete-line ( y -- ) + current-window get window-delete-line ; + +: window-insert-blank-line ( y window -- ) + ptr>> (window-insert-blank-line) ; +: insert-blank-line ( y -- ) + current-window get window-insert-blank-line ; + +: window-insert-line ( string y window -- ) + ptr>> [ (window-insert-blank-line) ] + [ (window-curses-write) ] bi ; +: insert-line ( string y -- ) + current-window get window-insert-line ; + +: window-curses-addch ( ch window -- ) + ptr>> (window-curses-addch) ; +: curses-addch ( ch -- ) + current-window get window-curses-addch ; + +: window-curses-color ( foreground background window -- ) + [ + 2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and + [ 2drop 0 ] [ register-color ] if COLOR_PAIR + ] dip ptr>> swap wattron curses-error ; +: curses-color ( foreground background -- ) + current-window get window-curses-color ; diff --git a/extra/curses/ffi/ffi.factor b/extra/curses/ffi/ffi.factor index 2b52d0ec56..591c8c820a 100644 --- a/extra/curses/ffi/ffi.factor +++ b/extra/curses/ffi/ffi.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.syntax combinators kernel system -alien.c-types alien.libraries classes.struct unix.types ; +USING: accessors alien alien.c-types alien.libraries +alien.syntax classes.struct combinators kernel math system unix.types ; IN: curses.ffi << "curses" { { [ os winnt? ] [ "libcurses.dll" ] } { [ os macosx? ] [ "libcurses.dylib" ] } - { [ os unix? ] [ "libcurses.so" ] } + { [ os unix? ] [ "libncurses.so.5.7" ] } } cond cdecl add-library >> C-TYPE: WINDOW @@ -21,56 +21,60 @@ TYPEDEF: ushort wchar_t CONSTANT: CCHARW_MAX 5 +CONSTANT: ERR -1 +CONSTANT: FALSE 0 +CONSTANT: TRUE 1 + STRUCT: cchar_t - { attr attr_t } - { chars { wchar_t CCHARW_MAX } } ; +{ attr attr_t } +{ chars { wchar_t CCHARW_MAX } } ; STRUCT: pdat - { _pad_y NCURSES_SIZE_T } - { _pad_x NCURSES_SIZE_T } - { _pad_top NCURSES_SIZE_T } - { _pad_left NCURSES_SIZE_T } - { _pad_bottom NCURSES_SIZE_T } - { _pad_right NCURSES_SIZE_T } ; +{ _pad_y NCURSES_SIZE_T } +{ _pad_x NCURSES_SIZE_T } +{ _pad_top NCURSES_SIZE_T } +{ _pad_left NCURSES_SIZE_T } +{ _pad_bottom NCURSES_SIZE_T } +{ _pad_right NCURSES_SIZE_T } ; STRUCT: c-window - { _cury NCURSES_SIZE_T } - { _curx NCURSES_SIZE_T } +{ _cury NCURSES_SIZE_T } +{ _curx NCURSES_SIZE_T } - { _maxy NCURSES_SIZE_T } - { _maxx NCURSES_SIZE_T } - { _begy NCURSES_SIZE_T } - { _begx NCURSES_SIZE_T } +{ _maxy NCURSES_SIZE_T } +{ _maxx NCURSES_SIZE_T } +{ _begy NCURSES_SIZE_T } +{ _begx NCURSES_SIZE_T } - { _flags short } +{ _flags short } - { _attrs attr_t } - { _bkgd chtype } +{ _attrs attr_t } +{ _bkgd chtype } - { _notimeout bool } - { _clear bool } - { _leaveok bool } - { _scroll bool } - { _idlok bool } - { _idcok bool } - { _immed bool } - { _sync bool } - { _use_keypad bool } - { _delay int } +{ _notimeout bool } +{ _clear bool } +{ _leaveok bool } +{ _scroll bool } +{ _idlok bool } +{ _idcok bool } +{ _immed bool } +{ _sync bool } +{ _use_keypad bool } +{ _delay int } - { _line c-string } - { _regtop NCURSES_SIZE_T } - { _regbottom NCURSES_SIZE_T } +{ _line c-string } +{ _regtop NCURSES_SIZE_T } +{ _regbottom NCURSES_SIZE_T } - { _parx int } - { _pary int } - { _parent WINDOW* } +{ _parx int } +{ _pary int } +{ _parent WINDOW* } - { _pad pdat } +{ _pad pdat } - { _yoffset NCURSES_SIZE_T } +{ _yoffset NCURSES_SIZE_T } - { _bkgrnd cchar_t } ; +{ _bkgrnd cchar_t } ; LIBRARY: curses @@ -134,13 +138,13 @@ FUNCTION: int scrollok ( WINDOW* win, bool bf ) ; FUNCTION: int nl ( ) ; FUNCTION: int nonl ( ) ; -FUNCTION: int erase ( ) ; +FUNCTION: int erase ( ) ; FUNCTION: int werase ( WINDOW* win ) ; -FUNCTION: int clear ( ) ; +FUNCTION: int clear ( ) ; FUNCTION: int wclear ( WINDOW* win ) ; -FUNCTION: int clrtobot ( ) ; +FUNCTION: int clrtobot ( ) ; FUNCTION: int wclrtobot ( WINDOW* win ) ; -FUNCTION: int clrtoeol ( ) ; +FUNCTION: int clrtoeol ( ) ; FUNCTION: int wclrtoeol ( WINDOW* win ) ; FUNCTION: int refresh ( ) ; @@ -181,22 +185,22 @@ FUNCTION: int scroll ( WINDOW* win ) ; FUNCTION: int scrl ( int n ) ; FUNCTION: int wscrl ( WINDOW* win, int n ) ; - ! int setupterm(char *term, int fildes, int *errret); - ! int setterm(char *term); - ! TERMINAL *set_curterm(TERMINAL *nterm); - ! int del_curterm(TERMINAL *oterm); - ! int restartterm(const char *term, int fildes, int *errret); - ! char *tparm(char *str, ...); - ! int tputs(const char *str, int affcnt, int (*putc)(int)); - ! int putp(const char *str); - ! int vidputs(chtype attrs, int (*putc)(int)); - ! int vidattr(chtype attrs); - ! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char)); - ! int vid_attr(attr_t attrs, short pair, void *opts); +! int setupterm(char *term, int fildes, int *errret); +! int setterm(char *term); +! TERMINAL *set_curterm(TERMINAL *nterm); +! int del_curterm(TERMINAL *oterm); +! int restartterm(const char *term, int fildes, int *errret); +! char *tparm(char *str, ...); +! int tputs(const char *str, int affcnt, int (*putc)(int)); +! int putp(const char *str); +! int vidputs(chtype attrs, int (*putc)(int)); +! int vidattr(chtype attrs); +! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char)); +! int vid_attr(attr_t attrs, short pair, void *opts); FUNCTION: int mvcur ( int oldrow, int oldcol, int newrow, int newcol ) ; - ! int tigetflag(char *capname); - ! int tigetnum(char *capname); - ! char *tigetstr(char *capname); +! int tigetflag(char *capname); +! int tigetnum(char *capname); +! char *tigetstr(char *capname); FUNCTION: int touchwin ( WINDOW* win ) ; FUNCTION: int touchline ( WINDOW* win, int start, int count ) ; @@ -229,3 +233,22 @@ FUNCTION: int mvaddstr ( int y, int x, c-string str ) ; FUNCTION: int mvaddnstr ( int y, int x, c-string str, int n ) ; FUNCTION: int mvwaddstr ( WINDOW* win, int y, int x, c-string str ) ; FUNCTION: int mvwaddnstr ( WINDOW* win, int y, int x, c-string str, int n ) ; + +FUNCTION: int waddch ( WINDOW* win, chtype ch ) ; + +FUNCTION: int start_color ( ) ; +FUNCTION: int init_pair ( short pair, short f, short b ) ; +FUNCTION: int init_color ( short color, short r, short g, short b ) ; +FUNCTION: bool has_colors ( ) ; +FUNCTION: bool can_change_color ( ) ; +FUNCTION: int color_content ( short color, short* r, short* g, short* b ) ; +FUNCTION: int pair_content ( short pair, short* f, short* b ) ; + +C-GLOBAL: int COLORS +C-GLOBAL: int COLOR_PAIRS + +: COLOR_PAIR ( n -- n' ) 8 shift ; inline foldable + +FUNCTION: int wattron ( WINDOW* win, int attrs ) ; +FUNCTION: int wattroff ( WINDOW* win, int attrs ) ; +FUNCTION: int wattrset ( WINDOW* win, int attrs ) ;