requires xutil.f
requires string-equals.f
requires uwm.f

variable this-mh

: mh this-mh @ ;

struct ( menu-header )
  addr mh_next
  addr mh_name
  addr mh_func
  addr mh_menuinfo
  Window mh_window
  int mh_mask
  int mh_button
  int mh_x
  int mh_y
  int mh_cur
  addr mh_curaddr
  int mh_hi_lite
  int mh_mapped
constant /menu-header

variable mouse_x  variable mouse_y  variable mouse_subw

: ?pending ( --- n )
  _XPending ret ;

: ?pending-mouseup ( --- b )
  begin ?pending while
    _button_event _XNextEvent
    xevent_type @ ButtonReleased = if
      _button_event _XPutBackEvent drop
      -1 exit then
  repeat
  0 ;

decimal
: update-mouse-click
  _button_event xevent_x w@ mouse_x !
  _button_event xevent_y w@ mouse_y !
;

: ?pending-mousedown ( --- b )
  begin ?pending while
    _button_event _XNextEvent
    xevent_type @ ButtonPressed = if
      _button_event _XPutBackEvent drop
      -1 exit then
  repeat
  0 ;

: cs"= ( c_string forth_string --- b )
  count rot cscount	\ fs_addr fs_len cs_addr cs_len
  2 pick = if		\ fs_addr fs_len cs_addr
    swap comp 0=		\ b
  else			\ fs_addr fs_len cs_addr
    2drop drop 0 then ;	\ b

: find-menu ( name --- menu )
  _Menus @ 			\ name mlink
  begin ?dup while		\ name mlink
    dup mlink_menu @		\ name mlink menuinfo
    dup mi_name @ 		\ name mlink menuinfo menuname
    3 pick cs"=	if		\ name mlink menuinfo
      nip nip exit then
    drop mlink_next @		\ name next_mlink
  repeat				\ name
  cr ." Can't find menu '" count type ." '!" abort ;

: update-mouse
  mouse_subw mouse_y mouse_x RootWindow _XUpdateMouse 2drop 2drop ;

: ?map-menu ( --- )
  mh mh_mapped @ 0= if
    mh mh_y @
    mh mh_x @
    mh mh_menuinfo @
    _MapMenu 2drop drop
    mh mh_mapped on
    _XFlush
  then ;

: ?unmap-menu ( --- )
  mh mh_mapped @ if
    mh mh_menuinfo @ _UnmapMenu drop 
    mh mh_mapped off
    _XFlush
  then ;

: center-menu ( --- )
  mh mh_menuinfo @ >r
  mouse_y @  
  dup mh mh_x !
  r@ mi_center_y @ - 0 max
  mouse_x @
  dup mh mh_y !
  r@ mi_center_x @ - 0 max
  r> mi_w @
  _XMoveWindow
  drop 2drop ;

: place-menu ( --- )
  begin
    ?pending-mousedown 0= while
    update-mouse center-menu
    ?map-menu
    _XFlush
  repeat
;

variable MH  0 MH !

: menu-header ( function name --name )
  here over over over c@ 1+ dup allot cmove
  create
  MH @ , , ,
  /menu-header 3 /n * - allot ;

: init-menu-headers
  MH begin
    @ ?dup while
    dup mh_name find-menu over mh_menuinfo !
  repeat ;

defer track-menu

: track-menu-highlight ( --- )
  mouse_y @  mouse_x @
  mh mh_cur  mh mh_menuinfo @
  _Track				\ y x >cur menu
  mh mh_mapped @ if
    mh mh_hi_lite  rot rot		\ y x >hi_lite >cur menu
    _Highlight drop then
  2drop 2drop ;

: track-menu-place ( --- )
  mh mh_mapped @ if
    mh mh_menuinfo @ >r
    mouse_y @  r@ mi_center_y @ -  _MBorderWidth @ -
    mouse_x @  r@ mi_center_x @ -  _MBorderWidth @ -
    r> mi_w @
    _XMoveWindow drop 2drop
  then ;

\ : wait-for-happening
\    mh mh_menuinfo @ mi_mask @		\ mask
\    ButtonPressed ButtonReleased or dup MouseMoved or	\ bp|br bp|br|mm
\    RootWindow
\    _XSelectInput
\ ." waiting..."
\ _button_event _GetButton drop
\    _button_event _XNextEvent drop
\ ." ...happened!" cr
\    nip _XSelectInput 2drop
\ ;

: get-selection ( event --- )
  begin
    ?pending while
    _button_event _XNextEvent
    xevent_type @ over and if
      drop exit then
  repeat
  ?map-menu
  begin
    update-mouse track-menu
    _button_event _XNextEvent
    xevent_type @ over and until
  drop ;
    
: grab-mouse
    [ ButtonPressed ButtonReleased MouseMoved or or ] literal
    _SliceCursor @
    RootWindow
    _XGrabMouse ret
    0= if cr ." _XGrabMouse lossage." cr quit then
    2drop drop ;

: ungrab-mouse
  _XUngrabMouse ;

: init-mh
    _button_event xevent_window @  mh mh_window !
    _button_event xevent_detail w@
    dup KeyMask mh mh_mask !
    ButtonValue mh mh_button !
    _button_event xevent_x w@  dup mh mh_x !  _MenuCenterX !
    _button_event xevent_y w@  dup mh mh_y !  _MenuCenterY !
    mh mh_cur off
    mh mh_hi_lite off
    mh mh_mapped off
;

100 stack: mh-stack

: push-mh-stack ( menu --- )
  this-mh @ mh-stack push
  this-mh !
  init-mh
;

: pop-mh-stack
  ?unmap-menu
  mh-stack pop this-mh ! ;

: track-release
    ['] track-menu-highlight is track-menu
    ButtonReleased get-selection
    update-mouse-click
    track-menu
;

: track-transition
    ['] track-menu-highlight is track-menu
    ButtonReleased ButtonPressed or get-selection
    update-mouse-click
    track-menu
;

: track-place
    ['] track-menu-place is track-menu
    ButtonPressed get-selection
    update-mouse-click
    track-menu
;

: choose-from-menu ( --- result )
    track-transition

    mh mh_cur @ 0= if
      track-transition then

    mh mh_cur @
    mh mh_func @ execute
    ?unmap-menu
;

: do-menu ( menu --- selection )
  push-mh-stack
  grab-mouse
  choose-from-menu
  ungrab-mouse
  pop-mh-stack
;

: do-place-menu ( menu --- )
  push-mh-stack
  grab-mouse
  track-place
  init-mh
  choose-from-menu
  ungrab-mouse
  pop-mh-stack
;

defer hosts-do-menu
' do-menu is hosts-do-menu
defer hosts-submenus

: do-hosts ( host --- )
  hosts-submenus ?dup if
    hosts-do-menu
    ." Got " . cr
  then
;

: show-choice ( choice --- )
  ." Called menu funcion with: " dup . cr ;

: f.forth
  sp0 @ sp!  rp0 @ rp! 
  cr ." Whammo! You're in Forth, now!" 
  warm ;

: zow
  begin
    _button_event _GetButton 
    xevent_type @ ButtonPressed = until
  _uwm_poop
;

: :case
  create ] does> swap /token * + @ execute ;

defer keymask-dispatch

decimal
: wm
  begin
\    ." Pending " ?pending . 
    begin
      _button_event _GetButton
      xevent_type @ ButtonPressed = until
    _button_event xevent_detail w@ 
    KeyMask 11 >> keymask-dispatch
\    ." ..." cr
  _XFlush
  again
;

defer button-binding

: do-test-menu
  _button_event xevent_detail w@ 
  3 and button-binding do-menu
\  ." Well, Mr. Spock, it looks like the life form chose " . ." ." cr
;

:case test-keymask-dispatch
\	---		SL		SH		SH SL
	do-test-menu	_uwm_poop	do-test-menu 	_uwm_poop
\	M		M SL		M SH		M SH SL
	_uwm_poop	_uwm_poop	_uwm_poop	_uwm_poop
\	C		C SL		C SH		C SH SL
	_uwm_poop	_uwm_poop	_uwm_poop 	_uwm_poop
\	C M		C M SL		C M SH		C M SH SL
	_uwm_poop	_uwm_poop	_uwm_poop	_uwm_poop
;

' test-keymask-dispatch is keymask-dispatch

"" wm.exe save-forth

fload fuwm-init.f