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

curses: renamed to shorter words

db4
Philipp Brüschweiler 2009-10-21 17:09:24 +02:00
parent 717f036e52
commit 47ee6ddfef
1 changed files with 93 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

205
extra/curses/curses.factor
View File

@ -1,12 +1,14 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings assocs byte-arrays USING: accessors alien.c-types alien.strings assocs byte-arrays
classes.struct combinators continuations curses.ffi destructors classes.struct combinators continuations destructors
fry io io.encodings.8-bit io.encodings.string io.encodings.utf8 fry io io.encodings.8-bit io.encodings.string io.encodings.utf8
io.streams.c kernel libc locals math memoize multiline io.streams.c kernel libc locals math memoize multiline
namespaces prettyprint sequences strings threads ; namespaces prettyprint sequences strings threads ;
IN: curses IN: curses
QUALIFIED-WITH: curses.ffi ffi
SYMBOL: current-window SYMBOL: current-window
CONSTANT: COLOR_BLACK 0 CONSTANT: COLOR_BLACK 0
@ -18,12 +20,18 @@ CONSTANT: COLOR_MAGEN 5
CONSTANT: COLOR_CYAN 6 CONSTANT: COLOR_CYAN 6
CONSTANT: COLOR_WHITE 7 CONSTANT: COLOR_WHITE 7
: >BOOLEAN ( ? -- TRUE/FALSE ) TRUE FALSE ? ; inline
ERROR: curses-failed ; ERROR: curses-failed ;
ERROR: unsupported-curses-terminal ; ERROR: unsupported-curses-terminal ;
: curses-error ( n -- ) ERR = [ curses-failed ] when ; <PRIVATE
: >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
: curses-pointer-error ( ptr/f -- ptr )
dup [ curses-failed ] unless ; inline
: curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
PRIVATE>
: curses-ok? ( -- ? ) : curses-ok? ( -- ? )
{ 0 1 2 } [ isatty 0 = not ] all? ; { 0 1 2 } [ isatty 0 = not ] all? ;
@ -52,7 +60,7 @@ TUPLE: curses-window < disposable
curses-window new-disposable ; curses-window new-disposable ;
M: curses-window dispose* ( window -- ) M: curses-window dispose* ( window -- )
ptr>> delwin curses-error ; ptr>> ffi:delwin curses-error ;
<PRIVATE <PRIVATE
@ -60,65 +68,58 @@ M: curses-window dispose* ( window -- )
{ [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ; { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
: set-cbreak/raw ( cbreak raw -- ) : set-cbreak/raw ( cbreak raw -- )
[ drop raw ] [ [ drop ffi:raw ] [
[ cbreak ] [ nocbreak ] if [ ffi:cbreak ] [ ffi:nocbreak ] if
] if curses-error ; ] if curses-error ;
: apply-options ( window -- ) : apply-options ( window -- )
{ {
[ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ] [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
[ echo>> [ echo ] [ noecho ] if curses-error ] [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ]
[ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ] [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi ffi:scrollok curses-error ]
[ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ] [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi ffi:leaveok curses-error ]
[ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ] [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi ffi:keypad curses-error ]
} cleave ; } cleave ;
SYMBOL: n-registered-colors SYMBOL: n-registered-colors
MEMO: register-color ( fg bg -- n ) MEMO: register-color ( fg bg -- n )
[ n-registered-colors get ] 2dip init_pair curses-error [ n-registered-colors get ] 2dip ffi:init_pair curses-error
n-registered-colors [ get ] [ inc ] bi ; n-registered-colors [ get ] [ inc ] bi ;
: init-colors ( -- )
ffi:has_colors [
1 n-registered-colors set
\ register-color reset-memoized
ffi:start_color curses-error
] when ;
PRIVATE> PRIVATE>
: setup-window ( window -- window ) : setup-window ( window -- window )
[ [
dup dup
dup parent-window>> [ dup parent-window>> [
ptr>> swap window-params derwin ptr>> swap window-params ffi:derwin
] [ ] [
window-params newwin window-params ffi:newwin
] if* [ curses-error ] keep >>ptr &dispose ] if* [ curses-error ] keep >>ptr &dispose
] [ apply-options ] bi ; ] [ apply-options ] bi ;
: with-window ( window quot -- ) : with-window ( window quot -- )
[ current-window ] dip with-variable ; inline [ 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>
: with-curses ( window quot -- ) : with-curses ( window quot -- )
curses-ok? [ unsupported-curses-terminal ] unless curses-ok? [ unsupported-curses-terminal ] unless
[ [
[ [
initscr curses-pointer-error ffi:initscr curses-pointer-error
>>ptr dup apply-options >>ptr dup apply-options
] dip ] dip
erase curses-error ffi:erase curses-error
init-colors init-colors
[ [
[ endwin curses-error ] [ ] cleanup [ ffi:endwin curses-error ] [ ] cleanup
] curry with-window ] curry with-window
] with-destructors ; inline ] with-destructors ; inline
@ -133,124 +134,104 @@ TUPLE: curses-terminal < disposable
M: curses-terminal dispose M: curses-terminal dispose
[ outfd>> fclose ] [ infd>> fclose ] [ outfd>> fclose ] [ infd>> fclose ]
[ ptr>> delscreen ] tri ; [ ptr>> ffi:delscreen ] tri ;
: init-terminal ( terminal -- curses-terminal ) : init-terminal ( terminal -- curses-terminal )
"xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi "xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi
[ newterm curses-pointer-error ] 2keep <curses-terminal> ; [ ffi:newterm curses-pointer-error ] 2keep <curses-terminal> ;
: start-remote-curses ( terminal window -- curses-terminal ) : start-remote-curses ( terminal window -- curses-terminal )
[ [
init-terminal init-terminal
initscr curses-pointer-error drop ffi:initscr curses-pointer-error drop
dup ptr>> set_term curses-pointer-error drop dup ptr>> ffi:set_term curses-pointer-error drop
] dip apply-options ; ] dip apply-options ;
<PRIVATE <PRIVATE
: (window-curses-refresh) ( window-ptr -- ) wrefresh curses-error ; inline : (wcrefresh) ( window-ptr -- ) ffi:wrefresh curses-error ; inline
: (window-curses-write) ( string window-ptr -- ) swap waddstr curses-error ; inline : (wcwrite) ( string window-ptr -- ) swap ffi:waddstr curses-error ; inline
:: (window-curses-read) ( n encoding window-ptr -- string ) :: (wcread) ( n encoding window-ptr -- string )
[ [
n 1 + malloc &free :> str n 1 + malloc &free :> str
window-ptr str n wgetnstr curses-error window-ptr str n ffi:wgetnstr curses-error
str encoding alien>string str encoding alien>string
] with-destructors ; inline ] with-destructors ; inline
: (window-curses-getch) ( window -- key ) : (wcmove) ( y x window-ptr -- )
wgetch [ curses-error ] keep ; -rot ffi:wmove curses-error ; inline
: (window-curses-move) ( y x window-ptr -- ) : (winsert-blank-line) ( y window-ptr -- )
-rot wmove curses-error ; inline [ 0 swap (wcmove) ]
[ ffi:winsertln curses-error ] bi ; inline
: (window-insert-blank-line) ( y window-ptr -- ) : (waddch) ( ch window-ptr -- )
[ 0 swap (window-curses-move) ] swap ffi:waddch curses-error ; inline
[ winsertln curses-error ] bi ; inline
: (window-curses-addch) ( ch window-ptr -- ) : (wgetch) ( window -- key )
swap waddch curses-error ; inline ffi:wgetch [ curses-error ] keep ; inline
PRIVATE> PRIVATE>
: window-curses-refresh ( window -- ) ptr>> (window-curses-refresh) ; : wcrefresh ( window -- ) ptr>> (wcrefresh) ;
: curses-refresh ( -- ) current-window get window-curses-refresh ; : crefresh ( -- ) current-window get wcrefresh ;
: window-curses-write ( string window -- ) : wcwrite ( string window -- ) ptr>> (wcwrite) ;
ptr>> (window-curses-write) ; : cwrite ( string -- ) current-window get wcwrite ;
: curses-write ( string -- )
current-window get window-curses-write ;
: window-curses-nl ( window -- ) : wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
[ "\n" ] dip ptr>> (window-curses-write) ; : cnl ( -- ) current-window get wcnl ;
: curses-nl ( -- )
current-window get window-curses-nl ;
: window-curses-print ( string window -- ) : wcprint ( string window -- )
ptr>> [ (window-curses-write) ] ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
[ "\n" swap (window-curses-write) ] bi ; : cprint ( string -- ) current-window get wcprint ;
: curses-print ( string -- )
current-window get window-curses-print ;
: window-curses-print-refresh ( string window -- ) : wcprintf ( string window -- )
ptr>> [ (window-curses-write) ] ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
[ "\n" swap (window-curses-write) ] [ (wcrefresh) ] tri ;
[ (window-curses-refresh) ] tri ; : curses-print-refresh ( string -- ) current-window get wcprintf ;
: curses-print-refresh ( string -- )
current-window get window-curses-print-refresh ;
: window-curses-write-refresh ( string window -- ) : wcwritef ( string window -- )
ptr>> [ (window-curses-write) ] [ (window-curses-refresh) ] bi ; ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
: curses-write-refresh ( string -- ) : cwritef ( string -- ) current-window get wcwritef ;
current-window get window-curses-write-refresh ;
: window-curses-read ( n window -- string ) : wcread ( n window -- string )
[ encoding>> ] [ ptr>> ] bi (window-curses-read) ; [ encoding>> ] [ ptr>> ] bi (wcread) ;
: curses-read ( n -- string ) : curses-read ( n -- string ) current-window get wcread ;
current-window get window-curses-read ;
: window-curses-getch ( window -- key ) : wgetch ( window -- key ) ptr>> (wgetch) ;
ptr>> (window-curses-getch) ; : getch ( -- key ) current-window get wgetch ;
: curses-getch ( -- key )
current-window get window-curses-getch ;
: window-curses-erase ( window -- ) : waddch ( ch window -- ) ptr>> (waddch) ;
ptr>> werase curses-error ; : addch ( ch -- ) current-window get waddch ;
: curses-erase ( -- )
current-window get window-curses-erase ;
: window-curses-move ( y x window -- ) : werase ( window -- ) ptr>> ffi:werase curses-error ;
ptr>> [ (window-curses-move) ] [ (window-curses-refresh) ] bi ; : erase ( -- ) current-window get werase ;
: curses-move ( y x -- )
current-window get window-curses-move ;
: window-delete-line ( y window -- ) : wcmove ( y x window -- )
ptr>> [ 0 swap (window-curses-move) ] ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
[ wdeleteln curses-error ] bi ; : cmove ( y x -- ) current-window get wcmove ;
: delete-line ( y -- )
current-window get window-delete-line ;
: window-insert-blank-line ( y window -- ) : wdelete-line ( y window -- )
ptr>> (window-insert-blank-line) ; ptr>> [ 0 swap (wcmove) ] [ ffi:wdeleteln curses-error ] bi ;
: delete-line ( y -- ) current-window get wdelete-line ;
: winsert-blank-line ( y window -- )
ptr>> (winsert-blank-line) ;
: insert-blank-line ( y -- ) : insert-blank-line ( y -- )
current-window get window-insert-blank-line ; current-window get winsert-blank-line ;
: window-insert-line ( string y window -- ) : winsert-line ( string y window -- )
ptr>> [ (window-insert-blank-line) ] ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
[ (window-curses-write) ] bi ;
: insert-line ( string y -- ) : insert-line ( string y -- )
current-window get window-insert-line ; current-window get winsert-line ;
: window-curses-addch ( ch window -- ) : wccolor ( foreground background 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 2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
[ 2drop 0 ] [ register-color ] if COLOR_PAIR [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
] dip ptr>> swap wattron curses-error ; ] dip ptr>> swap ffi:wattron curses-error ;
: curses-color ( foreground background -- )
current-window get window-curses-color ; : ccolor ( foreground background -- )
current-window get wccolor ;