extra/curses/curses.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors alien.c-types alien.data alien.strings
   5 classes.struct combinators continuations destructors fry
   6 io.encodings.utf8 kernel libc locals math memoize multiline
   7 namespaces sequences unix.ffi ;
   8
   9 QUALIFIED-WITH: curses.ffi ffi
  10
  11 IN: curses
  12
  13 SYMBOL: current-window
  14
  15 CONSTANT: COLOR_BLACK   0
  16 CONSTANT: COLOR_RED     1
  17 CONSTANT: COLOR_GREEN   2
  18 CONSTANT: COLOR_YELLOW  3
  19 CONSTANT: COLOR_BLUE    4
  20 CONSTANT: COLOR_MAGENTA 5
  21 CONSTANT: COLOR_CYAN    6
  22 CONSTANT: COLOR_WHITE   7
  23
  24 CONSTANT: A_NORMAL      0
  25 CONSTANT: A_ATTRIBUTES  -256
  26 CONSTANT: A_CHARTEXT    255
  27 CONSTANT: A_COLOR       65280
  28 CONSTANT: A_STANDOUT    65536
  29 CONSTANT: A_UNDERLINE   131072
  30 CONSTANT: A_REVERSE     262144
  31 CONSTANT: A_BLINK       524288
  32 CONSTANT: A_DIM         1048576
  33 CONSTANT: A_BOLD        2097152
  34 CONSTANT: A_ALTCHARSET  4194304
  35 CONSTANT: A_INVIS       8388608
  36 CONSTANT: A_PROTECT     16777216
  37 CONSTANT: A_HORIZONTAL  33554432
  38 CONSTANT: A_LEFT        67108864
  39 CONSTANT: A_LOW         134217728
  40 CONSTANT: A_RIGHT       268435456
  41 CONSTANT: A_TOP         536870912
  42 CONSTANT: A_VERTICAL    1073741824
  43 CONSTANT: A_ITALIC      2147483648
  44
  45 CONSTANT: KEY_CODE_YES  0o400  /* A wchar_t contains a key code */
  46 CONSTANT: KEY_MIN       0o401  /* Minimum curses key */
  47 CONSTANT: KEY_BREAK     0o401  /* Break key (unreliable) */
  48 CONSTANT: KEY_SRESET    0o530  /* Soft (partial) reset (unreliable) */
  49 CONSTANT: KEY_RESET     0o531  /* Reset or hard reset (unreliable) */
  50 CONSTANT: KEY_DOWN      0o402  /* down-arrow key */
  51 CONSTANT: KEY_UP        0o403  /* up-arrow key */
  52 CONSTANT: KEY_LEFT      0o404  /* left-arrow key */
  53 CONSTANT: KEY_RIGHT     0o405  /* right-arrow key */
  54 CONSTANT: KEY_HOME      0o406  /* home key */
  55 CONSTANT: KEY_BACKSPACE 0o407  /* backspace key */
  56 CONSTANT: KEY_DL        0o510  /* delete-line key */
  57 CONSTANT: KEY_IL        0o511  /* insert-line key */
  58 CONSTANT: KEY_DC        0o512  /* delete-character key */
  59 CONSTANT: KEY_IC        0o513  /* insert-character key */
  60 CONSTANT: KEY_EIC       0o514  /* sent by rmir or smir in insert mode */
  61 CONSTANT: KEY_CLEAR     0o515  /* clear-screen or erase key */
  62 CONSTANT: KEY_EOS       0o516  /* clear-to-end-of-screen key */
  63 CONSTANT: KEY_EOL       0o517  /* clear-to-end-of-line key */
  64 CONSTANT: KEY_SF        0o520  /* scroll-forward key */
  65 CONSTANT: KEY_SR        0o521  /* scroll-backward key */
  66 CONSTANT: KEY_NPAGE     0o522  /* next-page key */
  67 CONSTANT: KEY_PPAGE     0o523  /* previous-page key */
  68 CONSTANT: KEY_STAB      0o524  /* set-tab key */
  69 CONSTANT: KEY_CTAB      0o525  /* clear-tab key */
  70 CONSTANT: KEY_CATAB     0o526  /* clear-all-tabs key */
  71 CONSTANT: KEY_ENTER     0o527  /* enter/send key */
  72 CONSTANT: KEY_PRINT     0o532  /* print key */
  73 CONSTANT: KEY_LL        0o533  /* lower-left key (home down) */
  74 CONSTANT: KEY_A1        0o534  /* upper left of keypad */
  75 CONSTANT: KEY_A3        0o535  /* upper right of keypad */
  76 CONSTANT: KEY_B2        0o536  /* center of keypad */
  77 CONSTANT: KEY_C1        0o537  /* lower left of keypad */
  78 CONSTANT: KEY_C3        0o540  /* lower right of keypad */
  79 CONSTANT: KEY_BTAB      0o541  /* back-tab key */
  80 CONSTANT: KEY_BEG       0o542  /* begin key */
  81 CONSTANT: KEY_CANCEL    0o543  /* cancel key */
  82 CONSTANT: KEY_CLOSE     0o544  /* close key */
  83 CONSTANT: KEY_COMMAND   0o545  /* command key */
  84 CONSTANT: KEY_COPY      0o546  /* copy key */
  85 CONSTANT: KEY_CREATE    0o547  /* create key */
  86 CONSTANT: KEY_END       0o550  /* end key */
  87 CONSTANT: KEY_EXIT      0o551  /* exit key */
  88 CONSTANT: KEY_FIND      0o552  /* find key */
  89 CONSTANT: KEY_HELP      0o553  /* help key */
  90 CONSTANT: KEY_MARK      0o554  /* mark key */
  91 CONSTANT: KEY_MESSAGE   0o555  /* message key */
  92 CONSTANT: KEY_MOVE      0o556  /* move key */
  93 CONSTANT: KEY_NEXT      0o557  /* next key */
  94 CONSTANT: KEY_OPEN      0o560  /* open key */
  95 CONSTANT: KEY_OPTIONS   0o561  /* options key */
  96 CONSTANT: KEY_PREVIOUS  0o562  /* previous key */
  97 CONSTANT: KEY_REDO      0o563  /* redo key */
  98 CONSTANT: KEY_REFERENCE 0o564  /* reference key */
  99 CONSTANT: KEY_REFRESH   0o565  /* refresh key */
 100 CONSTANT: KEY_REPLACE   0o566  /* replace key */
 101 CONSTANT: KEY_RESTART   0o567  /* restart key */
 102 CONSTANT: KEY_RESUME    0o570  /* resume key */
 103 CONSTANT: KEY_SAVE      0o571  /* save key */
 104 CONSTANT: KEY_SBEG      0o572  /* shifted begin key */
 105 CONSTANT: KEY_SCANCEL   0o573  /* shifted cancel key */
 106 CONSTANT: KEY_SCOMMAND  0o574  /* shifted command key */
 107 CONSTANT: KEY_SCOPY     0o575  /* shifted copy key */
 108 CONSTANT: KEY_SCREATE   0o576  /* shifted create key */
 109 CONSTANT: KEY_SDC       0o577  /* shifted delete-character key */
 110 CONSTANT: KEY_SDL       0o600  /* shifted delete-line key */
 111 CONSTANT: KEY_SELECT    0o601  /* select key */
 112 CONSTANT: KEY_SEND      0o602  /* shifted end key */
 113 CONSTANT: KEY_SEOL      0o603  /* shifted clear-to-end-of-line key */
 114 CONSTANT: KEY_SEXIT     0o604  /* shifted exit key */
 115 CONSTANT: KEY_SFIND     0o605  /* shifted find key */
 116 CONSTANT: KEY_SHELP     0o606  /* shifted help key */
 117 CONSTANT: KEY_SHOME     0o607  /* shifted home key */
 118 CONSTANT: KEY_SIC       0o610  /* shifted insert-character key */
 119 CONSTANT: KEY_SLEFT     0o611  /* shifted left-arrow key */
 120 CONSTANT: KEY_SMESSAGE  0o612  /* shifted message key */
 121 CONSTANT: KEY_SMOVE     0o613  /* shifted move key */
 122 CONSTANT: KEY_SNEXT     0o614  /* shifted next key */
 123 CONSTANT: KEY_SOPTIONS  0o615  /* shifted options key */
 124 CONSTANT: KEY_SPREVIOUS 0o616  /* shifted previous key */
 125 CONSTANT: KEY_SPRINT    0o617  /* shifted print key */
 126 CONSTANT: KEY_SREDO     0o620  /* shifted redo key */
 127 CONSTANT: KEY_SREPLACE  0o621  /* shifted replace key */
 128 CONSTANT: KEY_SRIGHT    0o622  /* shifted right-arrow key */
 129 CONSTANT: KEY_SRSUME    0o623  /* shifted resume key */
 130 CONSTANT: KEY_SSAVE     0o624  /* shifted save key */
 131 CONSTANT: KEY_SSUSPEND  0o625  /* shifted suspend key */
 132 CONSTANT: KEY_SUNDO     0o626  /* shifted undo key */
 133 CONSTANT: KEY_SUSPEND   0o627  /* suspend key */
 134 CONSTANT: KEY_UNDO      0o630  /* undo key */
 135 CONSTANT: KEY_MOUSE     0o631  /* Mouse event has occurred */
 136 CONSTANT: KEY_RESIZE    0o632  /* Terminal resize event */
 137 CONSTANT: KEY_EVENT     0o633  /* We were interrupted by an event */
 138 CONSTANT: KEY_MAX       0o777  /* Maximum key value is 0633 */
 139 CONSTANT: KEY_F0        0o410  /* Function keys.  Space for 64 */
 140 : KEY_F ( n -- code ) KEY_F0 + ; inline /* Value of function key n */
 141
 142 : BUTTON1_RELEASED       ( -- mask ) 1 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
 143 : BUTTON1_PRESSED        ( -- mask ) 1 ffi:NCURSES_BUTTON_PRESSED  ffi:NCURSES_MOUSE_MASK ; inline
 144 : BUTTON1_CLICKED        ( -- mask ) 1 ffi:NCURSES_BUTTON_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 145 : BUTTON1_DOUBLE_CLICKED ( -- mask ) 1 ffi:NCURSES_DOUBLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 146 : BUTTON1_TRIPLE_CLICKED ( -- mask ) 1 ffi:NCURSES_TRIPLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 147 : BUTTON2_RELEASED       ( -- mask ) 2 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
 148 : BUTTON2_PRESSED        ( -- mask ) 2 ffi:NCURSES_BUTTON_PRESSED  ffi:NCURSES_MOUSE_MASK ; inline
 149 : BUTTON2_CLICKED        ( -- mask ) 2 ffi:NCURSES_BUTTON_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 150 : BUTTON2_DOUBLE_CLICKED ( -- mask ) 2 ffi:NCURSES_DOUBLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 151 : BUTTON2_TRIPLE_CLICKED ( -- mask ) 2 ffi:NCURSES_TRIPLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 152 : BUTTON3_RELEASED       ( -- mask ) 3 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
 153 : BUTTON3_PRESSED        ( -- mask ) 3 ffi:NCURSES_BUTTON_PRESSED  ffi:NCURSES_MOUSE_MASK ; inline
 154 : BUTTON3_CLICKED        ( -- mask ) 3 ffi:NCURSES_BUTTON_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 155 : BUTTON3_DOUBLE_CLICKED ( -- mask ) 3 ffi:NCURSES_DOUBLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 156 : BUTTON3_TRIPLE_CLICKED ( -- mask ) 3 ffi:NCURSES_TRIPLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 157 : BUTTON4_RELEASED       ( -- mask ) 4 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
 158 : BUTTON4_PRESSED        ( -- mask ) 4 ffi:NCURSES_BUTTON_PRESSED  ffi:NCURSES_MOUSE_MASK ; inline
 159 : BUTTON4_CLICKED        ( -- mask ) 4 ffi:NCURSES_BUTTON_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 160 : BUTTON4_DOUBLE_CLICKED ( -- mask ) 4 ffi:NCURSES_DOUBLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 161 : BUTTON4_TRIPLE_CLICKED ( -- mask ) 4 ffi:NCURSES_TRIPLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 162 : BUTTON5_RELEASED       ( -- mask ) 5 ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK ; inline
 163 : BUTTON5_PRESSED        ( -- mask ) 5 ffi:NCURSES_BUTTON_PRESSED  ffi:NCURSES_MOUSE_MASK ; inline
 164 : BUTTON5_CLICKED        ( -- mask ) 5 ffi:NCURSES_BUTTON_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 165 : BUTTON5_DOUBLE_CLICKED ( -- mask ) 5 ffi:NCURSES_DOUBLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 166 : BUTTON5_TRIPLE_CLICKED ( -- mask ) 5 ffi:NCURSES_TRIPLE_CLICKED  ffi:NCURSES_MOUSE_MASK ; inline
 167
 168 : BUTTON_CTRL            ( -- mask ) 5 0o01 ffi:NCURSES_MOUSE_MASK ; inline
 169 : BUTTON_SHIFT           ( -- mask ) 5 0o02 ffi:NCURSES_MOUSE_MASK ; inline
 170 : BUTTON_ALT             ( -- mask ) 5 0o04 ffi:NCURSES_MOUSE_MASK ; inline
 171 : REPORT_MOUSE_POSITION  ( -- mask ) 5 0o10 ffi:NCURSES_MOUSE_MASK ; inline
 172
 173 : ALL_MOUSE_EVENTS ( -- mask ) REPORT_MOUSE_POSITION 1 - ; inline
 174
 175 ERROR: curses-failed ;
 176 ERROR: unsupported-curses-terminal ;
 177
 178 <PRIVATE
 179
 180 : >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
 181
 182 : curses-pointer-error ( ptr/f -- ptr )
 183     [ curses-failed ] unless* ; inline
 184 : curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
 185
 186 PRIVATE>
 187
 188 : curses-ok? ( -- ? )
 189     { 0 1 2 } [ isatty 0 = not ] all? ;
 190
 191 TUPLE: curses-window < disposable
 192     ptr
 193     parent-window
 194     { lines integer initial: 0 }
 195     { columns integer initial: 0 }
 196     { y integer initial: 0 }
 197     { x integer initial: 0 }
 198
 199     { cbreak initial: t }
 200     { echo initial: f }
 201     { raw initial: f }
 202
 203     { scrollok initial: t }
 204     { leaveok initial: f }
 205
 206     idcok idlok immedok
 207     { keypad initial: t }
 208     { nodelay initial: f }
 209
 210     { encoding initial: utf8 } ;
 211
 212 : <curses-window> ( -- window )
 213     curses-window new-disposable ;
 214
 215 M: curses-window dispose* ( window -- )
 216     ptr>> ffi:delwin curses-error ;
 217
 218 <PRIVATE
 219
 220 : window-params ( window -- lines columns y x )
 221     { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
 222
 223 : set-cbreak/raw ( cbreak raw -- )
 224     [ drop ffi:raw ] [
 225         [ ffi:cbreak ] [ ffi:nocbreak ] if
 226     ] if curses-error ;
 227
 228 : apply-window-options ( window -- )
 229     {
 230         [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi ffi:scrollok curses-error ]
 231         [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi ffi:leaveok curses-error ]
 232         [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi ffi:keypad curses-error ]
 233         [ [ ptr>> ] [ nodelay>> ] bi [ ffi:TRUE ffi:nodelay
 234         curses-error ] [ drop ] if ]
 235     } cleave ;
 236
 237 : apply-global-options ( window -- )
 238     [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
 239     [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ]
 240     bi ;
 241
 242 SYMBOL: n-registered-colors
 243
 244 MEMO: register-color ( fg bg -- n )
 245     [ n-registered-colors get dup ] 2dip ffi:init_pair curses-error
 246     n-registered-colors inc ;
 247
 248 : init-colors ( -- )
 249     ffi:has_colors [
 250         1 n-registered-colors set
 251         \ register-color reset-memoized
 252         ffi:start_color curses-error
 253         ffi:stdscr 0 f ffi:wcolor_set curses-error
 254     ] when ;
 255
 256 PRIVATE>
 257
 258 : setup-window ( window -- window )
 259     [
 260         dup [ window-params ] keep
 261         parent-window>> [ ptr>> ffi:derwin ] [ ffi:newwin ] if*
 262         curses-pointer-error >>ptr &dispose
 263     ] [ apply-window-options ] bi ;
 264
 265 : with-window ( window quot -- )
 266     [ current-window ] dip with-variable ; inline
 267
 268 : with-curses ( window quot -- )
 269     curses-ok? [ unsupported-curses-terminal ] unless
 270     [
 271         '[
 272             ffi:initscr curses-pointer-error
 273             >>ptr
 274             {
 275                 [ apply-global-options ]
 276                 [ apply-window-options ]
 277                 [ ptr>> ffi:wclear curses-error ]
 278                 [ ptr>> ffi:wrefresh curses-error ]
 279                 [ ]
 280             } cleave
 281             init-colors
 282
 283             _ with-window
 284         ] [ ffi:endwin curses-error ] finally
 285     ] with-destructors ; inline
 286
 287 <PRIVATE
 288
 289 : (wcrefresh) ( window-ptr -- )
 290     ffi:wrefresh curses-error ; inline
 291
 292 : (wcwrite) ( string window-ptr -- )
 293     swap ffi:waddstr curses-error ; inline
 294
 295 :: (wcread) ( n encoding window-ptr -- string )
 296     [
 297         n 1 + malloc &free :> str
 298         window-ptr str n ffi:wgetnstr curses-error
 299         str encoding alien>string
 300     ] with-destructors ; inline
 301
 302 : (wcmove) ( y x window-ptr -- )
 303     -rot ffi:wmove curses-error ; inline
 304
 305 : (winsert-blank-line) ( y window-ptr -- )
 306     [ 0 swap (wcmove) ]
 307     [ ffi:winsertln curses-error ] bi ; inline
 308
 309 : (waddch) ( ch window-ptr -- )
 310     swap ffi:waddch curses-error ; inline
 311
 312 : (wgetch) ( window -- key )
 313     ffi:wgetch [ curses-error ] keep ; inline
 314
 315 : (wattroff) ( attribute window-ptr -- )
 316     swap ffi:wattroff curses-error ; inline
 317
 318 : (wattron) ( attribute window-ptr -- )
 319     swap ffi:wattron curses-error ; inline
 320
 321 PRIVATE>
 322
 323 : wcrefresh ( window -- ) ptr>> (wcrefresh) ;
 324 : crefresh ( -- ) current-window get wcrefresh ;
 325
 326 : wgetch ( window -- key ) ptr>> (wgetch) ;
 327 : getch ( -- key ) current-window get wgetch ;
 328
 329 : wgetch-err ( window -- key ) ptr>> ffi:wgetch ;
 330 : getch-err ( -- key ) current-window get wgetch-err ;
 331
 332 : waddch ( ch window -- ) ptr>> (waddch) ;
 333 : addch ( ch -- ) current-window get waddch ;
 334
 335 : wcnl ( window -- ) [ CHAR: \n ] dip waddch ;
 336 : cnl ( -- ) current-window get wcnl ;
 337
 338 : wcwrite ( string window -- ) ptr>> (wcwrite) ;
 339 : cwrite ( string -- ) current-window get wcwrite ;
 340
 341 : wcprint ( string window -- )
 342     ptr>> [ (wcwrite) ] [ CHAR: \n swap (waddch) ] bi ;
 343 : cprint ( string -- ) current-window get wcprint ;
 344
 345 : wcprintf ( string window -- )
 346     ptr>> [ (wcwrite) ] [ CHAR: \n swap (waddch) ]
 347     [ (wcrefresh) ] tri ;
 348 : cprintf ( string -- ) current-window get wcprintf ;
 349
 350 : wcwritef ( string window -- )
 351     ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
 352 : cwritef ( string -- ) current-window get wcwritef ;
 353
 354 : wcread ( n window -- string )
 355     [ encoding>> ] [ ptr>> ] bi (wcread) ;
 356 : cread ( n -- string ) current-window get wcread ;
 357
 358 : werase ( window -- ) ptr>> ffi:werase curses-error ;
 359 : erase ( -- ) current-window get werase ;
 360
 361 : wcmove ( y x window -- )
 362     ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
 363 : cmove ( y x -- ) current-window get wcmove ;
 364
 365 : wdelete-line ( y window -- )
 366     ptr>> [ 0 swap (wcmove) ] [ ffi:wdeleteln curses-error ] bi ;
 367 : delete-line ( y -- ) current-window get wdelete-line ;
 368
 369 : winsert-blank-line ( y window -- )
 370     ptr>> (winsert-blank-line) ;
 371 : insert-blank-line ( y -- )
 372     current-window get winsert-blank-line ;
 373
 374 : winsert-line ( string y window -- )
 375     ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
 376 : insert-line ( string y -- )
 377     current-window get winsert-line ;
 378
 379 : wattron ( attribute window -- ) ptr>> (wattron) ;
 380 : attron ( attribute -- ) current-window get wattron ;
 381
 382 : wattroff ( attribute window -- ) ptr>> (wattroff) ;
 383 : attroff ( attribute -- ) current-window get wattroff ;
 384
 385 : wall-attroff ( window -- ) [ A_NORMAL ] dip wattroff ;
 386 : all-attroff ( -- ) current-window get wall-attroff ;
 387
 388 : wccolor ( foreground background window -- )
 389     [ register-color ] dip ptr>> swap f ffi:wcolor_set curses-error ;
 390
 391 : ccolor ( foreground background -- )
 392     current-window get wccolor ;
 393
 394 : wcbox ( window -- )
 395     ptr>> 0 0 ffi:box curses-error ;
 396 : cbox ( -- )
 397     current-window get wcbox ;
 398
 399 SYMBOLS: +pressed+ +released+ +clicked+ +double+ +triple+ ;
 400
 401 TUPLE: mouse-event
 402     { id fixnum }
 403     { y fixnum }
 404     { x fixnum }
 405     { button fixnum }
 406     type
 407     alt
 408     shift
 409     ctrl ;
 410
 411 <PRIVATE
 412
 413 : substate-n ( bstate n -- substate )
 414     [ 1 + ffi:NCURSES_BUTTON_RELEASED ffi:NCURSES_MOUSE_MASK 1 - bitand ] keep
 415     1 - -6 * shift ; inline
 416
 417 : button-n? ( bstate n -- ? ) substate-n 0 = not ; inline
 418
 419 : fill-in-type ( mouse-event bstate button -- )
 420     substate-n {
 421         { BUTTON1_RELEASED       [ +released+ ] }
 422         { BUTTON1_PRESSED        [ +pressed+ ] }
 423         { BUTTON1_CLICKED        [ +clicked+ ] }
 424         { BUTTON1_DOUBLE_CLICKED [ +double+ ] }
 425         { BUTTON1_TRIPLE_CLICKED [ +triple+ ] }
 426     } case >>type drop ; inline
 427
 428 : fill-in-bstate ( mouse-event bstate -- )
 429     2dup {
 430         { [ dup 1 button-n? ] [ [ 1 >>button ] dip 1 fill-in-type ] }
 431         { [ dup 2 button-n? ] [ [ 2 >>button ] dip 2 fill-in-type ] }
 432         { [ dup 3 button-n? ] [ [ 3 >>button ] dip 3 fill-in-type ] }
 433         { [ dup 4 button-n? ] [ [ 4 >>button ] dip 4 fill-in-type ] }
 434         { [ dup 5 button-n? ] [ [ 5 >>button ] dip 5 fill-in-type ] }
 435     } cond
 436     {
 437         [ BUTTON_CTRL  bitand 0 = not [ t >>ctrl  ] when drop ]
 438         [ BUTTON_SHIFT bitand 0 = not [ t >>shift ] when drop ]
 439         [ BUTTON_ALT   bitand 0 = not [ t >>alt   ] when drop ]
 440     } 2cleave ;
 441
 442 : <mouse-event> ( MEVENT -- mouse-event )
 443     [ mouse-event new ] dip {
 444         [ id>> >>id drop ]
 445         [ y>> >>y drop ]
 446         [ x>> >>x drop ]
 447         [ bstate>> fill-in-bstate ]
 448         [ drop ]
 449     } 2cleave ;
 450
 451 PRIVATE>
 452
 453 : getmouse ( -- mouse-event/f )
 454     [
 455         ffi:MEVENT malloc-struct &free
 456         dup ffi:getmouse
 457         ffi:ERR = [ drop f ] [ <mouse-event> ] if
 458     ] with-destructors ;
 459
 460 : mousemask ( mask -- newmask oldmask )
 461     0 ulong <ref> [ ffi:mousemask ] keep ulong deref ;
 462
 463 : wget-yx ( window -- y x )
 464     ptr>> [ _cury>> ] [ _curx>> ] bi ;
 465 : get-yx ( -- y x )
 466     current-window get wget-yx ;
 467
 468 : wget-y ( window -- y )
 469     ptr>> _cury>> ;
 470 : get-y ( -- y )
 471     current-window get wget-y ;
 472 : wget-x ( window -- x )
 473     ptr>> _curx>> ;
 474 : get-x ( -- x )
 475     current-window get wget-x ;
 476
 477 : wget-max-yx ( window -- y x )
 478     ptr>> [ _maxy>> 1 + ] [ _maxx>> 1 + ] bi ;
 479 : get-max-yx ( -- y x )
 480     current-window get wget-max-yx ;
 481
 482 : wget-max-y ( window -- y )
 483     ptr>> _maxy>> 1 + ;
 484 : get-max-y ( -- y )
 485     current-window get wget-max-y ;
 486 : wget-max-x ( window -- x )
 487     ptr>> _maxx>> 1 + ;
 488 : get-max-x ( -- x )
 489     current-window get wget-max-x ;
 490
 491 ALIAS: set-escdelay ffi:set-ESCDELAY