steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

curses: add attributes

db4
Philipp Brüschweiler 2009-10-21 19:36:41 +02:00
parent 0e9572bf85
commit 697d846912
1 changed files with 45 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
extra/curses/curses.factor
View File

@ -20,6 +20,26 @@ CONSTANT: COLOR_MAGEN 5
CONSTANT: COLOR_CYAN 6 CONSTANT: COLOR_CYAN 6
CONSTANT: COLOR_WHITE 7 CONSTANT: COLOR_WHITE 7
CONSTANT: A_NORMAL 0
CONSTANT: A_ATTRIBUTES -256
CONSTANT: A_CHARTEXT 255
CONSTANT: A_COLOR 65280
CONSTANT: A_STANDOUT 65536
CONSTANT: A_UNDERLINE 131072
CONSTANT: A_REVERSE 262144
CONSTANT: A_BLINK 524288
CONSTANT: A_DIM 1048576
CONSTANT: A_BOLD 2097152
CONSTANT: A_ALTCHARSET 4194304
CONSTANT: A_INVIS 8388608
CONSTANT: A_PROTECT 16777216
CONSTANT: A_HORIZONTAL 33554432
CONSTANT: A_LEFT 67108864
CONSTANT: A_LOW 134217728
CONSTANT: A_RIGHT 268435456
CONSTANT: A_TOP 536870912
CONSTANT: A_VERTICAL 1073741824
ERROR: curses-failed ; ERROR: curses-failed ;
ERROR: unsupported-curses-terminal ; ERROR: unsupported-curses-terminal ;
@ -112,15 +132,13 @@ PRIVATE>
: with-curses ( window quot -- ) : with-curses ( window quot -- )
curses-ok? [ unsupported-curses-terminal ] unless curses-ok? [ unsupported-curses-terminal ] unless
[ [
[ '[
ffi:initscr curses-pointer-error ffi:initscr curses-pointer-error
>>ptr dup apply-options >>ptr dup apply-options
] dip ffi:erase curses-error
ffi:erase curses-error init-colors
init-colors _ with-window
[ ] [ ffi:endwin curses-error ] [ ] cleanup
[ ffi:endwin curses-error ] [ ] cleanup
] curry with-window
] with-destructors ; inline ] with-destructors ; inline
TUPLE: curses-terminal < disposable TUPLE: curses-terminal < disposable
@ -172,17 +190,23 @@ M: curses-terminal dispose
: (wgetch) ( window -- key ) : (wgetch) ( window -- key )
ffi:wgetch [ curses-error ] keep ; inline ffi:wgetch [ curses-error ] keep ; inline
: (wattroff) ( attribute window-ptr -- )
swap ffi:wattroff curses-error ; inline
: (wattron) ( attribute window-ptr -- )
swap ffi:wattron curses-error ; inline
PRIVATE> PRIVATE>
: wcrefresh ( window -- ) ptr>> (wcrefresh) ; : wcrefresh ( window -- ) ptr>> (wcrefresh) ;
: crefresh ( -- ) current-window get wcrefresh ; : crefresh ( -- ) current-window get wcrefresh ;
: wcwrite ( string window -- ) ptr>> (wcwrite) ;
: cwrite ( string -- ) current-window get wcwrite ;
: wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ; : wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
: cnl ( -- ) current-window get wcnl ; : cnl ( -- ) current-window get wcnl ;
: wcwrite ( string window -- ) ptr>> (wcwrite) ;
: cwrite ( string -- ) current-window get wcwrite ;
: wcprint ( string window -- ) : wcprint ( string window -- )
ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ; ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
: cprint ( string -- ) current-window get wcprint ; : cprint ( string -- ) current-window get wcprint ;
@ -190,7 +214,7 @@ PRIVATE>
: wcprintf ( string window -- ) : wcprintf ( string window -- )
ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
[ (wcrefresh) ] tri ; [ (wcrefresh) ] tri ;
: curses-print-refresh ( string -- ) current-window get wcprintf ; : cprintf ( string -- ) current-window get wcprintf ;
: wcwritef ( string window -- ) : wcwritef ( string window -- )
ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ; ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
@ -227,11 +251,20 @@ PRIVATE>
: insert-line ( string y -- ) : insert-line ( string y -- )
current-window get winsert-line ; current-window get winsert-line ;
: wattron ( attribute window -- ) ptr>> (wattron) ;
: attron ( attribute -- ) current-window get wattron ;
: wattroff ( attribute window -- ) ptr>> (wattroff) ;
: attroff ( attribute -- ) current-window get wattroff ;
: wall-attroff ( window -- ) [ A_NORMAL ] dip wattroff ;
: all-attroff ( -- ) current-window get wall-attroff ;
: wccolor ( foreground background window -- ) : wccolor ( foreground background window -- )
[ [
2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and 2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
[ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
] dip ptr>> swap ffi:wattron curses-error ; ] dip ptr>> (wattron) ;
: ccolor ( foreground background -- ) : ccolor ( foreground background -- )
current-window get wccolor ; current-window get wccolor ;