diff --git a/extra/curses/curses-tests.factor b/extra/curses/curses-tests.factor index bd98a7aff1..9ffd191681 100644 --- a/extra/curses/curses-tests.factor +++ b/extra/curses/curses-tests.factor @@ -1,19 +1,29 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors curses kernel threads tools.test ; +USING: accessors calendar curses kernel threads tools.test +strings sequences random ; IN: curses.tests : hello-curses ( -- ) - [ - curses-window new - "mainwin" >>name - add-curses-window + [ + "Hello Curses!" [ + dup cmove addch + ] each-index + crefresh - "mainwin" "hi" curses-printf + 2 seconds sleep + ] with-curses ; - 2000000 sleep +: hello-curses-color ( -- ) + [ + "Hello Curses!" [ + 8 random 8 random ccolor addch + ] each crefresh + + 2 seconds sleep ] with-curses ; curses-ok? [ [ ] [ hello-curses ] unit-test + [ ] [ hello-curses-color ] unit-test ] when diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index dfb1b8672a..0db3e8f649 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -1,162 +1,480 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.strings assocs byte-arrays -combinators continuations destructors fry io.encodings.8-bit -io io.encodings.string io.encodings.utf8 kernel locals math -namespaces prettyprint sequences classes.struct -strings threads curses.ffi unix.ffi ; +USING: accessors alien.c-types alien.strings classes.struct +combinators continuations destructors fry io.encodings.utf8 +kernel libc locals math memoize multiline namespaces sequences +unix.ffi ; + +QUALIFIED-WITH: curses.ffi ffi + IN: curses -SYMBOL: curses-windows SYMBOL: current-window -CONSTANT: ERR -1 -CONSTANT: FALSE 0 -CONSTANT: TRUE 1 -: >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline +CONSTANT: COLOR_BLACK 0 +CONSTANT: COLOR_RED 1 +CONSTANT: COLOR_GREEN 2 +CONSTANT: COLOR_YELLO 3 +CONSTANT: COLOR_BLUE 4 +CONSTANT: COLOR_MAGEN 5 +CONSTANT: COLOR_CYAN 6 +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 + +CONSTANT: KEY_CODE_YES OCT: 400 /* A wchar_t contains a key code */ +CONSTANT: KEY_MIN OCT: 401 /* Minimum curses key */ +CONSTANT: KEY_BREAK OCT: 401 /* Break key (unreliable) */ +CONSTANT: KEY_SRESET OCT: 530 /* Soft (partial) reset (unreliable) */ +CONSTANT: KEY_RESET OCT: 531 /* Reset or hard reset (unreliable) */ +CONSTANT: KEY_DOWN OCT: 402 /* down-arrow key */ +CONSTANT: KEY_UP OCT: 403 /* up-arrow key */ +CONSTANT: KEY_LEFT OCT: 404 /* left-arrow key */ +CONSTANT: KEY_RIGHT OCT: 405 /* right-arrow key */ +CONSTANT: KEY_HOME OCT: 406 /* home key */ +CONSTANT: KEY_BACKSPACE OCT: 407 /* backspace key */ +CONSTANT: KEY_DL OCT: 510 /* delete-line key */ +CONSTANT: KEY_IL OCT: 511 /* insert-line key */ +CONSTANT: KEY_DC OCT: 512 /* delete-character key */ +CONSTANT: KEY_IC OCT: 513 /* insert-character key */ +CONSTANT: KEY_EIC OCT: 514 /* sent by rmir or smir in insert mode */ +CONSTANT: KEY_CLEAR OCT: 515 /* clear-screen or erase key */ +CONSTANT: KEY_EOS OCT: 516 /* clear-to-end-of-screen key */ +CONSTANT: KEY_EOL OCT: 517 /* clear-to-end-of-line key */ +CONSTANT: KEY_SF OCT: 520 /* scroll-forward key */ +CONSTANT: KEY_SR OCT: 521 /* scroll-backward key */ +CONSTANT: KEY_NPAGE OCT: 522 /* next-page key */ +CONSTANT: KEY_PPAGE OCT: 523 /* previous-page key */ +CONSTANT: KEY_STAB OCT: 524 /* set-tab key */ +CONSTANT: KEY_CTAB OCT: 525 /* clear-tab key */ +CONSTANT: KEY_CATAB OCT: 526 /* clear-all-tabs key */ +CONSTANT: KEY_ENTER OCT: 527 /* enter/send key */ +CONSTANT: KEY_PRINT OCT: 532 /* print key */ +CONSTANT: KEY_LL OCT: 533 /* lower-left key (home down) */ +CONSTANT: KEY_A1 OCT: 534 /* upper left of keypad */ +CONSTANT: KEY_A3 OCT: 535 /* upper right of keypad */ +CONSTANT: KEY_B2 OCT: 536 /* center of keypad */ +CONSTANT: KEY_C1 OCT: 537 /* lower left of keypad */ +CONSTANT: KEY_C3 OCT: 540 /* lower right of keypad */ +CONSTANT: KEY_BTAB OCT: 541 /* back-tab key */ +CONSTANT: KEY_BEG OCT: 542 /* begin key */ +CONSTANT: KEY_CANCEL OCT: 543 /* cancel key */ +CONSTANT: KEY_CLOSE OCT: 544 /* close key */ +CONSTANT: KEY_COMMAND OCT: 545 /* command key */ +CONSTANT: KEY_COPY OCT: 546 /* copy key */ +CONSTANT: KEY_CREATE OCT: 547 /* create key */ +CONSTANT: KEY_END OCT: 550 /* end key */ +CONSTANT: KEY_EXIT OCT: 551 /* exit key */ +CONSTANT: KEY_FIND OCT: 552 /* find key */ +CONSTANT: KEY_HELP OCT: 553 /* help key */ +CONSTANT: KEY_MARK OCT: 554 /* mark key */ +CONSTANT: KEY_MESSAGE OCT: 555 /* message key */ +CONSTANT: KEY_MOVE OCT: 556 /* move key */ +CONSTANT: KEY_NEXT OCT: 557 /* next key */ +CONSTANT: KEY_OPEN OCT: 560 /* open key */ +CONSTANT: KEY_OPTIONS OCT: 561 /* options key */ +CONSTANT: KEY_PREVIOUS OCT: 562 /* previous key */ +CONSTANT: KEY_REDO OCT: 563 /* redo key */ +CONSTANT: KEY_REFERENCE OCT: 564 /* reference key */ +CONSTANT: KEY_REFRESH OCT: 565 /* refresh key */ +CONSTANT: KEY_REPLACE OCT: 566 /* replace key */ +CONSTANT: KEY_RESTART OCT: 567 /* restart key */ +CONSTANT: KEY_RESUME OCT: 570 /* resume key */ +CONSTANT: KEY_SAVE OCT: 571 /* save key */ +CONSTANT: KEY_SBEG OCT: 572 /* shifted begin key */ +CONSTANT: KEY_SCANCEL OCT: 573 /* shifted cancel key */ +CONSTANT: KEY_SCOMMAND OCT: 574 /* shifted command key */ +CONSTANT: KEY_SCOPY OCT: 575 /* shifted copy key */ +CONSTANT: KEY_SCREATE OCT: 576 /* shifted create key */ +CONSTANT: KEY_SDC OCT: 577 /* shifted delete-character key */ +CONSTANT: KEY_SDL OCT: 600 /* shifted delete-line key */ +CONSTANT: KEY_SELECT OCT: 601 /* select key */ +CONSTANT: KEY_SEND OCT: 602 /* shifted end key */ +CONSTANT: KEY_SEOL OCT: 603 /* shifted clear-to-end-of-line key */ +CONSTANT: KEY_SEXIT OCT: 604 /* shifted exit key */ +CONSTANT: KEY_SFIND OCT: 605 /* shifted find key */ +CONSTANT: KEY_SHELP OCT: 606 /* shifted help key */ +CONSTANT: KEY_SHOME OCT: 607 /* shifted home key */ +CONSTANT: KEY_SIC OCT: 610 /* shifted insert-character key */ +CONSTANT: KEY_SLEFT OCT: 611 /* shifted left-arrow key */ +CONSTANT: KEY_SMESSAGE OCT: 612 /* shifted message key */ +CONSTANT: KEY_SMOVE OCT: 613 /* shifted move key */ +CONSTANT: KEY_SNEXT OCT: 614 /* shifted next key */ +CONSTANT: KEY_SOPTIONS OCT: 615 /* shifted options key */ +CONSTANT: KEY_SPREVIOUS OCT: 616 /* shifted previous key */ +CONSTANT: KEY_SPRINT OCT: 617 /* shifted print key */ +CONSTANT: KEY_SREDO OCT: 620 /* shifted redo key */ +CONSTANT: KEY_SREPLACE OCT: 621 /* shifted replace key */ +CONSTANT: KEY_SRIGHT OCT: 622 /* shifted right-arrow key */ +CONSTANT: KEY_SRSUME OCT: 623 /* shifted resume key */ +CONSTANT: KEY_SSAVE OCT: 624 /* shifted save key */ +CONSTANT: KEY_SSUSPEND OCT: 625 /* shifted suspend key */ +CONSTANT: KEY_SUNDO OCT: 626 /* shifted undo key */ +CONSTANT: KEY_SUSPEND OCT: 627 /* suspend key */ +CONSTANT: KEY_UNDO OCT: 630 /* undo key */ +CONSTANT: KEY_MOUSE OCT: 631 /* Mouse event has occurred */ +CONSTANT: KEY_RESIZE OCT: 632 /* Terminal resize event */ +CONSTANT: KEY_EVENT OCT: 633 /* We were interrupted by an event */ +CONSTANT: KEY_MAX OCT: 777 /* Maximum key value is 0633 */ +CONSTANT: KEY_F0 OCT: 410 /* Function keys. Space for 64 */ +: KEY_F ( n -- code ) KEY_F0 + ; inline /* Value of function key n */ + +: BUTTON1_RELEASED ( -- mask ) 1 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON1_PRESSED ( -- mask ) 1 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON1_CLICKED ( -- mask ) 1 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON1_DOUBLE_CLICKED ( -- mask ) 1 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON1_TRIPLE_CLICKED ( -- mask ) 1 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON2_RELEASED ( -- mask ) 2 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON2_PRESSED ( -- mask ) 2 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON2_CLICKED ( -- mask ) 2 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON2_DOUBLE_CLICKED ( -- mask ) 2 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON2_TRIPLE_CLICKED ( -- mask ) 2 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON3_RELEASED ( -- mask ) 3 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON3_PRESSED ( -- mask ) 3 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON3_CLICKED ( -- mask ) 3 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON3_DOUBLE_CLICKED ( -- mask ) 3 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON3_TRIPLE_CLICKED ( -- mask ) 3 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON4_RELEASED ( -- mask ) 4 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON4_PRESSED ( -- mask ) 4 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON4_CLICKED ( -- mask ) 4 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON4_DOUBLE_CLICKED ( -- mask ) 4 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON4_TRIPLE_CLICKED ( -- mask ) 4 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline + +: BUTTON1_RESERVED_EVENT ( -- mask ) 1 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON2_RESERVED_EVENT ( -- mask ) 2 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON3_RESERVED_EVENT ( -- mask ) 3 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON4_RESERVED_EVENT ( -- mask ) 4 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline + +: BUTTON_CTRL ( -- mask ) 5 OCT: 01 ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON_SHIFT ( -- mask ) 5 OCT: 02 ffi:NCURSES_MOUSE_MASK ; inline +: BUTTON_ALT ( -- mask ) 5 OCT: 04 ffi:NCURSES_MOUSE_MASK ; inline +: REPORT_MOUSE_POSITION ( -- mask ) 5 OCT: 10 ffi:NCURSES_MOUSE_MASK ; inline + +: ALL_MOUSE_EVENTS ( -- mask ) REPORT_MOUSE_POSITION 1 - ; inline -ERROR: duplicate-window window ; -ERROR: unnamed-window window ; -ERROR: window-not-found window ; ERROR: curses-failed ; ERROR: unsupported-curses-terminal ; -: get-window ( string -- window ) - dup curses-windows get at* - [ nip ] [ drop window-not-found ] if ; +> ; +: >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline -: curses-error ( n -- ) ERR = [ curses-failed ] when ; +: curses-pointer-error ( ptr/f -- ptr ) + [ curses-failed ] unless* ; inline +: curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ; + +PRIVATE> : curses-ok? ( -- ? ) { 0 1 2 } [ isatty 0 = not ] all? ; -: with-curses ( quot -- ) - curses-ok? [ unsupported-curses-terminal ] unless - H{ } clone curses-windows [ - initscr curses-error - [ - curses-windows get values [ dispose ] each - nocbreak curses-error - echo curses-error - endwin curses-error - ] [ ] cleanup - ] with-variable ; inline - -: with-window ( name quot -- ) - [ window-ptr current-window ] dip with-variable ; inline - -TUPLE: curses-window - name - parent-name +TUPLE: curses-window < disposable ptr + parent-window { lines integer initial: 0 } { columns integer initial: 0 } { y integer initial: 0 } { x integer initial: 0 } { cbreak initial: t } - { echo initial: t } + { echo initial: f } { raw initial: f } { scrollok initial: t } { leaveok initial: f } idcok idlok immedok - { keypad initial: f } ; + { keypad initial: t } -M: curses-window dispose ( window -- ) - ptr>> delwin curses-error ; + { encoding initial: utf8 } ; + +: ( -- window ) + curses-window new-disposable ; + +M: curses-window dispose* ( window -- ) + ptr>> ffi:delwin curses-error ; > [ unnamed-window ] unless* - curses-windows get 2dup key? - [ duplicate-window ] [ set-at ] if ; - -: delete-window ( window -- ) - curses-windows get 2dup key? - [ delete-at ] [ drop window-not-found ] if ; - : window-params ( window -- lines columns y x ) { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ; -: setup-window ( window -- ) +: set-cbreak/raw ( cbreak raw -- ) + [ drop ffi:raw ] [ + [ ffi:cbreak ] [ ffi:nocbreak ] if + ] if curses-error ; + +: apply-window-options ( window -- ) { - [ - dup - dup parent-name>> [ - window-ptr swap window-params derwin - ] [ - window-params newwin - ] if* [ curses-error ] keep >>ptr drop - ] - [ cbreak>> [ cbreak ] [ nocbreak ] if curses-error ] - [ echo>> [ echo ] [ noecho ] if curses-error ] - [ raw>> [ raw ] [ noraw ] if curses-error ] - [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ] - [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ] - [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ] - [ add-window ] + [ [ 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 ; +: apply-global-options ( window -- ) + [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ] + [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ] + bi ; + +SYMBOL: n-registered-colors + +MEMO: register-color ( fg bg -- n ) + [ n-registered-colors get dup ] 2dip ffi:init_pair curses-error + n-registered-colors inc ; + +: init-colors ( -- ) + ffi:has_colors [ + 1 n-registered-colors set + \ register-color reset-memoized + ffi:start_color curses-error + ffi:stdscr 0 f ffi:wcolor_set curses-error + ] when ; + PRIVATE> -: add-curses-window ( window -- ) - [ setup-window ] [ ] [ dispose ] cleanup ; - -: (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ; -: wnrefresh ( window -- ) window-ptr (curses-window-refresh) ; -: curses-refresh ( -- ) current-window get (curses-window-refresh) ; - -: (curses-wprint) ( window-ptr string -- ) - waddstr curses-error ; - -: curses-nwrite ( window string -- ) - [ window-ptr ] dip (curses-wprint) ; - -: curses-wprint ( window string -- ) - [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ; - -: curses-printf ( window string -- ) - [ window-ptr dup dup ] dip (curses-wprint) - "\n" (curses-wprint) - (curses-window-refresh) ; - -: curses-writef ( window string -- ) - [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ; - -:: (curses-read) ( window-ptr n encoding -- string ) - n :> buf - window-ptr buf n wgetnstr curses-error - buf encoding alien>string ; - -: curses-read ( window n -- string ) - utf8 [ window-ptr ] 2dip (curses-read) ; - -: curses-erase ( window -- ) window-ptr werase curses-error ; - -: move-cursor ( window-name y x -- ) +: setup-window ( window -- window ) [ - window-ptr c-window memory>struct - { - [ ] - [ (curses-window-refresh) ] - [ _curx>> ] - [ _cury>> ] - } cleave - ] 2dip mvcur curses-error (curses-window-refresh) ; + dup [ window-params ] keep + parent-window>> [ ptr>> ffi:derwin ] [ ffi:newwin ] if* + curses-pointer-error >>ptr &dispose + ] [ apply-window-options ] bi ; -: delete-line ( window-name y -- ) - [ window-ptr dup ] dip - 0 wmove curses-error wdeleteln curses-error ; +: with-window ( window quot -- ) + [ current-window ] dip with-variable ; inline -: insert-blank-line ( window-name y -- ) - [ window-ptr dup ] dip - 0 wmove curses-error winsertln curses-error ; +: with-curses ( window quot -- ) + curses-ok? [ unsupported-curses-terminal ] unless + [ + '[ + ffi:initscr curses-pointer-error + >>ptr + { + [ apply-global-options ] + [ apply-window-options ] + [ ptr>> ffi:wclear curses-error ] + [ ptr>> ffi:wrefresh curses-error ] + [ ] + } cleave + init-colors -: insert-line ( window-name y string -- ) - [ dupd insert-blank-line ] dip - curses-writef ; + _ with-window + ] [ ffi:endwin curses-error ] [ ] cleanup + ] with-destructors ; inline + + 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 + +: (wattroff) ( attribute window-ptr -- ) + swap ffi:wattroff curses-error ; inline + +: (wattron) ( attribute window-ptr -- ) + swap ffi:wattron curses-error ; inline + +PRIVATE> + +: wcrefresh ( window -- ) ptr>> (wcrefresh) ; +: crefresh ( -- ) current-window get wcrefresh ; + +: wgetch ( window -- key ) ptr>> (wgetch) ; +: getch ( -- key ) current-window get wgetch ; + +: waddch ( ch window -- ) ptr>> (waddch) ; +: addch ( ch -- ) current-window get waddch ; + +: wcnl ( window -- ) [ CHAR: \n ] dip waddch ; +: cnl ( -- ) current-window get wcnl ; + +: wcwrite ( string window -- ) ptr>> (wcwrite) ; +: cwrite ( string -- ) current-window get wcwrite ; + +: wcprint ( string window -- ) + ptr>> [ (wcwrite) ] [ CHAR: \n swap (waddch) ] bi ; +: cprint ( string -- ) current-window get wcprint ; + +: wcprintf ( string window -- ) + ptr>> [ (wcwrite) ] [ CHAR: \n swap (waddch) ] + [ (wcrefresh) ] tri ; +: cprintf ( 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) ; +: cread ( n -- string ) current-window get wcread ; + +: 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 ; + +: 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 -- ) + [ register-color ] dip ptr>> swap f ffi:wcolor_set curses-error ; + +: ccolor ( foreground background -- ) + current-window get wccolor ; + +: wccbox ( window -- ) + ptr>> 0 0 ffi:box curses-error ; +: cbox ( -- ) + current-window get wccbox ; + +SYMBOLS: +pressed+ +released+ +clicked+ +double+ +triple+ ; + +TUPLE: mouse-event + { id fixnum } + { y fixnum } + { x fixnum } + { button fixnum } + type + alt + shift + ctrl ; + +>type drop ; inline + +: fill-in-bstate ( mouse-event bstate -- ) + 2dup { + { [ dup 1 button-n? ] [ [ 1 >>button ] dip 1 fill-in-type ] } + { [ dup 2 button-n? ] [ [ 2 >>button ] dip 2 fill-in-type ] } + { [ dup 3 button-n? ] [ [ 3 >>button ] dip 3 fill-in-type ] } + { [ dup 4 button-n? ] [ [ 4 >>button ] dip 4 fill-in-type ] } + } cond + { + [ BUTTON_CTRL bitand 0 = not [ t >>ctrl ] when drop ] + [ BUTTON_SHIFT bitand 0 = not [ t >>shift ] when drop ] + [ BUTTON_ALT bitand 0 = not [ t >>alt ] when drop ] + } 2cleave ; + +: ( MEVENT -- mouse-event ) + [ mouse-event new ] dip { + [ id>> >>id drop ] + [ y>> >>y drop ] + [ x>> >>x drop ] + [ bstate>> fill-in-bstate ] + [ drop ] + } 2cleave ; + +PRIVATE> + +: getmouse ( -- mouse-event/f ) + [ + ffi:MEVENT malloc-struct &free + dup ffi:getmouse + ffi:ERR = [ drop f ] [ ] if + ] with-destructors ; + +: mousemask ( mask -- newmask oldmask ) + 0 [ ffi:mousemask ] keep *ulong ; + +: wget-yx ( window -- y x ) + ptr>> [ _cury>> ] [ _curx>> ] bi ; +: get-yx ( -- y x ) + current-window get wget-yx ; + +: wget-y ( window -- y ) + ptr>> _cury>> ; +: get-y ( -- y ) + current-window get wget-y ; +: wget-x ( window -- x ) + ptr>> _curx>> ; +: get-x ( -- x ) + current-window get wget-x ; + +: wget-max-yx ( window -- y x ) + ptr>> [ _maxy>> 1 + ] [ _maxx>> 1 + ] bi ; +: get-max-yx ( -- y x ) + current-window get wget-max-yx ; + +: wget-max-y ( window -- y ) + ptr>> _maxy>> 1 + ; +: get-max-y ( -- y ) + current-window get wget-max-y ; +: wget-max-x ( window -- x ) + ptr>> _maxx>> 1 + ; +: get-max-x ( -- x ) + current-window get wget-max-x ; diff --git a/extra/curses/ffi/ffi.factor b/extra/curses/ffi/ffi.factor index 2b52d0ec56..85bc15d34b 100644 --- a/extra/curses/ffi/ffi.factor +++ b/extra/curses/ffi/ffi.factor @@ -1,16 +1,15 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.syntax combinators kernel system -alien.c-types alien.libraries classes.struct unix.types ; +USING: accessors alien alien.c-types alien.libraries +alien.syntax classes.struct combinators kernel math system unix.types ; IN: curses.ffi << "curses" { { [ os winnt? ] [ "libcurses.dll" ] } { [ os macosx? ] [ "libcurses.dylib" ] } - { [ os unix? ] [ "libcurses.so" ] } + { [ os unix? ] [ "libncursesw.so" ] } } cond cdecl add-library >> -C-TYPE: WINDOW C-TYPE: SCREEN TYPEDEF: void* va_list @@ -18,59 +17,69 @@ TYPEDEF: uint chtype TYPEDEF: chtype attr_t TYPEDEF: short NCURSES_SIZE_T TYPEDEF: ushort wchar_t +TYPEDEF: ulong mmask_t CONSTANT: CCHARW_MAX 5 +CONSTANT: ERR -1 +CONSTANT: FALSE 0 +CONSTANT: TRUE 1 + STRUCT: cchar_t - { attr attr_t } - { chars { wchar_t CCHARW_MAX } } ; +{ attr attr_t } +{ chars { wchar_t CCHARW_MAX } } ; STRUCT: pdat - { _pad_y NCURSES_SIZE_T } - { _pad_x NCURSES_SIZE_T } - { _pad_top NCURSES_SIZE_T } - { _pad_left NCURSES_SIZE_T } - { _pad_bottom NCURSES_SIZE_T } - { _pad_right NCURSES_SIZE_T } ; +{ _pad_y NCURSES_SIZE_T } +{ _pad_x NCURSES_SIZE_T } +{ _pad_top NCURSES_SIZE_T } +{ _pad_left NCURSES_SIZE_T } +{ _pad_bottom NCURSES_SIZE_T } +{ _pad_right NCURSES_SIZE_T } ; -STRUCT: c-window - { _cury NCURSES_SIZE_T } - { _curx NCURSES_SIZE_T } +STRUCT: WINDOW +{ _cury NCURSES_SIZE_T } +{ _curx NCURSES_SIZE_T } - { _maxy NCURSES_SIZE_T } - { _maxx NCURSES_SIZE_T } - { _begy NCURSES_SIZE_T } - { _begx NCURSES_SIZE_T } +{ _maxy NCURSES_SIZE_T } +{ _maxx NCURSES_SIZE_T } +{ _begy NCURSES_SIZE_T } +{ _begx NCURSES_SIZE_T } - { _flags short } +{ _flags short } - { _attrs attr_t } - { _bkgd chtype } +{ _attrs attr_t } +{ _bkgd chtype } - { _notimeout bool } - { _clear bool } - { _leaveok bool } - { _scroll bool } - { _idlok bool } - { _idcok bool } - { _immed bool } - { _sync bool } - { _use_keypad bool } - { _delay int } +{ _notimeout bool } +{ _clear bool } +{ _leaveok bool } +{ _scroll bool } +{ _idlok bool } +{ _idcok bool } +{ _immed bool } +{ _sync bool } +{ _use_keypad bool } +{ _delay int } - { _line c-string } - { _regtop NCURSES_SIZE_T } - { _regbottom NCURSES_SIZE_T } +{ _line c-string } +{ _regtop NCURSES_SIZE_T } +{ _regbottom NCURSES_SIZE_T } - { _parx int } - { _pary int } - { _parent WINDOW* } +{ _parx int } +{ _pary int } +{ _parent WINDOW* } - { _pad pdat } +{ _pad pdat } - { _yoffset NCURSES_SIZE_T } +{ _yoffset NCURSES_SIZE_T } - { _bkgrnd cchar_t } ; +{ _bkgrnd cchar_t } ; + +STRUCT: MEVENT + { id short } + { x int } { y int } { z int } + { bstate mmask_t } ; LIBRARY: curses @@ -134,13 +143,13 @@ FUNCTION: int scrollok ( WINDOW* win, bool bf ) ; FUNCTION: int nl ( ) ; FUNCTION: int nonl ( ) ; -FUNCTION: int erase ( ) ; +FUNCTION: int erase ( ) ; FUNCTION: int werase ( WINDOW* win ) ; -FUNCTION: int clear ( ) ; +FUNCTION: int clear ( ) ; FUNCTION: int wclear ( WINDOW* win ) ; -FUNCTION: int clrtobot ( ) ; +FUNCTION: int clrtobot ( ) ; FUNCTION: int wclrtobot ( WINDOW* win ) ; -FUNCTION: int clrtoeol ( ) ; +FUNCTION: int clrtoeol ( ) ; FUNCTION: int wclrtoeol ( WINDOW* win ) ; FUNCTION: int refresh ( ) ; @@ -176,27 +185,26 @@ FUNCTION: int vw_printw ( WINDOW* win, c-string fmt, va_list varglist ) ; FUNCTION: int move ( int y, int x ) ; FUNCTION: int wmove ( WINDOW* win, int y, int x ) ; - FUNCTION: int scroll ( WINDOW* win ) ; FUNCTION: int scrl ( int n ) ; FUNCTION: int wscrl ( WINDOW* win, int n ) ; - ! int setupterm(char *term, int fildes, int *errret); - ! int setterm(char *term); - ! TERMINAL *set_curterm(TERMINAL *nterm); - ! int del_curterm(TERMINAL *oterm); - ! int restartterm(const char *term, int fildes, int *errret); - ! char *tparm(char *str, ...); - ! int tputs(const char *str, int affcnt, int (*putc)(int)); - ! int putp(const char *str); - ! int vidputs(chtype attrs, int (*putc)(int)); - ! int vidattr(chtype attrs); - ! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char)); - ! int vid_attr(attr_t attrs, short pair, void *opts); +! int setupterm(char *term, int fildes, int *errret); +! int setterm(char *term); +! TERMINAL *set_curterm(TERMINAL *nterm); +! int del_curterm(TERMINAL *oterm); +! int restartterm(const char *term, int fildes, int *errret); +! char *tparm(char *str, ...); +! int tputs(const char *str, int affcnt, int (*putc)(int)); +! int putp(const char *str); +! int vidputs(chtype attrs, int (*putc)(int)); +! int vidattr(chtype attrs); +! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char)); +! int vid_attr(attr_t attrs, short pair, void *opts); FUNCTION: int mvcur ( int oldrow, int oldcol, int newrow, int newcol ) ; - ! int tigetflag(char *capname); - ! int tigetnum(char *capname); - ! char *tigetstr(char *capname); +! int tigetflag(char *capname); +! int tigetnum(char *capname); +! char *tigetstr(char *capname); FUNCTION: int touchwin ( WINDOW* win ) ; FUNCTION: int touchline ( WINDOW* win, int start, int count ) ; @@ -229,3 +237,46 @@ FUNCTION: int mvaddstr ( int y, int x, c-string str ) ; FUNCTION: int mvaddnstr ( int y, int x, c-string str, int n ) ; FUNCTION: int mvwaddstr ( WINDOW* win, int y, int x, c-string str ) ; FUNCTION: int mvwaddnstr ( WINDOW* win, int y, int x, c-string str, int n ) ; + +FUNCTION: int waddch ( WINDOW* win, chtype ch ) ; + +FUNCTION: int start_color ( ) ; +FUNCTION: int init_pair ( short pair, short f, short b ) ; +FUNCTION: int init_color ( short color, short r, short g, short b ) ; +FUNCTION: bool has_colors ( ) ; +FUNCTION: bool can_change_color ( ) ; +FUNCTION: int color_content ( short color, short* r, short* g, short* b ) ; +FUNCTION: int pair_content ( short pair, short* f, short* b ) ; + +C-GLOBAL: int COLORS +C-GLOBAL: int COLOR_PAIRS + +: COLOR_PAIR ( n -- n' ) 8 shift ; inline foldable + +FUNCTION: int wcolor_set ( WINDOW* win, short color_pair_number, void* opts ) ; + +FUNCTION: int wattron ( WINDOW* win, int attrs ) ; +FUNCTION: int wattroff ( WINDOW* win, int attrs ) ; +FUNCTION: int wattrset ( WINDOW* win, int attrs ) ; + +: NCURSES_MOUSE_MASK ( b m -- mask ) swap 1 - 6 * shift ; inline + +CONSTANT: NCURSES_BUTTON_RELEASED OCT: 01 +CONSTANT: NCURSES_BUTTON_PRESSED OCT: 02 +CONSTANT: NCURSES_BUTTON_CLICKED OCT: 04 +CONSTANT: NCURSES_DOUBLE_CLICKED OCT: 10 +CONSTANT: NCURSES_TRIPLE_CLICKED OCT: 20 +CONSTANT: NCURSES_RESERVED_EVENT OCT: 40 + +FUNCTION: int getmouse ( MEVENT* event ) ; +FUNCTION: int ungetmouse ( MEVENT* event ) ; +FUNCTION: mmask_t mousemask ( mmask_t newmask, mmask_t* oldmask ) ; +FUNCTION: bool wenclose ( WINDOW* win, int y, int x ) ; +FUNCTION: bool mouse_trafo ( int* pY, int* pX, bool to_screen ) ; +FUNCTION: bool wmouse_trafo ( WINDOW* win, int* pY, int* pX, bool to_screen ) ; +FUNCTION: int mouseinterval ( int erval ) ; + +FUNCTION: int wborder ( WINDOW* win, chtype ls, chtype rs, chtype ts, chtype bs, chtype tl, chtype tr, chtype bl, chtype br ) ; +FUNCTION: int box ( WINDOW* win, chtype verch, chtype horch ) ; +FUNCTION: int whline ( WINDOW* win, chtype ch, int n ) ; +FUNCTION: int wvline ( WINDOW* win, chtype ch, int n ) ; diff --git a/extra/curses/listener/authors.txt b/extra/curses/listener/authors.txt new file mode 100644 index 0000000000..4f30515bbb --- /dev/null +++ b/extra/curses/listener/authors.txt @@ -0,0 +1 @@ +Philipp Brüschweiler \ No newline at end of file diff --git a/extra/curses/listener/listener.factor b/extra/curses/listener/listener.factor new file mode 100644 index 0000000000..4505c63cbc --- /dev/null +++ b/extra/curses/listener/listener.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2010 Philipp Brüschweiler. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators continuations curses io io.encodings.string +io.encodings.utf8 io.streams.plain kernel listener make math +namespaces sequences ; +IN: curses.listener + +: print-scratchpad ( -- ) + COLOR_BLACK COLOR_RED ccolor + "( scratchpad )" cwrite + COLOR_WHITE COLOR_BLACK ccolor + " " cwritef ; + +! don't handle mouse clicks right now +: handle-mouse-click ( -- ) + ; + +: delchar ( y x -- ) + [ cmove CHAR: space addch ] [ cmove ] 2bi ; + +: move-left ( -- ) + get-yx [ + [ 1 - get-max-x 1 - delchar ] unless-zero + ] [ 1 - delchar ] if-zero ; + +: handle-backspace ( -- ) + building get [ pop* move-left ] unless-empty ; + +: curses-stream-readln ( -- ) + getch dup CHAR: \n = [ addch ] [ + { + { KEY_MOUSE [ handle-mouse-click ] } + { 127 [ handle-backspace ] } + { 4 [ return ] } ! ^D + [ [ , ] [ addch ] bi ] + } case + curses-stream-readln + ] if ; + +SINGLETON: curses-listener-stream + +M: curses-listener-stream stream-readln + drop [ curses-stream-readln ] B{ } make utf8 decode ; + +M: curses-listener-stream stream-write + drop cwrite ; + +M: curses-listener-stream stream-flush + drop crefresh ; + +M: curses-listener-stream stream-nl + drop cnl ; + +INSTANCE: curses-listener-stream plain-writer + +: run-listener ( -- ) + [ + curses-listener-stream dup [ listener ] with-streams* + ] with-curses ; + +: test-listener ( -- ) + global [ run-listener ] bind ; + +MAIN: run-listener diff --git a/extra/curses/listener/platforms.txt b/extra/curses/listener/platforms.txt new file mode 100644 index 0000000000..509143d863 --- /dev/null +++ b/extra/curses/listener/platforms.txt @@ -0,0 +1 @@ +unix diff --git a/extra/curses/listener/summary.txt b/extra/curses/listener/summary.txt new file mode 100644 index 0000000000..823c7e4311 --- /dev/null +++ b/extra/curses/listener/summary.txt @@ -0,0 +1 @@ +A curses-based Factor listener.