curses: renamed to shorter words
Philipp Brüschweiler
parent
717f036e52
commit
47ee6ddfef
|
|
@ -1,12 +1,14 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
io.streams.c kernel libc locals math memoize multiline
|
||||
namespaces prettyprint sequences strings threads ;
|
||||
IN: curses
|
||||
|
||||
QUALIFIED-WITH: curses.ffi ffi
|
||||
|
||||
SYMBOL: current-window
|
||||
|
||||
CONSTANT: COLOR_BLACK 0
|
||||
|
|
@ -18,12 +20,18 @@ CONSTANT: COLOR_MAGEN 5
|
|||
CONSTANT: COLOR_CYAN 6
|
||||
CONSTANT: COLOR_WHITE 7
|
||||
|
||||
: >BOOLEAN ( ? -- TRUE/FALSE ) TRUE FALSE ? ; inline
|
||||
|
||||
ERROR: curses-failed ;
|
||||
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? ( -- ? )
|
||||
{ 0 1 2 } [ isatty 0 = not ] all? ;
|
||||
|
|
@ -52,7 +60,7 @@ TUPLE: curses-window < disposable
|
|||
curses-window new-disposable ;
|
||||
|
||||
M: curses-window dispose* ( window -- )
|
||||
ptr>> delwin curses-error ;
|
||||
ptr>> ffi:delwin curses-error ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -60,65 +68,58 @@ M: curses-window dispose* ( window -- )
|
|||
{ [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
|
||||
|
||||
: set-cbreak/raw ( cbreak raw -- )
|
||||
[ drop raw ] [
|
||||
[ cbreak ] [ nocbreak ] if
|
||||
[ drop ffi:raw ] [
|
||||
[ ffi:cbreak ] [ ffi:nocbreak ] if
|
||||
] if curses-error ;
|
||||
|
||||
: apply-options ( window -- )
|
||||
{
|
||||
[ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
|
||||
[ echo>> [ echo ] [ noecho ] if curses-error ]
|
||||
[ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ]
|
||||
[ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ]
|
||||
[ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ]
|
||||
[ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ]
|
||||
[ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi ffi:scrollok curses-error ]
|
||||
[ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi ffi:leaveok curses-error ]
|
||||
[ [ ptr>> ] [ keypad>> >BOOLEAN ] bi ffi:keypad curses-error ]
|
||||
} cleave ;
|
||||
|
||||
SYMBOL: n-registered-colors
|
||||
|
||||
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 ;
|
||||
|
||||
: init-colors ( -- )
|
||||
ffi:has_colors [
|
||||
1 n-registered-colors set
|
||||
\ register-color reset-memoized
|
||||
ffi:start_color curses-error
|
||||
] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: setup-window ( window -- window )
|
||||
[
|
||||
dup
|
||||
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
|
||||
] [ 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>
|
||||
|
||||
: with-curses ( window quot -- )
|
||||
curses-ok? [ unsupported-curses-terminal ] unless
|
||||
[
|
||||
[
|
||||
initscr curses-pointer-error
|
||||
ffi:initscr curses-pointer-error
|
||||
>>ptr dup apply-options
|
||||
] dip
|
||||
erase curses-error
|
||||
ffi:erase curses-error
|
||||
init-colors
|
||||
[
|
||||
[ endwin curses-error ] [ ] cleanup
|
||||
[ ffi:endwin curses-error ] [ ] cleanup
|
||||
] curry with-window
|
||||
] with-destructors ; inline
|
||||
|
||||
|
|
@ -133,124 +134,104 @@ TUPLE: curses-terminal < disposable
|
|||
|
||||
M: curses-terminal dispose
|
||||
[ outfd>> fclose ] [ infd>> fclose ]
|
||||
[ ptr>> delscreen ] tri ;
|
||||
[ ptr>> ffi:delscreen ] tri ;
|
||||
|
||||
: init-terminal ( terminal -- curses-terminal )
|
||||
"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 )
|
||||
[
|
||||
init-terminal
|
||||
initscr curses-pointer-error drop
|
||||
dup ptr>> set_term curses-pointer-error drop
|
||||
ffi:initscr curses-pointer-error drop
|
||||
dup ptr>> ffi:set_term curses-pointer-error drop
|
||||
] dip apply-options ;
|
||||
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (window-curses-refresh) ( window-ptr -- ) wrefresh curses-error ; inline
|
||||
: (window-curses-write) ( string window-ptr -- ) swap waddstr curses-error ; inline
|
||||
: (wcrefresh) ( window-ptr -- ) ffi:wrefresh 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
|
||||
window-ptr str n wgetnstr curses-error
|
||||
window-ptr str n ffi:wgetnstr curses-error
|
||||
str encoding alien>string
|
||||
] with-destructors ; inline
|
||||
|
||||
: (window-curses-getch) ( window -- key )
|
||||
wgetch [ curses-error ] keep ;
|
||||
: (wcmove) ( y x window-ptr -- )
|
||||
-rot ffi:wmove curses-error ; inline
|
||||
|
||||
: (window-curses-move) ( y x window-ptr -- )
|
||||
-rot wmove curses-error ; inline
|
||||
: (winsert-blank-line) ( y window-ptr -- )
|
||||
[ 0 swap (wcmove) ]
|
||||
[ ffi:winsertln curses-error ] bi ; inline
|
||||
|
||||
: (window-insert-blank-line) ( y window-ptr -- )
|
||||
[ 0 swap (window-curses-move) ]
|
||||
[ winsertln curses-error ] bi ; inline
|
||||
: (waddch) ( ch window-ptr -- )
|
||||
swap ffi:waddch curses-error ; inline
|
||||
|
||||
: (window-curses-addch) ( ch window-ptr -- )
|
||||
swap waddch curses-error ; inline
|
||||
: (wgetch) ( window -- key )
|
||||
ffi:wgetch [ curses-error ] keep ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: window-curses-refresh ( window -- ) ptr>> (window-curses-refresh) ;
|
||||
: curses-refresh ( -- ) current-window get window-curses-refresh ;
|
||||
: wcrefresh ( window -- ) ptr>> (wcrefresh) ;
|
||||
: crefresh ( -- ) current-window get wcrefresh ;
|
||||
|
||||
: window-curses-write ( string window -- )
|
||||
ptr>> (window-curses-write) ;
|
||||
: curses-write ( string -- )
|
||||
current-window get window-curses-write ;
|
||||
: wcwrite ( string window -- ) ptr>> (wcwrite) ;
|
||||
: cwrite ( string -- ) current-window get wcwrite ;
|
||||
|
||||
: window-curses-nl ( window -- )
|
||||
[ "\n" ] dip ptr>> (window-curses-write) ;
|
||||
: curses-nl ( -- )
|
||||
current-window get window-curses-nl ;
|
||||
: wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
|
||||
: cnl ( -- ) current-window get wcnl ;
|
||||
|
||||
: window-curses-print ( string window -- )
|
||||
ptr>> [ (window-curses-write) ]
|
||||
[ "\n" swap (window-curses-write) ] bi ;
|
||||
: curses-print ( string -- )
|
||||
current-window get window-curses-print ;
|
||||
: wcprint ( string window -- )
|
||||
ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
|
||||
: cprint ( string -- ) current-window get wcprint ;
|
||||
|
||||
: 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 ;
|
||||
: wcprintf ( string window -- )
|
||||
ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
|
||||
[ (wcrefresh) ] tri ;
|
||||
: curses-print-refresh ( string -- ) current-window get wcprintf ;
|
||||
|
||||
: 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 ;
|
||||
: wcwritef ( string window -- )
|
||||
ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
|
||||
: cwritef ( string -- ) current-window get wcwritef ;
|
||||
|
||||
: window-curses-read ( n window -- string )
|
||||
[ encoding>> ] [ ptr>> ] bi (window-curses-read) ;
|
||||
: curses-read ( n -- string )
|
||||
current-window get window-curses-read ;
|
||||
: wcread ( n window -- string )
|
||||
[ encoding>> ] [ ptr>> ] bi (wcread) ;
|
||||
: curses-read ( n -- string ) current-window get wcread ;
|
||||
|
||||
: window-curses-getch ( window -- key )
|
||||
ptr>> (window-curses-getch) ;
|
||||
: curses-getch ( -- key )
|
||||
current-window get window-curses-getch ;
|
||||
: wgetch ( window -- key ) ptr>> (wgetch) ;
|
||||
: getch ( -- key ) current-window get wgetch ;
|
||||
|
||||
: window-curses-erase ( window -- )
|
||||
ptr>> werase curses-error ;
|
||||
: curses-erase ( -- )
|
||||
current-window get window-curses-erase ;
|
||||
: waddch ( ch window -- ) ptr>> (waddch) ;
|
||||
: addch ( ch -- ) current-window get waddch ;
|
||||
|
||||
: window-curses-move ( y x window -- )
|
||||
ptr>> [ (window-curses-move) ] [ (window-curses-refresh) ] bi ;
|
||||
: curses-move ( y x -- )
|
||||
current-window get window-curses-move ;
|
||||
: werase ( window -- ) ptr>> ffi:werase curses-error ;
|
||||
: erase ( -- ) current-window get werase ;
|
||||
|
||||
: window-delete-line ( y window -- )
|
||||
ptr>> [ 0 swap (window-curses-move) ]
|
||||
[ wdeleteln curses-error ] bi ;
|
||||
: delete-line ( y -- )
|
||||
current-window get window-delete-line ;
|
||||
: wcmove ( y x window -- )
|
||||
ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
|
||||
: cmove ( y x -- ) current-window get wcmove ;
|
||||
|
||||
: window-insert-blank-line ( y window -- )
|
||||
ptr>> (window-insert-blank-line) ;
|
||||
: wdelete-line ( y window -- )
|
||||
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 -- )
|
||||
current-window get window-insert-blank-line ;
|
||||
current-window get winsert-blank-line ;
|
||||
|
||||
: window-insert-line ( string y window -- )
|
||||
ptr>> [ (window-insert-blank-line) ]
|
||||
[ (window-curses-write) ] bi ;
|
||||
: winsert-line ( string y window -- )
|
||||
ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
|
||||
: insert-line ( string y -- )
|
||||
current-window get window-insert-line ;
|
||||
current-window get winsert-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 -- )
|
||||
: wccolor ( 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 ;
|
||||
[ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
|
||||
] dip ptr>> swap ffi:wattron curses-error ;
|
||||
|
||||
: ccolor ( foreground background -- )
|
||||
current-window get wccolor ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue