Paste: curses
Author: | blei |
Mode: | factor |
Date: | Sun, 18 Oct 2009 16:50:49 |
Plain Text |
USING: accessors alien.c-types alien.strings assocs byte-arrays
classes.struct combinators continuations curses.ffi destructors
fry io io.encodings.8-bit io.encodings.string io.encodings.utf8
kernel libc locals math namespaces prettyprint sequences
strings threads ;
IN: curses
SYMBOL: current-window
: >BOOLEAN TRUE FALSE ? ; inline
ERROR: duplicate-window window ;
ERROR: unnamed-window window ;
ERROR: window-not-found window ;
ERROR: curses-failed ;
: curses-error ERR = [ curses-failed ] when ;
: with-curses
[
initscr curses-error
[
nocbreak curses-error
echo curses-error
endwin curses-error
] [ ] cleanup
] with-destructors ; inline
: with-window
[ current-window ] dip with-variable ; inline
TUPLE: curses-window < disposable
name
parent-window
ptr
{ lines integer initial: 0 }
{ columns integer initial: 0 }
{ y integer initial: 0 }
{ x integer initial: 0 }
{ cbreak initial: t }
{ echo initial: t }
{ raw initial: f }
{ scrollok initial: t }
{ leaveok initial: f }
idcok idlok immedok
{ keypad initial: f }
{ encoding initial: utf8 } ;
: <curses-window>
curses-window new-disposable ;
M: curses-window dispose*
ptr>> delwin curses-error ;
<PRIVATE
: window-params
{ [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
: set-cbreak/raw
[ drop raw ] [
[ cbreak ] [ nocbreak ] if
] if curses-error ;
PRIVATE>
: setup-window
{
[
dup
dup parent-window>> [
ptr>> swap window-params derwin
] [
window-params newwin
] if* [ curses-error ] keep >>ptr &dispose drop
]
[ [ 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 ]
} cleave ;
<PRIVATE
: (window-curses-refresh) wrefresh curses-error ; inline
: (window-curses-write) swap waddstr curses-error ; inline
:: (window-curses-read)
[
n 1 + malloc &free :> str
window-ptr str n wgetnstr curses-error
str encoding alien>string
] with-destructors ; inline
: (window-curses-getch)
wgetch [ curses-error ] keep ;
: (window-curses-move)
-rot wmove curses-error ; inline
: (window-insert-blank-line)
[ 0 swap (window-curses-move) ]
[ winsertln curses-error ] bi ; inline
: (window-curses-addch)
swap waddch curses-error ; inline
PRIVATE>
: window-curses-refresh ptr>> (window-curses-refresh) ;
: curses-refresh current-window get window-curses-refresh ;
: window-curses-write
ptr>> (window-curses-write) ;
: curses-write
current-window get window-curses-write ;
: window-curses-nl
[ "\n" ] dip ptr>> (window-curses-write) ;
: curses-nl
current-window get window-curses-nl ;
: window-curses-print
ptr>> [ (window-curses-write) ]
[ "\n" swap (window-curses-write) ] bi ;
: curses-print
current-window get window-curses-print ;
: window-curses-print-refresh
ptr>> [ (window-curses-write) ]
[ "\n" swap (window-curses-write) ]
[ (window-curses-refresh) ] tri ;
: curses-print-refresh
current-window get window-curses-print-refresh ;
: window-curses-write-refresh
ptr>> [ (window-curses-write) ] [ (window-curses-refresh) ] bi ;
: curses-write-refresh
current-window get window-curses-write-refresh ;
: window-curses-read
[ encoding>> ] [ ptr>> ] bi (window-curses-read) ;
: curses-read
current-window get window-curses-read ;
: window-curses-getch
ptr>> (window-curses-getch) ;
: curses-getch
current-window get window-curses-getch ;
: window-curses-erase
ptr>> werase curses-error ;
: curses-erase
current-window get window-curses-erase ;
: window-curses-move
ptr>> [ (window-curses-move) ] [ (window-curses-refresh) ] bi ;
: curses-move
current-window get window-curses-move ;
: window-delete-line
ptr>> [ 0 swap (window-curses-move) ]
[ wdeleteln curses-error ] bi ;
: delete-line
current-window get window-delete-line ;
: window-insert-blank-line
ptr>> (window-insert-blank-line) ;
: insert-blank-line
current-window get window-insert-blank-line ;
: window-insert-line
ptr>> [ (window-insert-blank-line) ]
[ (window-curses-write) ] bi ;
: insert-line
current-window get window-insert-line ;
: window-curses-addch
ptr>> (window-curses-addch) ;
: curses-addch
current-window get window-curses-addch ;
New Annotation