\ Forthmacs menu system using the mouseaction interface as well
\ as the font driver and the screen-block saving/restoring

only forth also definitions
\needs get-mouse-position	??cr .( needs get-mouse-position) abort
\needs save-screen-block	??cr .( needs save-screen-block) abort
terminals also

\needs (lines)			??cr .( video driver must support fonts) abort
24 constant bottom-line
: get-menu-width&height	( menudata -- menudata width height )
	0 0 locals| mheight mwidth menu |
	begin	menu mheight cells+ token@  dup  ['] unnest <>
	while	>name c@  mwidth max is mwidth  mheight 1+ is mheight
	repeat	drop
	menu mwidth mheight ;
: m-color	(fg) azur set-font-colours ;
: menudef ;
: ^^^ ; : ----- ; \ general dummy word
: menu-cfa?	( cfa -- flag )
	locals| cfa | cfa origin main-heap within 0= if false exit then
	cfa >body token@  ['] menudef = ;
: ?mark-menu	( cfa -- cfa )
	dup menu-cfa? if (fg) light-grey set-font-colours then ;
: ?mark-sel	( n1 n2 )
	= if (bg) (fg) set-font-colours then ;
: ?help-text	( menu mheight selected skip )
	locals| selected mheight menu |
	selected 0>=
	if	menu mheight 1+ cells+ selected
		menu -1 cells+ token@  ['] ^^^ = if 1+ then
		0 ?do dup c@ 2+ chars+ aligned loop else nullstring
	then .help-text ;

0 constant menu-output?
: show-menu	( menustructure -- execution-token/0 )
	temp-single true is menu-output? mouse-on
        mouse-server sleep
	cell+ dup c@ over + 2+ aligned	( name menudata )
	dup token@ ['] ^^^ = if cell+ then
	over c@ >r get-menu-width&height swap r> max  0 0 at-xy? (bg) (fg) 0 -1 0 get-cursor-status
	locals| curstat flag selected saveblock fg bg oldy oldx topy leftx mwidth mheight menu name |
	#columns mwidth 2+ -  oldx min is leftx  bottom-line mheight 2+ -   oldy min is topy
	cursor-off  leftx topy at-xy  mwidth 2+ mheight 2+ save-screen-block is saveblock
	begin	leftx topy at-xy m-color space name ". mwidth name c@ - 1+ spaces
		menu mheight selected ?help-text
		mheight 0
		?do	m-color	leftx topy i 1+ + at-xy space
			marked menu i cells+ token@ ?mark-menu
			i selected ?mark-sel
			>name dup c@ swap ".  mwidth swap - spaces m-color space
		loop	leftx topy mheight + 1+ at-xy mwidth 2+ spaces
		fg bg set-font-colours  oldx oldy at-xy
		0 ms flag 0= if begin 0 ms get-mouse-position mouse-button 0= until true is flag then
		-1 is selected  get-mouse-position mouse-x (width) /  leftx 1+ dup mwidth + within
		if	mouse-y (height) /  topy dup mheight + between
			if mouse-y (height) / topy - 1- is selected then
		then
		l-butt? r-butt? or flag and
	until saveblock restore-screen-block curstat set-cursor-status
	multi 100 mouse-server wait 
	false is menu-output? 0 is lasthelp mouse-off
	selected 0< if 0 else  menu selected cells+ token@ then ;

: set-menu-root	( root menu -- )
	>body cell+ dup c@ 2+ chars+ aligned token! ;
: menu:
	blword dup "create  ['] menudef token,  count ", align
		4096 allocate >r 128 allocate r> or abort" can't allocate menu"
		0 locals| mheight menubuf helpbuf | helpbuf 4096 erase
		begin	' dup  ['] ; <>
		while	dup ['] p" <>
			if	menubuf mheight cells+ ! mheight 1+ is mheight
			else	drop [char] " word  helpbuf 128 mheight 1- * chars+ "copy
			then
		repeat	drop
		postpone ^^^
		mheight 0 ?do	menubuf i cells+ @ token, loop
		postpone unnest
		s" up to root menu" ", align
		mheight 0 ?do	helpbuf 128 i * chars+ count ", align loop
		helpbuf free drop  menubuf free drop
	does>	0 locals| item menu |
		['] ^^^ menu set-menu-root				\ define menu as root
		begin	menu show-menu is item  item menu-cfa?
		while	menu item > if menu body> item set-menu-root then
			item >body is menu
		repeat	item ;
