minos-windows.fs 26.9 KB
Newer Older
1 2
\ window                                               15aug99py

bp's avatar
bp committed
3 4
Variable  apprefcnt

5 6 7 8
displays class window
public: gadget ptr child        cell var title
        method make-window      method decoration
        gadget ptr innerwin     & innerwin viewport asptr viewp
bp's avatar
bp committed
9
        cell var closing        cell var app
10 11 12 13 14 15 16 17 18 19 20 21 22
        method title!           method title+!
        method stop             method set-icon
        method set-parent
how:    : xinc  child xinc ;
        : yinc  child yinc ;
        : schedule ( xt o time -- )  dpy schedule ;
        : invoke ( -- flag )  dpy invoke ;
        : cleanup ( o -- )  dpy cleanup ;

\ window                                               10may99py

        Variable border-size

bp's avatar
bp committed
23
[defined] x11 [IF]
24 25
        Variable wm_delete_window
        : set-protocol ( -- )
26
          xrc dpy @ 0" WM_DELETE_WINDOW" 0 XInternAtom
27
          wm_delete_window !
28
	  xrc dpy @ xwin @
29
	  xrc dpy @ 0" WM_PROTOCOLS" 0 XInternAtom
bp's avatar
bp committed
30
	  4 #32 1 wm_delete_window 1
31
	  XChangeProperty drop ;
32 33 34 35 36 37 38
        :noname  event XClientMessageEvent data @
          wm_delete_window @ =  IF  close  THEN ;
        ClientMessage cells Handlers + !

\ window transient subclassing                         13nov99py

        : set-parent ( win -- )
39
          xrc dpy @ xwin @ rot XSetTransientForHint ;
40 41 42 43 44 45 46 47

\ window                                               16aug98py
        Create WMhints sizeof XWMHints allot
        Create hints   sizeof XSizeHints allot
        : set-hint ( -- )  1 WMhints XWMHints input !
          NormalState WMhints XWMhints initial_state !
          [ InputHint StateHint or ] Literal
          WMhints XWMHints flags !
48
          xrc dpy @ xwin @ WMhints XSetWMHints ;
49 50 51 52
        : set-icon ( o -- )
          icon-pixmap with 0 0 draw-at endwith
          >r >r 2drop 2drop 2drop r> r>
          WMhints XWMHints icon_pixmap !
53 54
          dup WMhints XWMHints icon_mask !
	  IconPixmapHint swap -1 <> IF  IconMaskHint or  THEN
55
          WMhints XWMHints flags !
56
          xrc dpy @ xwin @ WMhints XSetWMHints ;
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71

\ window                                               19dec04py

        : set-xswa ( -- )  0 xrc color 3 xrc color
                    xswa XSetWindowAttributes background_pixel !
                    xswa XSetWindowAttributes border_pixel !
          backing-mode xswa XSetWindowAttributes backing_store !
        NorthWestGravity xswa XSetWindowAttributes bit_gravity !
        NorthWestGravity xswa XSetWindowAttributes win_gravity !
          None     xswa XSetWindowAttributes background_pixmap !
          None      xswa XSetWindowAttributes border_pixmap !
          xrc cmap @   xswa XSetWindowAttributes colormap !
          event-mask   xswa XSetWindowAttributes event_mask ! ;

\ window                                               28oct06py
bp's avatar
bp committed
72
        : set-hints  flags #hidden bit@ ?EXIT  x @ y @ d0= 0= 5 and
73 74 75 76 77 78 79 80 81 82 83 84 85
          $178  or hints XSizeHints flags !
          yinc  xinc rot swap
                hints XSizeHints width_inc 2!
                hints XSizeHints base_width 2!
          hglue 2dup + w @ min 2 pick max
                hints XSizeHints width !
          over  hints XSizeHints min_width !
          +     hints XSizeHints max_width !
          vglue 2dup + h @ min 2 pick max
                hints XSizeHints height !
          over  hints XSizeHints min_height !
          +     hints XSizeHints max_height !
          y @ x @ hints XSizeHints x 2!
86
          xrc dpy @ xwin @ hints XSetWMNormalHints ;
87 88 89 90

\ window                                               23jan07py

        : make-window ( n -- )  >r  set-xswa
91 92 93 94 95
	  xrc dpy @ dpy xwin @
	  0 0 w @ 1 max h @ 1 max
	  border-size @ border-size off
	  xrc get-visual 0 rot
	  xswavals r> or xswa
96 97 98 99 100
          XCreateWindow xwin !   set-protocol set-hint
          xwin @ xrc get-ic ;
[THEN]

\ window                                               28jul07py
bp's avatar
bp committed
101
[defined] win32 [IF]
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
        : make-window ( n -- )   >r  x @ y @ d0=
          IF  $80000000 dup x ! y !  THEN
          0 xrc inst @ 0  r@ $80000000 and
          0= IF    0        y @ x @ h @ w @
                   WS_OVERLAPPEDWINDOW
             ELSE  owner @  y @ x @ h @ w @
                   WS_POPUP border-size @ border-size off
                   IF  WS_BORDER or  THEN
             THEN  dup style !
          popupW minosW
          r> $7FFFFFFF and  CreateWindowExW xwin !
          0 0 0 0 sp@ xwin @ GetWindowRect drop x ! y ! 2drop
          app-win @ 0= IF  xwin @ app-win !  THEN ;
        : set-icon  ( o -- ) drop ;

\ window                                               13nov99py

        : set-parent ( win -- ) dup  owner !
          xwin @ SetParent drop ;
[THEN]
        : init ( dpy -- )   bind dpy  self dpy append
          dpy xrc clone bind xrc
          0 make-window  xwin @ xrc get-gc  0 set-font
          maxclicks 8* cell+ clicks 2dup Handle! @ swap erase
          title off ;
bp's avatar
bp committed
127
        : ?app  app @ IF  -1 apprefcnt +! app @ wake pause  app off  THEN ;
128 129 130

\ window                                               22sep07py

bp's avatar
bp committed
131
        : dispose ( -- ) self dpy delete
132 133 134
          child self  drop child dispose  self cleanup
          title $off
          xwin @  IF
bp's avatar
bp committed
135
[defined] x11 [IF]    xrc ic @ dup IF  XDestroyIC  THEN  drop
136
                      xrc dpy @ xwin @ XDestroyWindow drop
137
[THEN]
bp's avatar
bp committed
138 139
[defined] win32 [IF]  xwin @ DestroyWindow drop
                      xwin @ app-win @ = IF
bp's avatar
bp committed
140
			  screen childs xwin @ dup re-time app-win !
bp's avatar
bp committed
141 142
		      THEN
		      dpy handle-event
143
[THEN]    THEN
bp's avatar
bp committed
144
          ?app super dispose ;
145 146 147

\ window                                               09aug04py

bp's avatar
bp committed
148
[defined] x11 [IF]
bp's avatar
bp committed
149
        : show   ( -- )
150
          h @ w @ d0= IF  xywh resize THEN
bp's avatar
bp committed
151
          flags #hidden bit@  flags #hidden -bit  set-hints  \ dpy sync
bp's avatar
bp committed
152
          0= IF  xrc dpy @ xwin @  xywh 2over d0=
bp's avatar
bp committed
153
              IF    2swap 2drop XResizeWindow
154
              ELSE  XMoveResizeWindow  THEN  dpy sync  THEN
bp's avatar
bp committed
155
          xrc dpy @ xwin @ XMapRaised  child show ;
156 157 158 159
[THEN]

\ window                                               13nov99py

bp's avatar
bp committed
160
[defined] win32 [IF]
161 162
        : show   ( -- )  child show
          h @ w @ d0= IF  xywh resize THEN
bp's avatar
bp committed
163
          flags #hidden -bit   SWP_NOZORDER SWP_SHOWWINDOW or
164 165 166 167 168 169 170 171 172 173
          owner @ IF  SWP_NOACTIVATE or  THEN
          h @ w @ 0 0 sp@ >r 0 style @ r>
          AdjustWindowRect drop p-
          y @ x @
          owner @ IF  HWND_TOPMOST  ELSE  HWND_TOP  THEN
          xwin @ SetWindowPos drop ;
[THEN]

\ window                                               01nov06py

174
        : hide ( -- ) flags #hidden +bit  child hide \ ?app
bp's avatar
bp committed
175
[defined] x11 [IF]
176
          sync  xrc dpy @ xwin @ XUnmapWindow  sync  [THEN]
bp's avatar
bp committed
177
[defined] win32 [IF]
178
          SW_HIDE xwin @ ShowWindow drop  [THEN] ;
179 180 181 182 183 184
        : stop ( -- )  up@ app !  1 apprefcnt +!
	    up@ event-task' = IF
		BEGIN  screen with
		    handle-event invoke do-idle
		endwith apprefcnt @ 0=  UNTIL
		ELSE  F stop  THEN ;
185 186 187 188 189 190 191 192 193 194 195 196
        : delete ( addr addr' -- )  over self =
          IF    nextwin self swap ! drop
          ELSE  drop link nextwin  nextwin goto delete  THEN ;
        : append ( o before -- )  nextwin self over =
          IF    swap bind nextwin  nextwin bind nextwin
                parent self nextwin bind parent
          ELSE  nextwin goto append  THEN ;

\ window                                               22sep07py
        : decoration ( o -- o' )
          & viewport @ innerwin class?
          IF  sliderview new  THEN ;
bp's avatar
bp committed
197
        : focus  [defined] x11 [IF]
198 199
          xrc ic @ dup IF  dup >r XNFocusWindow xwin @
	                   XNClientWindow xwin @ 0
200 201 202 203 204 205 206 207 208
                           XSetICValues_2 drop
                           r> XSetICFocus
          THEN  drop  [THEN]
          child focus   ;
        : defocus
          child defocus ;

\ window                                               25jan03py

bp's avatar
bp committed
209
[defined] x11 [IF]
210 211 212 213 214 215 216 217 218
        : get-event ( mask -- )  dpy get-event  flush-queue ;
        : handle-event ( -- )
          event XAnyEvent window @ xwin @ =
          event XAnyEvent type @
          dup FocusIn = swap FocusOut = or
          IF    event XEnterWindowEvent subwindow @ xwin @ = or
          THEN
          IF \ cr ." sending event " event @ . ." to win "
             \ base @ event XAnyEvent window @ hex . base !
219
             event @ LASTEvent umin cells Handlers + perform
220 221 222 223 224
             ( ."  done " ) EXIT  THEN
          nextwin goto handle-event ;
[THEN]

\ window                                               29jul07py
bp's avatar
bp committed
225
[defined] win32 [IF]
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
        : .event base push hex cell+ @+ swap 4 .r
          @+ swap 5 .r @+ swap 9 .r @+ swap 9 .r @+ @ swap
          5 .r 5 .r cr ;
        : get-event ( mask -- )  drop
          BEGIN  PM_REMOVE 0 0 xwin @ event PeekMessageW
                 WHILE  handle-event  REPEAT
          size-event ;
        : handle-event ( -- )  \ event .event
          event TranslateMessage drop  maxascii $80 =
          IF    event DispatchMessageW drop
          ELSE  event DispatchMessage drop  THEN
          pause ;
[THEN]

\ window                                               25jan03py

        : !resized  xrc !font
          0 set-font  child !resized resized ;
bp's avatar
bp committed
244
        : geometry ( w h -- ) { gw gh }
245 246 247
          1 counter ! rw off rh off
          x @ y @ xinc gw * + yinc gh * + resize
          0 counter ! rw on  rh on
248
          x @ y @ xinc gw * + yinc gh * + resize ;
249
        : geometry? ( -- w h )
250 251
          w @ xinc >r - r> /f
          h @ yinc >r - r> /f ;
252 253 254 255 256
        : draw ( -- ) \ base push hex xwin @ . ." : w-draw "
          clip-should off  clip-is off
          0 clip-rect  child draw ;

\ window                                               05oct07py
bp's avatar
bp committed
257
[defined] x11 [IF]
258 259 260
        Create 'textprop 0 , 0 , 8 , 1 ,
        : !title ( -- )  0 title $@ + c!
          0" MINOS" title $@ drop sp@
261
          xrc dpy @ xwin @ rot XSetClassHint 2drop
262 263
          XA_STRING title @ cell+ 'textprop 2!
          title @ @ 'textprop 3 cells + !
264 265 266 267
	  xrc dpy @ xwin @ 'textprop
	  over2 0" _NET_WM_NAME" 0 XInternAtom  XSetTextProperty
	  xrc dpy @ xwin @ 'textprop
          over2 0" _NET_WM_ICON_NAME" 0 XInternAtom  XSetTextProperty
268 269
          xrc dpy @ xwin @ title @ cell+ XStoreName
          xrc dpy @ xwin @ title @ cell+ XSetIconName ;
270 271 272 273 274
        : title!  ( addr u -- ) title $!  !title ;
        : title+! ( addr u -- ) title $+! !title ;  [THEN]

\ window                                               29jul07py

bp's avatar
bp committed
275
[defined] win32 [IF]
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
        : !title ( -- )  title $@ >utf16 drop
          xwin @ SetWindowTextW drop ;
        : title!  ( addr u -- ) title $!  !title ;
        : title+! ( addr u -- ) title $+! !title ;
        : screenpos ( -- x y )
          0 0 0 0 sp@ xwin @ GetWindowRect drop 2swap 2drop
          h @ w @ 0 0
          sp@ >r 0 style @ r> AdjustWindowRect drop 2swap 2drop
          p- swap ;
        : mxy! ( mx my -- ) 2dup super mxy!
          screenpos p+ screen mxy! ;
[THEN]

\ window                                               17dec00py
        : assign ( widget addr n -- )
          child self IF  child dispose  THEN  title!
          dup bind innerwin  decoration  bind child
          self child dpy!  self child bind parent ;
        : adjust-inc ( n off inc -- n' )
295
          >r tuck - r@ 2/ + r@ /f r> * + ;
296 297 298 299 300 301 302 303 304 305
        : min-max ( n glue -- n' ) over + >r umax r> umin ;
        : child-size? ( -- x y )  child xywh 2swap 2drop  2dup
          yinc adjust-inc vglue min-max h !
          xinc adjust-inc hglue min-max w ! ;
        : child-resize ( -- )
          BEGIN  0 0 w @ h @ 2dup 2>r child resize
                 2r> child-size? 2over w @ h @ d= >r
                 d= r> and  UNTIL ;

\ window                                               19oct99py
bp's avatar
bp committed
306
[defined] x11 [IF]
307 308
        : re-size ( -- )
          rw @ rh @ w @ h @ d= 0= IF
309
              xrc dpy @ xwin @ w @ h @ XResizeWindow
310 311
          THEN ;
[THEN]
bp's avatar
bp committed
312
[defined] win32 [IF]
313 314 315 316 317 318 319 320 321 322 323 324 325 326 327
        : re-size ( -- )
          rw @ rh @ w @ h @ d= 0= IF
              1 h @ w @ 0 0
              sp@ >r 0 style @ r> AdjustWindowRect drop
              2dup >r >r p- screenpos swap r> r> p+
              xwin @ MoveWindow drop
          THEN ;
[THEN]

\ window                                               07jan07py

        : (resized ( -- )
          child-resize  child-moved
\          rw @ rh @  child-size?  d= 0=  IF  draw  THEN
          set-hints dpy sync  re-size ;
bp's avatar
bp committed
328
        : close  ( -- )  closing push closing @ closing on
bp's avatar
bp committed
329
          IF    hide ['] dispose self #10 after schedule
bp's avatar
bp committed
330
          ELSE  innerwin close  THEN ;
331 332 333 334

\ window                                               15jul01py

        : repos ( x y -- )   2dup y ! x !
bp's avatar
bp committed
335
[defined] x11 [IF]   set-hints
336
          xrc dpy @ xwin @ 2swap XMoveWindow sync ; [THEN]
bp's avatar
bp committed
337
[defined] win32 [IF]
338 339 340
          >r >r 0 h @ w @ r> r> swap
          xwin @ MoveWindow drop ;  [THEN]
        : resized  ( -- )  (resized counter @ ?EXIT  draw ;
341
	: child-moved ( -- )  pointed self
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367
          IF  mx @ my @ pointed xywh >r >r
              p- r> r> rot swap u< -rot u< and
              IF  & backing @ pointed class?
                  IF mx @ my @ pointed moved THEN  EXIT  THEN
              pointed leave  0 bind pointed  THEN
          child self  IF  mx @ my @  child moved  THEN ;

\ window                                               28mar99py
        : resize ( x y w h -- )
          h ! w ! 2drop (resized ;
        : mouse ( -- x y b ) mx @ my @ mb @ ;
        : clicked  ( x y b n -- )  child clicked ;
        : hglue ( -- glue ) child hglue ;
        : vglue ( -- glue ) child vglue ;
        : keyed ( key -- )  dup 8 and
          IF  over $FF51 =  2 pick $FF53 = or
              & vviewport @ innerwin class? not and
              IF  viewp hspos keyed  EXIT  THEN
              over $FF52 =  2 pick $FF54 = or
              & hviewport @ innerwin class? not and
              IF  viewp vspos keyed  EXIT  THEN
          THEN  innerwin keyed ;
class;

\ menu-entry                                           05jan07py

bp's avatar
bp committed
368 369 370 371 372 373
[defined] VFXFORTH [IF]
    actor ptr menu-call
[ELSE]
    actor uptr menu-call
[THEN]
: >menu-call ( addr -- ) bind menu-call ;
374

bp's avatar
bp committed
375
'&' Value menu-sep
376 377 378 379 380
button class menu-entry
how:    \ init ( act addr len -- )
        2 colors focuscol !     3 colors defocuscol !
        : clicked ( x y b n -- ) dup 0= IF 2drop 2drop EXIT THEN
          >released drop
bp's avatar
bp committed
381
          dpy hide callback self >menu-call ;
382 383 384 385 386 387 388 389
        : keyed ( key sh -- )  drop  dup bl = swap #cr = or
          IF  x @ y @  1 2 clicked  THEN ;
        : focus  super focus color   focuscol chcol +push draw ;
        : defocus color defocuscol chcol -push draw ;

\ menu-entry                                           12dec99py

        : hglue  text $@ menu-sep scan nip
390
          IF    0 text menu-sep [: fnt size drop 1 *fil
391 392 393
                               2 pick parent with
                                   dup >r 1- combined tab@ p+
                                   r> combined tab!
394
                               endwith  1+ ;] $iter
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409
                1- parent with combined tab@ endwith
                xM xS + 1+ 0 p+
          ELSE  textwh @ xM + xS + 1+ 1 *fil  THEN ;
class;

\ event handler for sub-window                         30aug05py
window class window-stub
how:    : init ( widget win -- )  xwin !  title off
          dup bind innerwin bind child
          child with dpy self endwith bind dpy
          self dpy with dpy append endwith
          dpy xrc clone bind xrc
          xwin @ xrc get-gc  0 set-font
          maxclicks 8* cell+ clicks 2dup Handle! @ swap erase ;
        : resize-win ( -- )  h @ w @ y @ x @ or or or 0= ?EXIT
bp's avatar
bp committed
410
[defined] win32 [IF]  SWP_NOZORDER SWP_SHOWWINDOW or
411
          h @ w @ y @ x @
412
          owner @ IF  HWND_TOPMOST  ELSE  0  THEN
bp's avatar
bp committed
413
          xwin @ SetWindowPos drop  [THEN]
bp's avatar
bp committed
414
[defined] x11 [IF]    xrc dpy @ xwin @ xywh XMoveResizeWindow  [THEN] ;
415 416

\ event handler for sub-window                         20nov07py
bp's avatar
bp committed
417
        : show ( -- )  resize-win
bp's avatar
bp committed
418 419
[defined] win32 [IF]  SWP_SHOWWINDOW xwin @ ShowWindow drop [THEN]
[defined] x11 [IF]    xrc dpy @ xwin @ XMapWindow  [THEN] ;
420 421 422 423 424
        : dispose-it ( -- )  self cleanup
          self dpy get-dpy with dpy delete endwith
          title $off
          xrc dispose gadget :: dispose ;
        : dispose ( -- )
bp's avatar
bp committed
425 426 427
[defined] win32 [IF]  xwin @ IF  xwin @ DestroyWindow drop  THEN
          ['] dispose-it  self #20 after schedule ;  [THEN]
[defined] x11 [IF]  dispose-it ;  [THEN]
428 429 430 431
        : resize  h ! w ! y ! x !  resize-win ;

\ event handler for sub-window                         30aug05py

432
        : moved!  dpy moved! ;
433
\        : moved?  dpy moved? ;
bp's avatar
bp committed
434
        : click^  dpy click^ ;
435 436 437 438 439 440 441
        : moreclicks dpy moreclicks ;
        : mxy!    transclick dpy mxy! ;
        : keyed   dpy keyed ;
        : transclick ( x y -- x' y' ) x @ y @ p+ ;
class;

\ window without border                                12dec99py
bp's avatar
bp committed
442
[defined] win32 [IF]   Variable owner-win  [THEN]
443 444 445
window class frame
public: cell var map?           method set-dpys
        method grab             method ungrab
bp's avatar
bp committed
446
        method handle [defined] win32 [IF]  displays ptr ?grab  [THEN]
447
how:    : make-window  ( attrib -- )
bp's avatar
bp committed
448
[defined] x11 [IF]  mouse_cursor xrc cursor
449 450 451 452 453
          xswa XSetWindowAttributes cursor !
          1 xswa XSetWindowAttributes override_redirect !
          1 xswa XSetWindowAttributes save_under !
          CWSaveUnder or CWOverrideRedirect or CWCursor or
[THEN]
bp's avatar
bp committed
454
[defined] win32 [IF]  owner-win @ owner ! owner-win off  $80000000 or
455 456 457 458 459 460 461 462 463 464 465 466 467
          WS_EX_TOPMOST or WS_EX_TOOLWINDOW or  [THEN]
          super make-window ;

\ frame                                                08aug04py

        : handle ( -- flag )
          -1 -1 0 0 child clicked  true
          BEGIN  click? 0=
                 IF  moved?
                     IF   mouse drop child inside?
                          mouse 0 child clicked tuck <>
                          IF dup IF   child focus
                                 ELSE child defocus  THEN THEN
bp's avatar
bp committed
468
                     THEN  dpy xrc fid #30 idle
469 470 471 472 473 474 475 476
                 ELSE  click 2over child inside? dup >r
                       IF    child clicked
                       ELSE  hide 2drop 2drop
                       THEN  drop r>
                 THEN  map? @ 0=  UNTIL ;

\ frame                                                09mar07py

bp's avatar
bp committed
477
[defined] x11 [IF]
478 479
        Variable grab-win       grab-win on
        : Xgrab ( win -- )  grab-win @ map? ! grab-win !
480
	  xrc dpy @ grab-win @ 0
481 482
          [ ButtonPressMask ButtonReleaseMask PointerMotionMask
            or or ] Literal
483 484 485 486
	  GrabModeAsync dup  None dup  CurrentTime
	  XGrabPointer drop
	  xrc dpy @ grab-win @ RevertToParent CurrentTime
	  XSetInputFocus ;
487 488 489
        : grab  xwin @ Xgrab ;
        : ungrab ( -- )  map? @ dup grab-win !
          dup -1 <>  IF  Xgrab map? off  EXIT  THEN drop
490
          xrc dpy @ CurrentTime XUngrabPointer map? off ;
491 492 493
[THEN]

\ frame                                                27jun02py
bp's avatar
bp committed
494
[defined] win32 [IF]
495 496 497 498 499 500 501 502 503 504
        : Wgrab ( win -- ) dup re-time  grab-key self bind ?grab
          SetCapture dup 0= or map? !  ^ F bind grab-key ;
        : grab ( -- )  xwin @ Wgrab ;
        : ungrab ( -- )  map? @
          IF    ?grab self  F bind grab-key  0 bind ?grab
                map? @ -1 <>  IF  map? @ grab  ?grab self
                   F bind grab-key  0 bind ?grab  THEN  map? off
          ELSE  ReleaseCapture drop  app-win @ re-time  THEN ;
 [THEN] : dispose ( -- )
          title $off
bp's avatar
bp committed
505 506
[defined] x11 [IF]  xwin @ IF xrc dpy @ xwin @ XDestroyWindow drop THEN
 [THEN] [defined] win32 [IF]
507 508 509 510 511
          xwin @  IF  xwin @ DestroyWindow drop  THEN
 [THEN]   self dpy delete  displays :: dispose ;

\ window without border                                29aug98py

bp's avatar
bp committed
512 513
        : show ( x y -- )
          y ! x !  flags #hidden -bit  super show ;
bp's avatar
bp committed
514
        : set-dpys ( widget -- )
515 516 517
          BEGIN  dup 0<> over 'nil <> and  WHILE  ^ swap >o
                 widget bind dpy   widget widgets self
                 & combined @ class?
bp's avatar
bp committed
518
                 IF    combined childs self o> recurse
519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
                 ELSE  o>  THEN
          REPEAT  drop ;
class;

\ tool tips                                            16jul00py

frame class frame-tip
public: displays ptr owner-dpy
how:    : make-window ( n -- )  1 border-size !
          super make-window ;
        : init ( owner dpy -- )  super init  bind owner-dpy ;
        : keyed  owner-dpy keyed ;
class;

\ tool tips                                            27jun02py

minos

bp's avatar
bp committed
537
#1000 Value tooltip-delay
538
#8000 Value tooltip-hide-delay
539 540 541 542 543 544 545 546 547 548 549 550

actor class tooltip
public: widget ptr tip          actor ptr feed
        frame-tip ptr tip-frame early show-tip
how:    : init ( actor tip -- )  bind tip  bind feed
          feed called self  set-called ;
        : dispose leave  tip dispose super dispose ;
        : leave  ^ screen cleanup  tip-frame self 0= ?EXIT
          tip-frame hide  tip-frame dispose 0 bind tip-frame ;

\ tool tips                                            07nov99py
        : show-tip ( -- )
bp's avatar
bp committed
551
[defined] win32 [IF]  caller with widget dpy get-dpy endwith
552 553 554 555 556 557 558
               displays with xwin @ endwith owner-win ! [THEN]
          caller with widget dpy pointed self ^ =
              IF   0 widget dpy set-rect  THEN  endwith
          caller xywh  & hbox @ caller parent class?
          IF  nip 0 swap  ELSE  drop 0  THEN  p+
          caller self widget with xN endwith dup p+
          caller self widget with dpy screenpos endwith p+
bp's avatar
bp committed
559
[defined] x11 [IF]  caller with widget dpy get-win endwith  [THEN]
560 561 562
          tip self caller self widget with dpy self endwith
          screen self frame-tip new dup bind tip-frame
          frame-tip with s" tooltip" assign
bp's avatar
bp committed
563
              [defined] x11 [IF]  set-parent  [THEN]  show focus
564 565
	  endwith
	  ['] leave ^ tooltip-hide-delay after screen schedule ;
566 567 568

\ tool tips                                            21sep07py

bp's avatar
bp committed
569 570
        : enter  [defined] x11 [IF]  leave  [THEN]
          [defined] win32 [IF]  tip-frame self ?EXIT  [THEN]
571 572
          ['] show-tip ^ tooltip-delay after screen schedule ;
        : toggle leave feed toggle ;
573
        : fetch  feed fetch ;
574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599
        : store  leave feed store ;
        : set-called  dup super set-called feed set-called ;
class;

: TT[  ;                                         immediate
: ]TT  tooltip postpone new ;                    immediate
: TT-string  text-label new tooltip new ;
: TT"  postpone X" postpone TT-string ;          immediate

\ menu-frame                                           09mar07py

frame class menu-frame
public: early popup
how:    : assign ( widget -- ) child self IF child dispose THEN
          dup bind child   bind innerwin
          self child dpy!  self child bind parent
          resized ;
        : screenpos ( -- x y )  x @ y @ ;
        : hide  ( -- )  super hide  ungrab ;
        : show ( x y -- ) super show  grab ;
        : keyed ( key sh -- )
          over #esc =  IF  2drop drop 0 hide EXIT  THEN
          super keyed ;

\ menu-frame                                           05mar07py

bp's avatar
bp committed
600
        : submenu-vpos { x y w h w' h' } ( --> x y )
601
          x y h + dup h' + screen h @ >  IF  h' - h - 0max  THEN
bp's avatar
bp committed
602 603
          swap screen w @ w' - min 0max swap ;
        : submenu-hpos { x y w h w' h' } ( --> x y )
604 605
          x w + y screen h @ h' - min 0max
          swap dup w' + screen w @ >  IF  w' - w - 0max  THEN
bp's avatar
bp committed
606
          swap ;
607 608 609

\ menu-frame                                           09mar07py
        : popup ( [xwin] child -- flag )  >r
bp's avatar
bp committed
610
[defined] win32+ [IF]  dpy get-dpy displays with xwin @ endwith
611 612 613 614 615 616 617 618
                owner-win !   [THEN]
          r@ widget with dpy self endwith
          dpy screenpos  xywh  >r >r p+ r> r>
          & hbox @ parent class?
          r> screen self new  with  assign  defocus
             >r  ( !resized ) 0 0 0 0 resize
             child with w @ h @ endwith
             r>  IF  submenu-vpos  ELSE  submenu-hpos  THEN
bp's avatar
bp committed
619
             >r rot [defined] x11 [IF] set-parent [ELSE] drop [THEN] r>
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637
             show  focus   handle  swap child dpy!
             dispose  endwith ;
class;

\ menu title                                           05mar07py
menu-entry class menu-title
        method menu-action
public: widget ptr callw
how:    0 colors focuscol !     1 colors defocuscol !
        : init  ( widget addr len -- )
          noop-act -rot super init bind callw ;
        : dispose callw dispose super dispose ;
        : menu-action  menu-call called self
          0= IF  dpy self menu-call set-called  THEN
          menu-call toggle ;
        : >released ( x y b n -- ) 2drop 2drop
          1 color 2+ c!  draw
          dpy get-win callw self menu-frame popup
bp's avatar
bp committed
638
          0=   IF    callback self >menu-call
639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656
               ELSE  dpy focus  THEN    0 color 2+ c!  draw ;

\ menu title                                           21apr01py

        : clicked  ( x y b n -- )
          dup 0= IF  2drop 2drop  EXIT  THEN
          >released  callw hide  menu-action ;
        : !resized  super !resized ( callw !resized ) ;
class;

\ sub-menu                                             27dec99py

menu-title class sub-menu
how:    \ : init ( widget addr u -- )  super init ;
        : menu-action ( -- )
          menu-call self callback self <> IF  dpy hide  THEN ;
class;

bp's avatar
bp committed
657
[defined] alias [IF]
658
' noop alias M:                                 immediate
bp's avatar
bp committed
659 660 661
[ELSE]
    synonym M: noop immediate
[THEN]
662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682

\ info-menu                                            27dec99py
hbox class info-menu
public: textfield ptr text      tributton ptr tri
        text-label ptr info     gadget ptr callw
how:    : assign ( addr u -- ) text assign ;
        : get ( -- addr u ) text get ;
        : text!  ( addr u -- ) info assign ;
        : menu-action  menu-call self 0= ?EXIT
          menu-call called self
          0= IF  dpy self menu-call set-called  THEN
          menu-call toggle ;
        : keyed ( key sh -- )
          over bl =  IF  tri keyed  ELSE  text keyed  THEN ;
        gadget :: prev-active
        gadget :: next-active
        gadget :: first-active

\ info-menu                                            02dec00py
        : init  ( widget addr len -- )
          text-label new bind info  bind callw
bp's avatar
bp committed
683
          callw self combined with childs get endwith 0 ST[ ]ST
684 685 686 687
                    textfield new dup bind text
          0 text edit ds !
            ^ M[ clicked ]M :down tributton new bind tri
            info self 1 habox new hfixbox  text self
688
            ^ S[ ]S [: text childs vglue ;] [: xS 0 ;] arule new
689
               tri self
690
            ^ S[ ]S [: text childs vglue ;] [: xS 0 ;] arule new
691
            3 vbox new hfixbox 2 hbox new
692
            ^ S[ ]S [: callw hglue ;] [: 0 0 ;] arule new
693 694 695 696 697 698 699
          2 vbox new  +fill 3 super init drop ;
        : dpy!  dup callw dpy!  super dpy! ;
        : !resized  super !resized  callw !resized ;

\ info-menu                                            05mar07py

        : >released ( x y b n -- ) 2drop 2drop
bp's avatar
bp committed
700
          :up tri assign tri draw  0 >menu-call
bp's avatar
bp committed
701
          dpy get-win
702
          callw self text with menu-frame popup endwith
bp's avatar
bp committed
703
          0=   IF callback self >menu-call THEN
704 705 706
          :down tri assign tri draw ;
        : clicked  ( x y b n -- ) \ first-active
          dup 0= IF  2drop 2drop  EXIT  THEN
707
          >released  menu-action ;
708 709 710 711 712 713 714 715 716 717 718
        : dispose  callw dispose  super dispose ;
        boxchar :: handle-key?
class;

\ window with menu                                     27dec99py

window class menu-window
how:    : decoration ( menu widget -- )
          super decoration 2 vbox new ;
class;