curses: partial rewrite

diff --git a/extra/curses/curses-tests.factor b/extra/curses/curses-tests.factor
index bd98a7aff1a2da06cf3b33248563aed62b3e9bd4..d03935630f21d5168f50451f1ddbfaa825ec5510 100644 (file)
--- 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
+    <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 dfb1b8672a0f1bc2a03266fd88b386a748151a66..aef00577730444a16f8104c70de52378c6473310 100644 (file)
--- 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 -- )
-    ptr>> delwin curses-error ;
+    { encoding initial: utf8 } ;
 
-<PRIVATE
+: <curses-window> ( -- window )
+    curses-window new-disposable ;
 
-: add-window ( window -- )
-    dup name>> [ unnamed-window ] unless*
-    curses-windows get 2dup key?
-    [ duplicate-window ] [ set-at ] if ;
+M: curses-window dispose* ( window -- )
+    ptr>> delwin curses-error ;
 
-: delete-window ( window -- )
-    curses-windows get 2dup key?
-    [ delete-at ] [ drop window-not-found ] if ;
+<PRIVATE
 
 : 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 ;
+: setup-window ( window -- window )
+    [
+        dup
+        dup parent-window>> [
+            ptr>> swap window-params derwin
+        ] [
+            window-params newwin
+        ] if* [ curses-error ] keep >>ptr &dispose
+    ] [ apply-options ] bi ;
+
+: with-window ( window quot -- )
+    [ current-window ] dip with-variable ; inline
+
+<PRIVATE
+
+: init-colors ( -- )
+    has_colors [
+        1 n-registered-colors set
+        \ register-color reset-memoized
+        start_color curses-error
+    ] when ;
+
+: curses-pointer-error ( ptr/f -- ptr )
+    dup [ curses-failed ] unless ; inline
+
+PRIVATE>
 
-: (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ;
-: wnrefresh ( window -- ) window-ptr (curses-window-refresh) ;
-: curses-refresh ( -- ) current-window get (curses-window-refresh) ;
+: 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
+    
 
-: (curses-wprint) ( window-ptr string -- )
-    waddstr curses-error ;
+<PRIVATE
 
-: curses-nwrite ( window string -- )
-    [ window-ptr ] dip (curses-wprint) ;
+: (window-curses-refresh) ( window-ptr -- ) wrefresh curses-error ; inline
+: (window-curses-write) ( string window-ptr -- ) swap waddstr curses-error ; inline
 
-: curses-wprint ( window string -- )
-    [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
+:: (window-curses-read) ( n encoding window-ptr -- string )
+    [
+        n 1 + malloc &free :> str
+        window-ptr str n wgetnstr curses-error
+        str encoding alien>string
+    ] with-destructors ; inline
 
-: curses-printf ( window string -- )
-    [ window-ptr dup dup ] dip (curses-wprint)
-    "\n" (curses-wprint)
-    (curses-window-refresh) ;
+: (window-curses-getch) ( window -- key )
+    wgetch [ curses-error ] keep ;
 
-: curses-writef ( window string -- )
-    [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
+: (window-curses-move) ( y x window-ptr -- )
+    -rot wmove curses-error ; inline
 
-:: (curses-read) ( window-ptr n encoding -- string )
-    n <byte-array> :> buf
-    window-ptr buf n wgetnstr curses-error
-    buf encoding alien>string ;
+: (window-insert-blank-line) ( y window-ptr -- )
+    [ 0 swap (window-curses-move) ]
+    [ winsertln curses-error ] bi ; inline
 
-: curses-read ( window n -- string )
-    utf8 [ window-ptr ] 2dip (curses-read) ;
+: (window-curses-addch) ( ch window-ptr -- )
+    swap waddch curses-error ; inline
 
-: curses-erase ( window -- ) window-ptr werase curses-error ;
+PRIVATE>
 
-: move-cursor ( window-name y x -- )
+: 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 -- )
     [
-        window-ptr c-window memory>struct
-        {
-            [ ]
-            [ (curses-window-refresh) ]
-            [ _curx>> ]
-            [ _cury>> ]
-        } cleave
-    ] 2dip mvcur curses-error (curses-window-refresh) ;
-
-: delete-line ( window-name y -- )
-    [ window-ptr dup ] dip
-    0 wmove curses-error wdeleteln curses-error ;
-
-: insert-blank-line ( window-name y -- )
-    [ window-ptr dup ] dip
-    0 wmove curses-error winsertln curses-error ;
-
-: insert-line ( window-name y string -- )
-    [ dupd insert-blank-line ] dip
-    curses-writef ;
+        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 2b52d0ec566d3a84b5afd096f489ce447bf0e679..591c8c820a49adcffdf537c9831c0446f5e19c7c 100644 (file)
--- 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 ) ;