 ! 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_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 ;

: curses-ok? ( -- ? )
    { 0 1 2 } [ isatty 0 = not ] all? ;


M: curses-terminal dispose
    [ outfd>> fclose ] [ infd>> fclose ]
    [ ptr>> ffi:delscreen ] tri ;

: init-terminal ( terminal -- curses-terminal )
    "xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi
    [ ffi:newterm curses-pointer-error ] 2keep <curses-terminal> ;

: start-remote-curses ( terminal window -- curses-terminal )
    [
        init-terminal
        ffi:initscr curses-pointer-error drop
        dup ptr>> ffi:set_term curses-pointer-error drop
    ] dip apply-options ;
    
<PRIVATE

: (wcrefresh) ( window-ptr -- ) ffi:wrefresh curses-error ; inline
: (wcwrite) ( string window-ptr -- ) swap ffi:waddstr curses-error ; inline

:: (wcread) ( n encoding window-ptr -- string )
    [
        n 1 + malloc &free :> str
        window-ptr str n ffi:wgetnstr curses-error
        str encoding alien>string
    ] with-destructors ; inline

: (wcmove) ( y x window-ptr -- )
    -rot ffi:wmove curses-error ; inline

: (winsert-blank-line) ( y window-ptr -- )
    [ 0 swap (wcmove) ]
    [ ffi:winsertln curses-error ] bi ; inline

: (waddch) ( ch window-ptr -- )
    swap ffi:waddch curses-error ; inline

: (wgetch) ( window -- key )
    ffi:wgetch [ curses-error ] keep ; inline

PRIVATE>

: wcrefresh ( window -- ) ptr>> (wcrefresh) ;
: crefresh ( -- ) current-window get wcrefresh ;

: wcwrite ( string window -- ) ptr>> (wcwrite) ;
: cwrite ( string -- ) current-window get wcwrite ;

: wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
: cnl ( -- ) current-window get wcnl ;

: wcprint ( string window -- )
    ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
: cprint ( string -- ) current-window get wcprint ;

: wcprintf ( string window -- )
    ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
    [ (wcrefresh) ] tri ;
: curses-print-refresh ( string -- ) current-window get wcprintf ;

: wcwritef ( string window -- )
    ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
: cwritef ( string -- ) current-window get wcwritef ;

: wcread ( n window -- string )
    [ encoding>> ] [ ptr>> ] bi (wcread) ;
: curses-read ( n -- string ) current-window get wcread ;

: wgetch ( window -- key ) ptr>> (wgetch) ;
: getch ( -- key ) current-window get wgetch ;

: waddch ( ch window -- ) ptr>> (waddch) ;
: addch ( ch -- ) current-window get waddch ;

: werase ( window -- ) ptr>> ffi:werase curses-error ;
: erase ( -- ) current-window get werase ;

: wcmove ( y x window -- )
    ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
: cmove ( y x -- ) current-window get wcmove ;

: 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 winsert-blank-line ;

: winsert-line ( string y window -- )
    ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
: insert-line ( string y -- )
    current-window get winsert-line ;

: wccolor ( foreground background window -- )
    [
        2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
        [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
    ] dip ptr>> swap ffi:wattron curses-error ;

: ccolor ( foreground background -- )
    current-window get wccolor ;
