1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.strings assocs byte-arrays
4 classes.struct combinators continuations destructors
5 fry io io.encodings.8-bit io.encodings.string io.encodings.utf8
6 io.streams.c kernel libc locals math memoize multiline
7 namespaces prettyprint sequences strings threads ;
10 QUALIFIED-WITH: curses.ffi ffi
12 SYMBOL: current-window
14 CONSTANT: COLOR_BLACK 0
16 CONSTANT: COLOR_GREEN 2
17 CONSTANT: COLOR_YELLO 3
18 CONSTANT: COLOR_BLUE 4
19 CONSTANT: COLOR_MAGEN 5
20 CONSTANT: COLOR_CYAN 6
21 CONSTANT: COLOR_WHITE 7
24 CONSTANT: A_ATTRIBUTES -256
25 CONSTANT: A_CHARTEXT 255
26 CONSTANT: A_COLOR 65280
27 CONSTANT: A_STANDOUT 65536
28 CONSTANT: A_UNDERLINE 131072
29 CONSTANT: A_REVERSE 262144
30 CONSTANT: A_BLINK 524288
31 CONSTANT: A_DIM 1048576
32 CONSTANT: A_BOLD 2097152
33 CONSTANT: A_ALTCHARSET 4194304
34 CONSTANT: A_INVIS 8388608
35 CONSTANT: A_PROTECT 16777216
36 CONSTANT: A_HORIZONTAL 33554432
37 CONSTANT: A_LEFT 67108864
38 CONSTANT: A_LOW 134217728
39 CONSTANT: A_RIGHT 268435456
40 CONSTANT: A_TOP 536870912
41 CONSTANT: A_VERTICAL 1073741824
43 CONSTANT: KEY_CODE_YES OCT: 400 /* A wchar_t contains a key code */
44 CONSTANT: KEY_MIN OCT: 401 /* Minimum curses key */
45 CONSTANT: KEY_BREAK OCT: 401 /* Break key (unreliable) */
46 CONSTANT: KEY_SRESET OCT: 530 /* Soft (partial) reset (unreliable) */
47 CONSTANT: KEY_RESET OCT: 531 /* Reset or hard reset (unreliable) */
48 CONSTANT: KEY_DOWN OCT: 402 /* down-arrow key */
49 CONSTANT: KEY_UP OCT: 403 /* up-arrow key */
50 CONSTANT: KEY_LEFT OCT: 404 /* left-arrow key */
51 CONSTANT: KEY_RIGHT OCT: 405 /* right-arrow key */
52 CONSTANT: KEY_HOME OCT: 406 /* home key */
53 CONSTANT: KEY_BACKSPACE OCT: 407 /* backspace key */
54 CONSTANT: KEY_DL OCT: 510 /* delete-line key */
55 CONSTANT: KEY_IL OCT: 511 /* insert-line key */
56 CONSTANT: KEY_DC OCT: 512 /* delete-character key */
57 CONSTANT: KEY_IC OCT: 513 /* insert-character key */
58 CONSTANT: KEY_EIC OCT: 514 /* sent by rmir or smir in insert mode */
59 CONSTANT: KEY_CLEAR OCT: 515 /* clear-screen or erase key */
60 CONSTANT: KEY_EOS OCT: 516 /* clear-to-end-of-screen key */
61 CONSTANT: KEY_EOL OCT: 517 /* clear-to-end-of-line key */
62 CONSTANT: KEY_SF OCT: 520 /* scroll-forward key */
63 CONSTANT: KEY_SR OCT: 521 /* scroll-backward key */
64 CONSTANT: KEY_NPAGE OCT: 522 /* next-page key */
65 CONSTANT: KEY_PPAGE OCT: 523 /* previous-page key */
66 CONSTANT: KEY_STAB OCT: 524 /* set-tab key */
67 CONSTANT: KEY_CTAB OCT: 525 /* clear-tab key */
68 CONSTANT: KEY_CATAB OCT: 526 /* clear-all-tabs key */
69 CONSTANT: KEY_ENTER OCT: 527 /* enter/send key */
70 CONSTANT: KEY_PRINT OCT: 532 /* print key */
71 CONSTANT: KEY_LL OCT: 533 /* lower-left key (home down) */
72 CONSTANT: KEY_A1 OCT: 534 /* upper left of keypad */
73 CONSTANT: KEY_A3 OCT: 535 /* upper right of keypad */
74 CONSTANT: KEY_B2 OCT: 536 /* center of keypad */
75 CONSTANT: KEY_C1 OCT: 537 /* lower left of keypad */
76 CONSTANT: KEY_C3 OCT: 540 /* lower right of keypad */
77 CONSTANT: KEY_BTAB OCT: 541 /* back-tab key */
78 CONSTANT: KEY_BEG OCT: 542 /* begin key */
79 CONSTANT: KEY_CANCEL OCT: 543 /* cancel key */
80 CONSTANT: KEY_CLOSE OCT: 544 /* close key */
81 CONSTANT: KEY_COMMAND OCT: 545 /* command key */
82 CONSTANT: KEY_COPY OCT: 546 /* copy key */
83 CONSTANT: KEY_CREATE OCT: 547 /* create key */
84 CONSTANT: KEY_END OCT: 550 /* end key */
85 CONSTANT: KEY_EXIT OCT: 551 /* exit key */
86 CONSTANT: KEY_FIND OCT: 552 /* find key */
87 CONSTANT: KEY_HELP OCT: 553 /* help key */
88 CONSTANT: KEY_MARK OCT: 554 /* mark key */
89 CONSTANT: KEY_MESSAGE OCT: 555 /* message key */
90 CONSTANT: KEY_MOVE OCT: 556 /* move key */
91 CONSTANT: KEY_NEXT OCT: 557 /* next key */
92 CONSTANT: KEY_OPEN OCT: 560 /* open key */
93 CONSTANT: KEY_OPTIONS OCT: 561 /* options key */
94 CONSTANT: KEY_PREVIOUS OCT: 562 /* previous key */
95 CONSTANT: KEY_REDO OCT: 563 /* redo key */
96 CONSTANT: KEY_REFERENCE OCT: 564 /* reference key */
97 CONSTANT: KEY_REFRESH OCT: 565 /* refresh key */
98 CONSTANT: KEY_REPLACE OCT: 566 /* replace key */
99 CONSTANT: KEY_RESTART OCT: 567 /* restart key */
100 CONSTANT: KEY_RESUME OCT: 570 /* resume key */
101 CONSTANT: KEY_SAVE OCT: 571 /* save key */
102 CONSTANT: KEY_SBEG OCT: 572 /* shifted begin key */
103 CONSTANT: KEY_SCANCEL OCT: 573 /* shifted cancel key */
104 CONSTANT: KEY_SCOMMAND OCT: 574 /* shifted command key */
105 CONSTANT: KEY_SCOPY OCT: 575 /* shifted copy key */
106 CONSTANT: KEY_SCREATE OCT: 576 /* shifted create key */
107 CONSTANT: KEY_SDC OCT: 577 /* shifted delete-character key */
108 CONSTANT: KEY_SDL OCT: 600 /* shifted delete-line key */
109 CONSTANT: KEY_SELECT OCT: 601 /* select key */
110 CONSTANT: KEY_SEND OCT: 602 /* shifted end key */
111 CONSTANT: KEY_SEOL OCT: 603 /* shifted clear-to-end-of-line key */
112 CONSTANT: KEY_SEXIT OCT: 604 /* shifted exit key */
113 CONSTANT: KEY_SFIND OCT: 605 /* shifted find key */
114 CONSTANT: KEY_SHELP OCT: 606 /* shifted help key */
115 CONSTANT: KEY_SHOME OCT: 607 /* shifted home key */
116 CONSTANT: KEY_SIC OCT: 610 /* shifted insert-character key */
117 CONSTANT: KEY_SLEFT OCT: 611 /* shifted left-arrow key */
118 CONSTANT: KEY_SMESSAGE OCT: 612 /* shifted message key */
119 CONSTANT: KEY_SMOVE OCT: 613 /* shifted move key */
120 CONSTANT: KEY_SNEXT OCT: 614 /* shifted next key */
121 CONSTANT: KEY_SOPTIONS OCT: 615 /* shifted options key */
122 CONSTANT: KEY_SPREVIOUS OCT: 616 /* shifted previous key */
123 CONSTANT: KEY_SPRINT OCT: 617 /* shifted print key */
124 CONSTANT: KEY_SREDO OCT: 620 /* shifted redo key */
125 CONSTANT: KEY_SREPLACE OCT: 621 /* shifted replace key */
126 CONSTANT: KEY_SRIGHT OCT: 622 /* shifted right-arrow key */
127 CONSTANT: KEY_SRSUME OCT: 623 /* shifted resume key */
128 CONSTANT: KEY_SSAVE OCT: 624 /* shifted save key */
129 CONSTANT: KEY_SSUSPEND OCT: 625 /* shifted suspend key */
130 CONSTANT: KEY_SUNDO OCT: 626 /* shifted undo key */
131 CONSTANT: KEY_SUSPEND OCT: 627 /* suspend key */
132 CONSTANT: KEY_UNDO OCT: 630 /* undo key */
133 CONSTANT: KEY_MOUSE OCT: 631 /* Mouse event has occurred */
134 CONSTANT: KEY_RESIZE OCT: 632 /* Terminal resize event */
135 CONSTANT: KEY_EVENT OCT: 633 /* We were interrupted by an event */
136 CONSTANT: KEY_F0 OCT: 410 /* Function keys. Space for 64 */
137 : KEY_F ( n -- code ) KEY_F0 + ; inline /* Value of function key n */
139 : BUTTON1_RELEASED ( -- mask ) 1 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
140 : BUTTON1_PRESSED ( -- mask ) 1 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline
141 : BUTTON1_CLICKED ( -- mask ) 1 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
142 : BUTTON1_DOUBLE_CLICKED ( -- mask ) 1 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
143 : BUTTON1_TRIPLE_CLICKED ( -- mask ) 1 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
144 : BUTTON2_RELEASED ( -- mask ) 2 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
145 : BUTTON2_PRESSED ( -- mask ) 2 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline
146 : BUTTON2_CLICKED ( -- mask ) 2 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
147 : BUTTON2_DOUBLE_CLICKED ( -- mask ) 2 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
148 : BUTTON2_TRIPLE_CLICKED ( -- mask ) 2 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
149 : BUTTON3_RELEASED ( -- mask ) 3 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
150 : BUTTON3_PRESSED ( -- mask ) 3 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline
151 : BUTTON3_CLICKED ( -- mask ) 3 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
152 : BUTTON3_DOUBLE_CLICKED ( -- mask ) 3 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
153 : BUTTON3_TRIPLE_CLICKED ( -- mask ) 3 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
154 : BUTTON4_RELEASED ( -- mask ) 4 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
155 : BUTTON4_PRESSED ( -- mask ) 4 ffi:NCURSES_BUTTON_PRESSED ffi:NCURSES_MOUSE_MASK ; inline
156 : BUTTON4_CLICKED ( -- mask ) 4 ffi:NCURSES_BUTTON_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
157 : BUTTON4_DOUBLE_CLICKED ( -- mask ) 4 ffi:NCURSES_DOUBLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
158 : BUTTON4_TRIPLE_CLICKED ( -- mask ) 4 ffi:NCURSES_TRIPLE_CLICKED ffi:NCURSES_MOUSE_MASK ; inline
160 : BUTTON1_RESERVED_EVENT ( -- mask ) 1 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline
161 : BUTTON2_RESERVED_EVENT ( -- mask ) 2 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline
162 : BUTTON3_RESERVED_EVENT ( -- mask ) 3 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline
163 : BUTTON4_RESERVED_EVENT ( -- mask ) 4 ffi:NCURSES_RESERVED_EVENT ffi:NCURSES_MOUSE_MASK ; inline
164 : BUTTON_CTRL ( -- mask ) 5 OCT: 01 ffi:NCURSES_MOUSE_MASK ; inline
165 : BUTTON_SHIFT ( -- mask ) 5 OCT: 02 ffi:NCURSES_MOUSE_MASK ; inline
166 : BUTTON_ALT ( -- mask ) 5 OCT: 04 ffi:NCURSES_MOUSE_MASK ; inline
167 : REPORT_MOUSE_POSITION ( -- mask ) 5 OCT: 10 ffi:NCURSES_MOUSE_MASK ; inline
169 : ALL_MOUSE_EVENTS ( -- mask ) REPORT_MOUSE_POSITION 1 - ; inline
171 ERROR: curses-failed ;
172 ERROR: unsupported-curses-terminal ;
176 : >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
178 : curses-pointer-error ( ptr/f -- ptr )
179 dup [ curses-failed ] unless ; inline
180 : curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
184 : curses-ok? ( -- ? )
185 { 0 1 2 } [ isatty 0 = not ] all? ;
187 TUPLE: curses-window < disposable
190 { lines integer initial: 0 }
191 { columns integer initial: 0 }
192 { y integer initial: 0 }
193 { x integer initial: 0 }
195 { cbreak initial: t }
199 { scrollok initial: t }
200 { leaveok initial: f }
203 { keypad initial: t }
205 { encoding initial: utf8 } ;
207 : <curses-window> ( -- window )
208 curses-window new-disposable ;
210 M: curses-window dispose* ( window -- )
211 ptr>> ffi:delwin curses-error ;
215 : window-params ( window -- lines columns y x )
216 { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
218 : set-cbreak/raw ( cbreak raw -- )
220 [ ffi:cbreak ] [ ffi:nocbreak ] if
223 : apply-window-options ( window -- )
225 [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi ffi:scrollok curses-error ]
226 [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi ffi:leaveok curses-error ]
227 [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi ffi:keypad curses-error ]
230 : apply-global-options ( window -- )
231 [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
232 [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ]
235 SYMBOL: n-registered-colors
237 MEMO: register-color ( fg bg -- n )
238 [ n-registered-colors get ] 2dip ffi:init_pair curses-error
239 n-registered-colors [ get ] [ inc ] bi ;
243 1 n-registered-colors set
244 \ register-color reset-memoized
245 ffi:start_color curses-error
250 : setup-window ( window -- window )
253 dup parent-window>> [
254 ptr>> swap window-params ffi:derwin
256 window-params ffi:newwin
257 ] if* curses-pointer-error >>ptr &dispose
258 ] [ apply-window-options ] bi ;
260 : with-window ( window quot -- )
261 [ current-window ] dip with-variable ; inline
263 : with-curses ( window quot -- )
264 curses-ok? [ unsupported-curses-terminal ] unless
267 ffi:initscr curses-pointer-error
270 [ apply-global-options ]
271 [ apply-window-options ]
272 [ ptr>> ffi:wclear curses-error ]
273 [ ptr>> ffi:wrefresh curses-error ]
279 ] [ ffi:endwin curses-error ] [ ] cleanup
280 ] with-destructors ; inline
282 TUPLE: curses-terminal < disposable
285 : <curses-terminal> ( infd outfd ptr -- curses-terminal )
286 curses-terminal new-disposable
291 M: curses-terminal dispose
292 [ outfd>> fclose ] [ infd>> fclose ]
293 [ ptr>> ffi:delscreen ] tri ;
295 : init-terminal ( terminal -- curses-terminal )
296 "xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi
297 [ ffi:newterm curses-pointer-error ] 2keep <curses-terminal> ;
299 : start-remote-curses ( terminal window -- curses-terminal )
302 ffi:initscr curses-pointer-error drop
303 dup ptr>> ffi:set_term curses-pointer-error drop
304 ] dip [ apply-global-options ] [ apply-window-options ] bi ;
308 : (wcrefresh) ( window-ptr -- ) ffi:wrefresh curses-error ; inline
309 : (wcwrite) ( string window-ptr -- ) swap ffi:waddstr curses-error ; inline
311 :: (wcread) ( n encoding window-ptr -- string )
313 n 1 + malloc &free :> str
314 window-ptr str n ffi:wgetnstr curses-error
315 str encoding alien>string
316 ] with-destructors ; inline
318 : (wcmove) ( y x window-ptr -- )
319 -rot ffi:wmove curses-error ; inline
321 : (winsert-blank-line) ( y window-ptr -- )
323 [ ffi:winsertln curses-error ] bi ; inline
325 : (waddch) ( ch window-ptr -- )
326 swap ffi:waddch curses-error ; inline
328 : (wgetch) ( window -- key )
329 ffi:wgetch [ curses-error ] keep ; inline
331 : (wattroff) ( attribute window-ptr -- )
332 swap ffi:wattroff curses-error ; inline
334 : (wattron) ( attribute window-ptr -- )
335 swap ffi:wattron curses-error ; inline
339 : wcrefresh ( window -- ) ptr>> (wcrefresh) ;
340 : crefresh ( -- ) current-window get wcrefresh ;
342 : wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
343 : cnl ( -- ) current-window get wcnl ;
345 : wcwrite ( string window -- ) ptr>> (wcwrite) ;
346 : cwrite ( string -- ) current-window get wcwrite ;
348 : wcprint ( string window -- )
349 ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
350 : cprint ( string -- ) current-window get wcprint ;
352 : wcprintf ( string window -- )
353 ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
354 [ (wcrefresh) ] tri ;
355 : cprintf ( string -- ) current-window get wcprintf ;
357 : wcwritef ( string window -- )
358 ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
359 : cwritef ( string -- ) current-window get wcwritef ;
361 : wcread ( n window -- string )
362 [ encoding>> ] [ ptr>> ] bi (wcread) ;
363 : curses-read ( n -- string ) current-window get wcread ;
365 : wgetch ( window -- key ) ptr>> (wgetch) ;
366 : getch ( -- key ) current-window get wgetch ;
368 : waddch ( ch window -- ) ptr>> (waddch) ;
369 : addch ( ch -- ) current-window get waddch ;
371 : werase ( window -- ) ptr>> ffi:werase curses-error ;
372 : erase ( -- ) current-window get werase ;
374 : wcmove ( y x window -- )
375 ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
376 : cmove ( y x -- ) current-window get wcmove ;
378 : wdelete-line ( y window -- )
379 ptr>> [ 0 swap (wcmove) ] [ ffi:wdeleteln curses-error ] bi ;
380 : delete-line ( y -- ) current-window get wdelete-line ;
382 : winsert-blank-line ( y window -- )
383 ptr>> (winsert-blank-line) ;
384 : insert-blank-line ( y -- )
385 current-window get winsert-blank-line ;
387 : winsert-line ( string y window -- )
388 ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
389 : insert-line ( string y -- )
390 current-window get winsert-line ;
392 : wattron ( attribute window -- ) ptr>> (wattron) ;
393 : attron ( attribute -- ) current-window get wattron ;
395 : wattroff ( attribute window -- ) ptr>> (wattroff) ;
396 : attroff ( attribute -- ) current-window get wattroff ;
398 : wall-attroff ( window -- ) [ A_NORMAL ] dip wattroff ;
399 : all-attroff ( -- ) current-window get wall-attroff ;
401 : wccolor ( foreground background window -- )
403 2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
404 [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
405 ] dip ptr>> (wattron) ;
407 : ccolor ( foreground background -- )
408 current-window get wccolor ;
410 : wccbox ( window -- )
411 ptr>> 0 0 ffi:box curses-error ;
413 current-window get wccbox ;
415 : mousemask ( mask -- newmask oldmask )
416 0 <ulong> [ ffi:mousemask ] keep *ulong ;
418 : getmouse ( -- MEVENT/f )
419 ffi:MEVENT <struct> dup ffi:getmouse
420 ffi:ERR = [ drop f ] when ;