\ window 15aug99py Variable apprefcnt displays class window public: gadget ptr child cell var title method make-window method decoration gadget ptr innerwin & innerwin viewport asptr viewp cell var closing cell var app 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 [defined] x11 [IF] Variable wm_delete_window : set-protocol ( -- ) xrc dpy @ 0" WM_DELETE_WINDOW" 0 XInternAtom wm_delete_window ! xrc dpy @ xwin @ xrc dpy @ 0" WM_PROTOCOLS" 0 XInternAtom 4 #32 1 wm_delete_window 1 XChangeProperty drop ; :noname event XClientMessageEvent data @ wm_delete_window @ = IF close THEN ; ClientMessage cells Handlers + ! \ window transient subclassing 13nov99py : set-parent ( win -- ) xrc dpy @ xwin @ rot XSetTransientForHint ; \ 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 ! xrc dpy @ xwin @ WMhints XSetWMHints ; : set-icon ( o -- ) icon-pixmap with 0 0 draw-at endwith >r >r 2drop 2drop 2drop r> r> WMhints XWMHints icon_pixmap ! dup WMhints XWMHints icon_mask ! IconPixmapHint swap -1 <> IF IconMaskHint or THEN WMhints XWMHints flags ! xrc dpy @ xwin @ WMhints XSetWMHints ; \ 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 : set-hints flags #hidden bit@ ?EXIT x @ y @ d0= 0= 5 and $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! xrc dpy @ xwin @ hints XSetWMNormalHints ; \ window 23jan07py : make-window ( n -- ) >r set-xswa 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 XCreateWindow xwin ! set-protocol set-hint xwin @ xrc get-ic ; [THEN] \ window 28jul07py [defined] win32 [IF] : 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 ; : ?app app @ IF -1 apprefcnt +! app @ wake pause app off THEN ; \ window 22sep07py : dispose ( -- ) self dpy delete child self drop child dispose self cleanup title $off xwin @ IF [defined] x11 [IF] xrc ic @ dup IF XDestroyIC THEN drop xrc dpy @ xwin @ XDestroyWindow drop [THEN] [defined] win32 [IF] xwin @ DestroyWindow drop xwin @ app-win @ = IF screen childs xwin @ dup re-time app-win ! THEN dpy handle-event [THEN] THEN ?app super dispose ; \ window 09aug04py [defined] x11 [IF] : show ( -- ) h @ w @ d0= IF xywh resize THEN flags #hidden bit@ flags #hidden -bit set-hints \ dpy sync 0= IF xrc dpy @ xwin @ xywh 2over d0= IF 2swap 2drop XResizeWindow ELSE XMoveResizeWindow THEN dpy sync THEN xrc dpy @ xwin @ XMapRaised child show ; [THEN] \ window 13nov99py [defined] win32 [IF] : show ( -- ) child show h @ w @ d0= IF xywh resize THEN flags #hidden -bit SWP_NOZORDER SWP_SHOWWINDOW or 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 : hide ( -- ) flags #hidden +bit child hide \ ?app [defined] x11 [IF] sync xrc dpy @ xwin @ XUnmapWindow sync [THEN] [defined] win32 [IF] SW_HIDE xwin @ ShowWindow drop [THEN] ; : 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 ; : 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 ; : focus [defined] x11 [IF] xrc ic @ dup IF dup >r XNFocusWindow xwin @ XNClientWindow xwin @ 0 XSetICValues_2 drop r> XSetICFocus THEN drop [THEN] child focus ; : defocus child defocus ; \ window 25jan03py [defined] x11 [IF] : 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 ! event @ LASTEvent umin cells Handlers + perform ( ." done " ) EXIT THEN nextwin goto handle-event ; [THEN] \ window 29jul07py [defined] win32 [IF] : .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 ; : geometry ( w h -- ) { gw gh } 1 counter ! rw off rh off x @ y @ xinc gw * + yinc gh * + resize 0 counter ! rw on rh on x @ y @ xinc gw * + yinc gh * + resize ; : geometry? ( -- w h ) w @ xinc >r - r> /f h @ yinc >r - r> /f ; : draw ( -- ) \ base push hex xwin @ . ." : w-draw " clip-should off clip-is off 0 clip-rect child draw ; \ window 05oct07py [defined] x11 [IF] Create 'textprop 0 , 0 , 8 , 1 , : !title ( -- ) 0 title $@ + c! 0" MINOS" title $@ drop sp@ xrc dpy @ xwin @ rot XSetClassHint 2drop XA_STRING title @ cell+ 'textprop 2! title @ @ 'textprop 3 cells + ! 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 xrc dpy @ xwin @ title @ cell+ XStoreName xrc dpy @ xwin @ title @ cell+ XSetIconName ; : title! ( addr u -- ) title $! !title ; : title+! ( addr u -- ) title $+! !title ; [THEN] \ window 29jul07py [defined] win32 [IF] : !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' ) >r tuck - r@ 2/ + r@ /f r> * + ; : 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 [defined] x11 [IF] : re-size ( -- ) rw @ rh @ w @ h @ d= 0= IF xrc dpy @ xwin @ w @ h @ XResizeWindow THEN ; [THEN] [defined] win32 [IF] : 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 ; : close ( -- ) closing push closing @ closing on IF hide ['] dispose self #10 after schedule ELSE innerwin close THEN ; \ window 15jul01py : repos ( x y -- ) 2dup y ! x ! [defined] x11 [IF] set-hints xrc dpy @ xwin @ 2swap XMoveWindow sync ; [THEN] [defined] win32 [IF] >r >r 0 h @ w @ r> r> swap xwin @ MoveWindow drop ; [THEN] : resized ( -- ) (resized counter @ ?EXIT draw ; : child-moved ( -- ) pointed self 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 [defined] VFXFORTH [IF] actor ptr menu-call [ELSE] actor uptr menu-call [THEN] : >menu-call ( addr -- ) bind menu-call ; '&' Value menu-sep 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 dpy hide callback self >menu-call ; : 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 IF 0 text menu-sep [: fnt size drop 1 *fil 2 pick parent with dup >r 1- combined tab@ p+ r> combined tab! endwith 1+ ;] $iter 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 [defined] win32 [IF] SWP_NOZORDER SWP_SHOWWINDOW or h @ w @ y @ x @ owner @ IF HWND_TOPMOST ELSE 0 THEN xwin @ SetWindowPos drop [THEN] [defined] x11 [IF] xrc dpy @ xwin @ xywh XMoveResizeWindow [THEN] ; \ event handler for sub-window 20nov07py : show ( -- ) resize-win [defined] win32 [IF] SWP_SHOWWINDOW xwin @ ShowWindow drop [THEN] [defined] x11 [IF] xrc dpy @ xwin @ XMapWindow [THEN] ; : dispose-it ( -- ) self cleanup self dpy get-dpy with dpy delete endwith title $off xrc dispose gadget :: dispose ; : dispose ( -- ) [defined] win32 [IF] xwin @ IF xwin @ DestroyWindow drop THEN ['] dispose-it self #20 after schedule ; [THEN] [defined] x11 [IF] dispose-it ; [THEN] : resize h ! w ! y ! x ! resize-win ; \ event handler for sub-window 30aug05py : moved! dpy moved! ; \ : moved? dpy moved? ; : click^ dpy click^ ; : moreclicks dpy moreclicks ; : mxy! transclick dpy mxy! ; : keyed dpy keyed ; : transclick ( x y -- x' y' ) x @ y @ p+ ; class; \ window without border 12dec99py [defined] win32 [IF] Variable owner-win [THEN] window class frame public: cell var map? method set-dpys method grab method ungrab method handle [defined] win32 [IF] displays ptr ?grab [THEN] how: : make-window ( attrib -- ) [defined] x11 [IF] mouse_cursor xrc cursor xswa XSetWindowAttributes cursor ! 1 xswa XSetWindowAttributes override_redirect ! 1 xswa XSetWindowAttributes save_under ! CWSaveUnder or CWOverrideRedirect or CWCursor or [THEN] [defined] win32 [IF] owner-win @ owner ! owner-win off $80000000 or 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 THEN dpy xrc fid #30 idle ELSE click 2over child inside? dup >r IF child clicked ELSE hide 2drop 2drop THEN drop r> THEN map? @ 0= UNTIL ; \ frame 09mar07py [defined] x11 [IF] Variable grab-win grab-win on : Xgrab ( win -- ) grab-win @ map? ! grab-win ! xrc dpy @ grab-win @ 0 [ ButtonPressMask ButtonReleaseMask PointerMotionMask or or ] Literal GrabModeAsync dup None dup CurrentTime XGrabPointer drop xrc dpy @ grab-win @ RevertToParent CurrentTime XSetInputFocus ; : grab xwin @ Xgrab ; : ungrab ( -- ) map? @ dup grab-win ! dup -1 <> IF Xgrab map? off EXIT THEN drop xrc dpy @ CurrentTime XUngrabPointer map? off ; [THEN] \ frame 27jun02py [defined] win32 [IF] : 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 [defined] x11 [IF] xwin @ IF xrc dpy @ xwin @ XDestroyWindow drop THEN [THEN] [defined] win32 [IF] xwin @ IF xwin @ DestroyWindow drop THEN [THEN] self dpy delete displays :: dispose ; \ window without border 29aug98py : show ( x y -- ) y ! x ! flags #hidden -bit super show ; : set-dpys ( widget -- ) BEGIN dup 0<> over 'nil <> and WHILE ^ swap >o widget bind dpy widget widgets self & combined @ class? IF combined childs self o> recurse 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 #1000 Value tooltip-delay #8000 Value tooltip-hide-delay 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 ( -- ) [defined] win32 [IF] caller with widget dpy get-dpy endwith 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+ [defined] x11 [IF] caller with widget dpy get-win endwith [THEN] tip self caller self widget with dpy self endwith screen self frame-tip new dup bind tip-frame frame-tip with s" tooltip" assign [defined] x11 [IF] set-parent [THEN] show focus endwith ['] leave ^ tooltip-hide-delay after screen schedule ; \ tool tips 21sep07py : enter [defined] x11 [IF] leave [THEN] [defined] win32 [IF] tip-frame self ?EXIT [THEN] ['] show-tip ^ tooltip-delay after screen schedule ; : toggle leave feed toggle ; : fetch feed fetch ; : 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 : submenu-vpos { x y w h w' h' } ( --> x y ) x y h + dup h' + screen h @ > IF h' - h - 0max THEN swap screen w @ w' - min 0max swap ; : submenu-hpos { x y w h w' h' } ( --> x y ) x w + y screen h @ h' - min 0max swap dup w' + screen w @ > IF w' - w - 0max THEN swap ; \ menu-frame 09mar07py : popup ( [xwin] child -- flag ) >r [defined] win32+ [IF] dpy get-dpy displays with xwin @ endwith 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 >r rot [defined] x11 [IF] set-parent [ELSE] drop [THEN] r> 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 0= IF callback self >menu-call 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; [defined] alias [IF] ' noop alias M: immediate [ELSE] synonym M: noop immediate [THEN] \ 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 callw self combined with childs get endwith 0 ST[ ]ST 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 ^ S[ ]S [: text childs vglue ;] [: xS 0 ;] arule new tri self ^ S[ ]S [: text childs vglue ;] [: xS 0 ;] arule new 3 vbox new hfixbox 2 hbox new ^ S[ ]S [: callw hglue ;] [: 0 0 ;] arule new 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 :up tri assign tri draw 0 >menu-call dpy get-win callw self text with menu-frame popup endwith 0= IF callback self >menu-call THEN :down tri assign tri draw ; : clicked ( x y b n -- ) \ first-active dup 0= IF 2drop 2drop EXIT THEN >released menu-action ; : 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;