extra/curses/curses.factor

   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 ;
   8 IN: curses
   9
  10 QUALIFIED-WITH: curses.ffi ffi
  11
  12 SYMBOL: current-window
  13
  14 CONSTANT: COLOR_BLACK 0
  15 CONSTANT: COLOR_RED   1
  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
  22
  23 CONSTANT: A_NORMAL      0
  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
  42
  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 */
 138
 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
 159
 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
 168
 169 : ALL_MOUSE_EVENTS ( -- mask ) REPORT_MOUSE_POSITION 1 - ; inline
 170
 171 ERROR: curses-failed ;
 172 ERROR: unsupported-curses-terminal ;
 173
 174 <PRIVATE
 175
 176 : >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
 177
 178 : curses-pointer-error ( ptr/f -- ptr )
 179     dup [ curses-failed ] unless ; inline
 180 : curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
 181
 182 PRIVATE>
 183
 184 : curses-ok? ( -- ? )
 185     { 0 1 2 } [ isatty 0 = not ] all? ;
 186
 187 TUPLE: curses-window < disposable
 188     ptr
 189     parent-window
 190     { lines integer initial: 0 }
 191     { columns integer initial: 0 }
 192     { y integer initial: 0 }
 193     { x integer initial: 0 }
 194
 195     { cbreak initial: t }
 196     { echo initial: f }
 197     { raw initial: f }
 198
 199     { scrollok initial: t }
 200     { leaveok initial: f }
 201
 202     idcok idlok immedok
 203     { keypad initial: t }
 204
 205     { encoding initial: utf8 } ;
 206
 207 : <curses-window> ( -- window )
 208     curses-window new-disposable ;
 209
 210 M: curses-window dispose* ( window -- )
 211     ptr>> ffi:delwin curses-error ;
 212
 213 <PRIVATE
 214
 215 : window-params ( window -- lines columns y x )
 216     { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
 217
 218 : set-cbreak/raw ( cbreak raw -- )
 219     [ drop ffi:raw ] [
 220         [ ffi:cbreak ] [ ffi:nocbreak ] if
 221     ] if curses-error ;
 222
 223 : apply-window-options ( window -- )
 224     {
 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 ]
 228     } cleave ;
 229
 230 : apply-global-options ( window -- )
 231     [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
 232     [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ]
 233     bi ;
 234
 235 SYMBOL: n-registered-colors
 236
 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 ;
 240
 241 : init-colors ( -- )
 242     ffi:has_colors [
 243         1 n-registered-colors set
 244         \ register-color reset-memoized
 245         ffi:start_color curses-error
 246     ] when ;
 247
 248 PRIVATE>
 249
 250 : setup-window ( window -- window )
 251     [
 252         dup
 253         dup parent-window>> [
 254             ptr>> swap window-params ffi:derwin
 255         ] [
 256             window-params ffi:newwin
 257         ] if* [ curses-error ] keep >>ptr &dispose
 258     ] [ apply-window-options ] bi ;
 259
 260 : with-window ( window quot -- )
 261     [ current-window ] dip with-variable ; inline
 262
 263 : with-curses ( window quot -- )
 264     curses-ok? [ unsupported-curses-terminal ] unless
 265     [
 266         '[
 267             ffi:initscr curses-pointer-error
 268             >>ptr
 269             [ apply-global-options ] [ apply-window-options ] [ ] tri
 270
 271             ffi:erase curses-error
 272             init-colors
 273
 274             _ with-window
 275         ] [ ffi:endwin curses-error ] [ ] cleanup
 276     ] with-destructors ; inline
 277
 278 TUPLE: curses-terminal < disposable
 279     infd outfd ptr ;
 280
 281 : <curses-terminal> ( infd outfd ptr -- curses-terminal )
 282     curses-terminal new-disposable
 283         swap >>ptr
 284         swap >>outfd
 285         swap >>infd ;
 286
 287 M: curses-terminal dispose
 288     [ outfd>> fclose ] [ infd>> fclose ]
 289     [ ptr>> ffi:delscreen ] tri ;
 290
 291 : init-terminal ( terminal -- curses-terminal )
 292     "xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi
 293     [ ffi:newterm curses-pointer-error ] 2keep <curses-terminal> ;
 294
 295 : start-remote-curses ( terminal window -- curses-terminal )
 296     [
 297         init-terminal
 298         ffi:initscr curses-pointer-error drop
 299         dup ptr>> ffi:set_term curses-pointer-error drop
 300     ] dip [ apply-global-options ] [ apply-window-options ] bi ;
 301
 302 <PRIVATE
 303
 304 : (wcrefresh) ( window-ptr -- ) ffi:wrefresh curses-error ; inline
 305 : (wcwrite) ( string window-ptr -- ) swap ffi:waddstr curses-error ; inline
 306
 307 :: (wcread) ( n encoding window-ptr -- string )
 308     [
 309         n 1 + malloc &free :> str
 310         window-ptr str n ffi:wgetnstr curses-error
 311         str encoding alien>string
 312     ] with-destructors ; inline
 313
 314 : (wcmove) ( y x window-ptr -- )
 315     -rot ffi:wmove curses-error ; inline
 316
 317 : (winsert-blank-line) ( y window-ptr -- )
 318     [ 0 swap (wcmove) ]
 319     [ ffi:winsertln curses-error ] bi ; inline
 320
 321 : (waddch) ( ch window-ptr -- )
 322     swap ffi:waddch curses-error ; inline
 323
 324 : (wgetch) ( window -- key )
 325     ffi:wgetch [ curses-error ] keep ; inline
 326
 327 : (wattroff) ( attribute window-ptr -- )
 328     swap ffi:wattroff curses-error ; inline
 329
 330 : (wattron) ( attribute window-ptr -- )
 331     swap ffi:wattron curses-error ; inline
 332
 333 PRIVATE>
 334
 335 : wcrefresh ( window -- ) ptr>> (wcrefresh) ;
 336 : crefresh ( -- ) current-window get wcrefresh ;
 337
 338 : wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
 339 : cnl ( -- ) current-window get wcnl ;
 340
 341 : wcwrite ( string window -- ) ptr>> (wcwrite) ;
 342 : cwrite ( string -- ) current-window get wcwrite ;
 343
 344 : wcprint ( string window -- )
 345     ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
 346 : cprint ( string -- ) current-window get wcprint ;
 347
 348 : wcprintf ( string window -- )
 349     ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
 350     [ (wcrefresh) ] tri ;
 351 : cprintf ( string -- ) current-window get wcprintf ;
 352
 353 : wcwritef ( string window -- )
 354     ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
 355 : cwritef ( string -- ) current-window get wcwritef ;
 356
 357 : wcread ( n window -- string )
 358     [ encoding>> ] [ ptr>> ] bi (wcread) ;
 359 : curses-read ( n -- string ) current-window get wcread ;
 360
 361 : wgetch ( window -- key ) ptr>> (wgetch) ;
 362 : getch ( -- key ) current-window get wgetch ;
 363
 364 : waddch ( ch window -- ) ptr>> (waddch) ;
 365 : addch ( ch -- ) current-window get waddch ;
 366
 367 : werase ( window -- ) ptr>> ffi:werase curses-error ;
 368 : erase ( -- ) current-window get werase ;
 369
 370 : wcmove ( y x window -- )
 371     ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
 372 : cmove ( y x -- ) current-window get wcmove ;
 373
 374 : wdelete-line ( y window -- )
 375     ptr>> [ 0 swap (wcmove) ] [ ffi:wdeleteln curses-error ] bi ;
 376 : delete-line ( y -- ) current-window get wdelete-line ;
 377
 378 : winsert-blank-line ( y window -- )
 379     ptr>> (winsert-blank-line) ;
 380 : insert-blank-line ( y -- )
 381     current-window get winsert-blank-line ;
 382
 383 : winsert-line ( string y window -- )
 384     ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
 385 : insert-line ( string y -- )
 386     current-window get winsert-line ;
 387
 388 : wattron ( attribute window -- ) ptr>> (wattron) ;
 389 : attron ( attribute -- ) current-window get wattron ;
 390
 391 : wattroff ( attribute window -- ) ptr>> (wattroff) ;
 392 : attroff ( attribute -- ) current-window get wattroff ;
 393
 394 : wall-attroff ( window -- ) [ A_NORMAL ] dip wattroff ;
 395 : all-attroff ( -- ) current-window get wall-attroff ;
 396
 397 : wccolor ( foreground background window -- )
 398     [
 399         2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
 400         [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
 401     ] dip ptr>> (wattron) ;
 402
 403 : ccolor ( foreground background -- )
 404     current-window get wccolor ;