share/scripts/_osd_menu.tcl at main · doomsdayone/openmsx

◆ main openmsx / share / scripts / _osd_menu.tcl

18.1 KiB · Tcl · last changed chore(): initial commit 1 month ago source blame history raw

namespace eval osd_menu {

variable menu_z 3

proc get_optional {dict_name key default} {
	upvar $dict_name d
	expr {[dict exists $d $key] ? [dict get $d $key] : $default}
}

proc set_optional {dict_name key value} {
	upvar $dict_name d
	if {![dict exists $d $key]} {
		dict set d $key $value
	}
}

variable menulevels 0
# some variables for typing-in-menus support
variable input_buffer ""
variable input_last_time [openmsx_info realtime]
variable input_timeout 1; #sec

variable controller_capture_timeout 5; #sec
variable controller_capture_after_id ""

variable pool_prefix "pool::"

proc push_menu_info {} {
	variable menulevels
	incr menulevels 1
	set levelname "menuinfo_$menulevels"
	variable $levelname
	set $levelname [uplevel {dict create \
		name $name lst $lst menu_len $menu_len presentation $presentation \
		menutextexpressions $menutextexpressions menutexts $menutexts \
		selectinfo $selectinfo selectidx $selectidx scrollidx \
		$scrollidx on_close $on_close osditems $osditems}]
}

proc peek_menu_info {} {
	variable menulevels
	uplevel upvar #0 osd_menu::menuinfo_$menulevels menuinfo
}

proc set_selectidx {value} {
	peek_menu_info
	dict set menuinfo selectidx $value
}

proc set_scrollidx {value} {
	peek_menu_info
	dict set menuinfo scrollidx $value
}

proc get_current_menu_name {} {
	peek_menu_info
	return [dict get $menuinfo name]
}

proc menu_create {menudef} {
	variable menulevels
	variable default_bg_color
	variable default_text_color
	variable default_select_color
	variable default_header_text_color
	variable menu_z

	set name "menu[expr {$menulevels + 1}]"

	set defactions   [get_optional menudef "actions" ""]
	set bgcolor      [get_optional menudef "bg-color" $default_bg_color]
	set deftextcolor [get_optional menudef "text-color" $default_text_color]
	set selectcolor  [get_optional menudef "select-color" $default_select_color]
	set deffontsize  [get_optional menudef "font-size" 12]
	set deffont      [get_optional menudef "font" "skins/DejaVuSans.ttf.gz"]
	# set default border to 0.5 to avoid content ending up in the outer
	# (black) edge
	set bordersize   [get_optional menudef "border-size" 0.5]
	set on_open      [get_optional menudef "on-open" ""]
	set on_close     [get_optional menudef "on-close" ""]

	osd create rectangle $name -scaled true -rgba $bgcolor -clip true \
		-borderrgba 0x000000ff -bordersize 0.5 -z $menu_z

	set bordersizereduction [expr {-$bordersize*2}]

	# we manage x border for texts by clip rect, y border by position of
	# items
	osd create rectangle $name.clip -x $bordersize -w $bordersizereduction \
		-relw 1 -relh 1 -scaled true -alpha 0 -clip true

	# note that y can non-integer, so we can't use incr on it
	set y $bordersize
	set selectinfo [list]
	set menutextexpressions [list]
	set menutexts [list]
	set osditems [list]
	set itemidx 0
	foreach itemdef [dict get $menudef items] {
		set selectable  [get_optional itemdef "selectable" true]
		set y         [expr {$y + [get_optional itemdef "pre-spacing" 0]}]
		set fontsize    [get_optional itemdef "font-size" $deffontsize]
		set font        [get_optional itemdef "font"      $deffont]
		set textcolor [expr {$selectable
		              ? [get_optional itemdef "text-color" $deftextcolor]
		              : [get_optional itemdef "text-color" $default_header_text_color]}]
		set actions     [get_optional itemdef "actions"     ""]
		set on_select   [get_optional itemdef "on-select"   ""]
		set on_deselect [get_optional itemdef "on-deselect" ""]
		set textid "${name}.clip.item${itemidx}"
		if {[dict exists $itemdef textexpr]} {
			set textexpr [dict get $itemdef textexpr]
			lappend menutextexpressions $textid $textexpr
		} else {
			set text [dict get $itemdef text]
			lappend menutexts $textid $text
		}
		osd create text $textid -font $font -size $fontsize \
					-rgba $textcolor -x 0 -y $y

		lappend osditems $textid

		if {$selectable} {
			set allactions [concat $defactions $actions]
			# NOTE: the 1.5 below is necessary to place the select
			# bar properly vertically... It's unclear why this is
			# necessary and why this emperically determined value
			# is working.
			lappend selectinfo [list [expr {$y+1.5}] $fontsize $allactions $on_select $on_deselect $textid]
		}
		set y [expr {$y + $fontsize}]
		set y [expr {$y + [get_optional itemdef "post-spacing" 0]}]

		incr itemidx
	}

	set width [dict get $menudef width]
	set height [expr {$y + $bordersize}]
	set xpos [get_optional menudef "xpos" [expr {(320 - $width)  / 2}]]
	set ypos [get_optional menudef "ypos" [expr {(240 - $height) / 2}]]
	osd configure $name -x $xpos -y $ypos -w $width -h $height

	osd create rectangle "${name}.selection" -z -1 -rgba $selectcolor \
		-x 0 -w $width

	set lst [get_optional menudef "lst" ""]
	set menu_len [get_optional menudef "menu_len" 0]
	if {[llength $lst] > $menu_len} {
		set startheight 0
		if {[llength $selectinfo] > 0} {
			# there are selectable items. Start the scrollbar
			# at the top of the first selectable item
			# (skipping headers and stuff)
			set startheight [lindex $selectinfo 0 0]
		}
		set scrollbarwidth 6
		osd create rectangle "${name}.scrollbar" -rgba 0x00000010 \
		   -relx 1.0 -x -$scrollbarwidth -w $scrollbarwidth -relh 1.0 -h -$startheight -y $startheight -borderrgba 0x00000070 -bordersize 0.5
		osd create rectangle "${name}.scrollbar.thumb" -rgba $default_select_color \
		   -relw 1.0 -w -2 -x 1
		# Now also reduce the width of the clip area to avoid having
		# text on the scrollbar...
		# For now let's just keep only a fixed 0.5 margin between text
		# and scrollbar at the right size:
		osd configure $name.clip -w [expr {-$bordersize - $scrollbarwidth - 0.5}]
		# Alternatively, keep the bordersize intact at the right side
		# next to the scrollbar:
		# osd configure $name.clip -w [expr {$bordersizereduction - $scrollbarwidth}]
		# Also the select bar shouldn't be on the scrollbar:
		osd configure "${name}.selection" -w [expr {$width - $scrollbarwidth}]
	}
	set presentation [get_optional menudef "presentation" ""]
	set selectidx 0
	set scrollidx 0
	push_menu_info

	uplevel #0 $on_open
	menu_on_select $selectinfo $selectidx

	menu_refresh_top
	menu_update_scrollbar
}

proc menu_update_scrollbar {} {
	peek_menu_info
	set name [dict get $menuinfo name]
	if {[osd exists ${name}.scrollbar]} {
		set menu_len   [dict get $menuinfo menu_len]
		set scrollidx  [dict get $menuinfo scrollidx]
		set selectidx  [dict get $menuinfo selectidx]
		set totalitems [llength [dict get $menuinfo lst]]
		set height [expr {1.0*$menu_len/$totalitems}]
		set minheight 0.05 ;# TODO: derive from width of bar
		set height [expr {$height > $minheight ? $height : $minheight}]
		set pos [expr {1.0*($scrollidx+$selectidx)/($totalitems-1)}]
		# scale the pos to the usable range
		set pos [expr {$pos*(1.0-$height)}]
		osd configure "${name}.scrollbar.thumb" -relh $height -rely $pos
	}
}

proc menu_refresh_top {} {
	peek_menu_info
	foreach {osdid textexpr} [dict get $menuinfo menutextexpressions] {
		set cmd [list subst $textexpr]
		osd configure $osdid -text [uplevel #0 $cmd]
	}
	foreach {osdid text} [dict get $menuinfo menutexts] {
		osd configure $osdid -text $text
	}

	set selectinfo [dict get $menuinfo selectinfo]
	if {[llength $selectinfo] == 0} return
	set selectidx  [dict get $menuinfo selectidx ]
	lassign [lindex $selectinfo $selectidx] sely selh
	osd configure "[dict get $menuinfo name].selection" -y $sely -h $selh
}

proc menu_close_top {} {
	variable menulevels
	peek_menu_info
	menu_on_deselect [dict get $menuinfo selectinfo] [dict get $menuinfo selectidx]
	uplevel #0 [dict get $menuinfo on_close]
	osd destroy [dict get $menuinfo name]
	unset menuinfo
	incr menulevels -1
	if {$menulevels == 0} {
		menu_last_closed
	}
}

proc menu_close_all {} {
	variable menulevels
	while {$menulevels} {
		menu_close_top
	}
}

proc menu_close_until {name} {
	variable menulevels
	while {$menulevels && [get_current_menu_name] != $name} {
		menu_close_top
	}
}

proc menu_setting {cmd_result} {
	menu_refresh_top
}

proc menu_updown {delta} {
	peek_menu_info
	set num [llength [dict get $menuinfo selectinfo]]
	if {$num == 0} return
	set old_idx [dict get $menuinfo selectidx]
	menu_reselect [expr {($old_idx + $delta) % $num}]
}

proc menu_reselect {new_idx} {
	peek_menu_info
	set selectinfo [dict get $menuinfo selectinfo]
	set old_idx [dict get $menuinfo selectidx]
	menu_on_deselect $selectinfo $old_idx
	set_selectidx $new_idx
	menu_on_select $selectinfo $new_idx
	menu_refresh_top
}

proc menu_on_select {selectinfo selectidx} {
	set osd_elem [lindex $selectinfo $selectidx 5]
	if {$osd_elem ne ""} {
		osd configure $osd_elem -scrollSpeed 20 -scrollPauseLeft 1.0 -scrollPauseRight 0.4
	}
	set on_select [lindex $selectinfo $selectidx 3]
	uplevel #0 $on_select
}

proc menu_on_deselect {selectinfo selectidx} {
	set osd_elem [lindex $selectinfo $selectidx 5]
	if {$osd_elem ne ""} {
		osd configure $osd_elem -scrollSpeed 0
	}
	set on_deselect [lindex $selectinfo $selectidx 4]
	uplevel #0 $on_deselect
}

proc menu_action {button} {
	# for any menu action, clear the input buffer
	variable input_buffer
	set input_buffer ""

	peek_menu_info
	set selectidx [dict get $menuinfo selectidx ]
	menu_action_idx $selectidx $button
}
proc menu_action_idx {idx button} {
	peek_menu_info
	set selectinfo [dict get $menuinfo selectinfo]
	set actions [lindex $selectinfo $idx 2]
	set_optional actions UP   {osd_menu::menu_updown -1}
	set_optional actions DOWN {osd_menu::menu_updown  1}
	set_optional actions B    {osd_menu::menu_close_top}
	set cmd [get_optional actions $button ""]
	uplevel #0 $cmd
}

proc get_mouse_coords {} {
	peek_menu_info
	set x 2; set y 2
	catch {
		set name [dict get $menuinfo name]
		lassign [osd info $name -mousecoord] x y
	}
	list $x $y
}
proc menu_get_mouse_idx {xy} {
	lassign $xy x y
	if {$x < 0 || 1 < $x || $y < 0 || 1 < $y} {return -1}

	peek_menu_info
	set name [dict get $menuinfo name]

	set yy [expr {$y * [osd info $name -h]}]
	set sel 0
	foreach i [dict get $menuinfo selectinfo] {
		lassign $i y h actions
		if {($y <= $yy) && ($yy < ($y + $h))} {
			return $sel
		}
		incr sel
	}
	return -1
}
proc menu_mouse_down {} {
	variable mouse_coord
	variable mouse_idx
	set mouse_coord [get_mouse_coords]
	set mouse_idx [menu_get_mouse_idx $mouse_coord]
	if {$mouse_idx != -1} {
		menu_reselect $mouse_idx
	}
}
proc menu_mouse_up {} {
	variable mouse_coord
	variable mouse_idx
	set mouse_coord [get_mouse_coords]
	set mouse_idx [menu_get_mouse_idx $mouse_coord]
	if {$mouse_idx != -1} {
		menu_action_idx $mouse_idx A
	}
	unset mouse_coord
	unset mouse_idx
}
proc menu_mouse_wheel {event} {
	lassign $event type1 type2 x y
	if {$y > 0} {
		osd_menu::menu_action UP
	} elseif {$y < 0} {
		osd_menu::menu_action DOWN
	}
}
proc menu_mouse_motion {} {
	variable mouse_coord
	variable mouse_idx
	if {![info exists mouse_coord]} return

	set new_mouse_coord [get_mouse_coords]
	set new_idx [menu_get_mouse_idx $new_mouse_coord]
	if {$new_idx != -1 && $new_idx != $mouse_idx} {
		menu_reselect $new_idx
		set mouse_coord $new_mouse_coord
		set mouse_idx $new_idx
		return
	}

	if {$mouse_idx != -1} {
		lassign $mouse_coord     old_x old_y
		lassign $new_mouse_coord new_x new_y
		set delta_x [expr {$new_x - $old_x}]
		set delta_y [expr {$new_y - $old_y}]
		if {$delta_y > 0.1} {
			menu_action_idx $mouse_idx DOWN
			set mouse_coord $new_mouse_coord
			return
		} elseif {$delta_y < -0.1} {
			menu_action_idx $mouse_idx UP
			set mouse_coord $new_mouse_coord
			return
		} elseif {$delta_x > 0.1} {
			menu_action_idx $mouse_idx RIGHT
			set mouse_coord $new_mouse_coord
			return
		} elseif {$delta_x < -0.1} {
			menu_action_idx $mouse_idx LEFT
			set mouse_coord $new_mouse_coord
			return
		}
	}
}

proc do_menu_open {top_menu} {
	# close console, because the menu interferes with it
	set ::console off

	# also remove other OSD controlled widgets (like the osd keyboard)
	if {[info exists ::osd_control::close]} {
		eval $::osd_control::close
	}
	# end tell how to close this widget
	namespace eval ::osd_control {set close ::osd_menu::menu_close_all}

	menu_create $top_menu

	set ::pause true
	# TODO make these bindings easier to customize
	bind -layer osd_menu "OSDcontrol UP PRESS"    -repeat {osd_menu::menu_action UP   }
	bind -layer osd_menu "OSDcontrol DOWN PRESS"  -repeat {osd_menu::menu_action DOWN }
	bind -layer osd_menu "OSDcontrol LEFT PRESS"  -repeat {osd_menu::menu_action LEFT }
	bind -layer osd_menu "OSDcontrol RIGHT PRESS" -repeat {osd_menu::menu_action RIGHT}
	bind -layer osd_menu "mouse button1 down" {osd_menu::menu_mouse_down}
	bind -layer osd_menu "mouse button1 up"   {osd_menu::menu_mouse_up}
	bind -layer osd_menu "mouse button3 up"   {osd_menu::menu_close_top}
	bind -layer osd_menu "mouse motion"       {osd_menu::menu_mouse_motion}
	bind -layer osd_menu "mouse wheel" -event {osd_menu::menu_mouse_wheel}
	bind -layer osd_menu "OSDcontrol A PRESS" {osd_menu::menu_action A }
	bind -layer osd_menu "OSDcontrol B PRESS" {osd_menu::menu_action B }
	bind -layer osd_menu "CTRL+UP"      {osd_menu::select_menu_idx 0}
	bind -layer osd_menu "CTRL+LEFT"    {osd_menu::select_menu_idx 0}
	bind -layer osd_menu "keyb HOME"    {osd_menu::select_menu_idx 0}
	set alphanum {a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9 MINUS SHIFT+MINUS}
	foreach char $alphanum {
		bind -layer osd_menu "keyb $char"      "osd_menu::handle_keyboard_input $char"
	}
	activate_input_layer osd_menu -blocking
}

proc menu_last_closed {} {
	set ::pause false
	after realtime 0 {deactivate_input_layer osd_menu}

	namespace eval ::osd_control {unset close}
}

proc prepare_menu_list {lst num menudef} {
	set execute [dict get $menudef execute]
	set header  [dict get $menudef header]
	set item_extra   [get_optional menudef item ""]
	set on_select    [get_optional menudef on-select ""]
	set on_deselect  [get_optional menudef on-deselect ""]
	set presentation [get_optional menudef presentation $lst]
	# 'assert': presentation should have same length as item list!
	if {[llength $presentation] != [llength $lst]} {
		error "Presentation should be of same length as item list!"
	}
	dict set menudef presentation $presentation
	lappend header "selectable" "false"
	set items [list $header]
	set lst_len [llength $lst]
	set menu_len [expr {$lst_len < $num ? $lst_len : $num}]
	for {set i 0} {$i < $menu_len} {incr i} {
		set actions [list "A" "osd_menu::list_menu_item_exec {$execute} $i"]
		if {$i == 0} {
			lappend actions "UP" "osd_menu::move_selection -1"
		}
		if {$i == ($menu_len - 1)} {
			lappend actions "DOWN" "osd_menu::move_selection 1"
		}
		lappend actions "LEFT"  "osd_menu::move_selection -$menu_len"
		lappend actions "RIGHT" "osd_menu::move_selection  $menu_len"
		set item [list "textexpr" "\[osd_menu::list_menu_item_show $i\]" \
		               "actions" $actions]
		if {$on_select ne ""} {
			lappend item "on-select" "osd_menu::list_menu_item_select $i $on_select"
		}
		if {$on_deselect ne ""} {
			lappend item "on-deselect" "osd_menu::list_menu_item_select $i $on_deselect"
		}
		lappend items [concat $item $item_extra]
	}
	dict set menudef items $items
	dict set menudef lst $lst
	dict set menudef menu_len $menu_len
	return $menudef
}

proc list_menu_item_exec {execute pos} {
	peek_menu_info
	{*}$execute [lindex [dict get $menuinfo lst] [expr {$pos + [dict get $menuinfo scrollidx]}]]
}

proc list_menu_item_show {pos} {
	peek_menu_info
	return [lindex [dict get $menuinfo presentation] [expr {$pos + [dict get $menuinfo scrollidx]}]]
}

proc list_menu_item_select {pos select_proc} {
	peek_menu_info
	$select_proc [lindex [dict get $menuinfo lst] [expr {$pos + [dict get $menuinfo scrollidx]}]]
}

proc move_selection {delta} {
	peek_menu_info
	set lst_last [expr {[llength [dict get $menuinfo lst]] - 1}]
	set scrollidx [dict get $menuinfo scrollidx]
	set selectidx [dict get $menuinfo selectidx]

	set old_itemidx [expr {$scrollidx + $selectidx}]
	set new_itemidx [expr {$old_itemidx + $delta}]

	if {$new_itemidx < 0} {
		# Before first element
		if {$old_itemidx == 0} {
			# if first element was already selected, wrap to last
			set new_itemidx $lst_last
		} else {
			# otherwise, clamp to first element
			set new_itemidx 0
		}
	} elseif {$new_itemidx > $lst_last} {
		# After last element
		if {$old_itemidx == $lst_last} {
			# if last element was already selected, wrap to first
			set new_itemidx 0
		} else {
			# otherwise clam to last element
			set new_itemidx $lst_last
		}
	}

	select_menu_idx $new_itemidx
}

proc select_menu_idx {itemidx} {
	peek_menu_info
	set menu_len   [dict get $menuinfo menu_len]
	set scrollidx  [dict get $menuinfo scrollidx]
	set selectidx  [dict get $menuinfo selectidx]
	set selectinfo [dict get $menuinfo selectinfo]

	menu_on_deselect $selectinfo $selectidx

	set selectidx [expr {$itemidx - $scrollidx}]
	if {$selectidx < 0} {
		incr scrollidx $selectidx
		set selectidx 0
	} elseif {($menu_len > 0) && ($selectidx >= $menu_len)} {
		set selectidx [expr {$menu_len - 1}]
		set scrollidx [expr {$itemidx - $selectidx}]
	}

	set_selectidx $selectidx
	set_scrollidx $scrollidx
	menu_on_select $selectinfo $selectidx
	menu_refresh_top
	menu_update_scrollbar
}

proc select_menu_item {item} {
	peek_menu_info

	set index [lsearch -exact [dict get $menuinfo lst] $item]
	if {$index == -1} return

	select_menu_idx $index
}

proc handle_keyboard_input {char} {
	variable input_buffer
	variable input_last_time
	variable input_timeout

	if {$char eq "MINUS"} {
		set char "-"
	} elseif {$char eq "SHIFT+MINUS"} {
		set char "_"
	}

	set current_time [openmsx_info realtime]
	if {[expr {$current_time - $input_last_time}] < $input_timeout} {
		set input_buffer "$input_buffer$char"
	} else {
		set input_buffer $char
	}
	set input_last_time $current_time

	osd_menu::select_next_menu_item_starting_with $input_buffer
}

proc select_next_menu_item_starting_with {text} {
	peek_menu_info

	set items [dict get $menuinfo presentation]
	if {[llength $items] == 0} return

	set selectidx [dict get $menuinfo selectidx]
	set scrollidx [dict get $menuinfo scrollidx]
	set itemidx [expr {$scrollidx + $selectidx}]

	# start after the current item if this is a new search
	if {[string length $text] == 1} {
		incr itemidx
	}
	# use the list twice to wrap
	set index [lsearch -glob -nocase -start $itemidx [concat $items $items] "$text*"]
	if {$index == -1} return
	set index [expr {$index % [llength $items]}]

	select_menu_idx $index
}

} ;# namespace osd_menu

`/`	Search
`g` `c`	Code
`g` `h`	History
`g` `b`	Bookmarks
`g` `t`	Trust
`y`	Permalink to this state (files and trees)
`?`	This sheet

e8555c89 Andy McCall 1 month ago	1	namespace eval osd_menu {
	2
	3	variable menu_z 3
	4
	5	proc get_optional {dict_name key default} {
	6	upvar $dict_name d
	7	expr {[dict exists $d $key] ? [dict get $d $key] : $default}
	8	}
	9
	10	proc set_optional {dict_name key value} {
	11	upvar $dict_name d
	12	if {![dict exists $d $key]} {
	13	dict set d $key $value
	14	}
	15	}
	16
	17	variable menulevels 0
	18	# some variables for typing-in-menus support
	19	variable input_buffer ""
	20	variable input_last_time [openmsx_info realtime]
	21	variable input_timeout 1; #sec
	22
	23	variable controller_capture_timeout 5; #sec
	24	variable controller_capture_after_id ""
	25
	26	variable pool_prefix "pool::"
	27
	28	proc push_menu_info {} {
	29	variable menulevels
	30	incr menulevels 1
	31	set levelname "menuinfo_$menulevels"
	32	variable $levelname
	33	set $levelname [uplevel {dict create \
	34	name $name lst $lst menu_len $menu_len presentation $presentation \
	35	menutextexpressions $menutextexpressions menutexts $menutexts \
	36	selectinfo $selectinfo selectidx $selectidx scrollidx \
	37	$scrollidx on_close $on_close osditems $osditems}]
	38	}
	39
	40	proc peek_menu_info {} {
	41	variable menulevels
	42	uplevel upvar #0 osd_menu::menuinfo_$menulevels menuinfo
	43	}
	44
	45	proc set_selectidx {value} {
	46	peek_menu_info
	47	dict set menuinfo selectidx $value
	48	}
	49
	50	proc set_scrollidx {value} {
	51	peek_menu_info
	52	dict set menuinfo scrollidx $value
	53	}
	54
	55	proc get_current_menu_name {} {
	56	peek_menu_info
	57	return [dict get $menuinfo name]
	58	}
	59
	60	proc menu_create {menudef} {
	61	variable menulevels
	62	variable default_bg_color
	63	variable default_text_color
	64	variable default_select_color
65	variable default_header_text_color
66	variable menu_z
67
68	set name "menu[expr {$menulevels + 1}]"
69
70	set defactions [get_optional menudef "actions" ""]
71	set bgcolor [get_optional menudef "bg-color" $default_bg_color]
72	set deftextcolor [get_optional menudef "text-color" $default_text_color]
73	set selectcolor [get_optional menudef "select-color" $default_select_color]
74	set deffontsize [get_optional menudef "font-size" 12]
75	set deffont [get_optional menudef "font" "skins/DejaVuSans.ttf.gz"]
76	# set default border to 0.5 to avoid content ending up in the outer
77	# (black) edge
78	set bordersize [get_optional menudef "border-size" 0.5]
79	set on_open [get_optional menudef "on-open" ""]
80	set on_close [get_optional menudef "on-close" ""]
81
82	osd create rectangle $name -scaled true -rgba $bgcolor -clip true \
83	-borderrgba 0x000000ff -bordersize 0.5 -z $menu_z
84
85	set bordersizereduction [expr {-$bordersize*2}]
86
87	# we manage x border for texts by clip rect, y border by position of
88	# items
89	osd create rectangle $name.clip -x $bordersize -w $bordersizereduction \
90	-relw 1 -relh 1 -scaled true -alpha 0 -clip true
91
92	# note that y can non-integer, so we can't use incr on it
93	set y $bordersize
94	set selectinfo [list]
95	set menutextexpressions [list]
96	set menutexts [list]
97	set osditems [list]
98	set itemidx 0
99	foreach itemdef [dict get $menudef items] {
100	set selectable [get_optional itemdef "selectable" true]
101	set y [expr {$y + [get_optional itemdef "pre-spacing" 0]}]
102	set fontsize [get_optional itemdef "font-size" $deffontsize]
103	set font [get_optional itemdef "font" $deffont]
104	set textcolor [expr {$selectable
105	? [get_optional itemdef "text-color" $deftextcolor]
106	: [get_optional itemdef "text-color" $default_header_text_color]}]
107	set actions [get_optional itemdef "actions" ""]
108	set on_select [get_optional itemdef "on-select" ""]
109	set on_deselect [get_optional itemdef "on-deselect" ""]
110	set textid "${name}.clip.item${itemidx}"
111	if {[dict exists $itemdef textexpr]} {
112	set textexpr [dict get $itemdef textexpr]
113	lappend menutextexpressions $textid $textexpr
114	} else {
115	set text [dict get $itemdef text]
116	lappend menutexts $textid $text
117	}
118	osd create text $textid -font $font -size $fontsize \
119	-rgba $textcolor -x 0 -y $y
120
121	lappend osditems $textid
122
123	if {$selectable} {
124	set allactions [concat $defactions $actions]
125	# NOTE: the 1.5 below is necessary to place the select
126	# bar properly vertically... It's unclear why this is
127	# necessary and why this emperically determined value
128	# is working.
129	lappend selectinfo [list [expr {$y+1.5}] $fontsize $allactions $on_select $on_deselect $textid]
130	}
131	set y [expr {$y + $fontsize}]
132	set y [expr {$y + [get_optional itemdef "post-spacing" 0]}]
133
134	incr itemidx
135	}
136
137	set width [dict get $menudef width]
138	set height [expr {$y + $bordersize}]
139	set xpos [get_optional menudef "xpos" [expr {(320 - $width) / 2}]]
140	set ypos [get_optional menudef "ypos" [expr {(240 - $height) / 2}]]
141	osd configure $name -x $xpos -y $ypos -w $width -h $height
142
143	osd create rectangle "${name}.selection" -z -1 -rgba $selectcolor \
144	-x 0 -w $width
145
146	set lst [get_optional menudef "lst" ""]
147	set menu_len [get_optional menudef "menu_len" 0]
148	if {[llength $lst] > $menu_len} {
149	set startheight 0
150	if {[llength $selectinfo] > 0} {
151	# there are selectable items. Start the scrollbar
152	# at the top of the first selectable item
153	# (skipping headers and stuff)
154	set startheight [lindex $selectinfo 0 0]
155	}
156	set scrollbarwidth 6
157	osd create rectangle "${name}.scrollbar" -rgba 0x00000010 \
158	-relx 1.0 -x -$scrollbarwidth -w $scrollbarwidth -relh 1.0 -h -$startheight -y $startheight -borderrgba 0x00000070 -bordersize 0.5
159	osd create rectangle "${name}.scrollbar.thumb" -rgba $default_select_color \
160	-relw 1.0 -w -2 -x 1
161	# Now also reduce the width of the clip area to avoid having
162	# text on the scrollbar...
163	# For now let's just keep only a fixed 0.5 margin between text
164	# and scrollbar at the right size:
165	osd configure $name.clip -w [expr {-$bordersize - $scrollbarwidth - 0.5}]
166	# Alternatively, keep the bordersize intact at the right side
167	# next to the scrollbar:
168	# osd configure $name.clip -w [expr {$bordersizereduction - $scrollbarwidth}]
169	# Also the select bar shouldn't be on the scrollbar:
170	osd configure "${name}.selection" -w [expr {$width - $scrollbarwidth}]
171	}
172	set presentation [get_optional menudef "presentation" ""]
173	set selectidx 0
174	set scrollidx 0
175	push_menu_info
176
177	uplevel #0 $on_open
178	menu_on_select $selectinfo $selectidx
179
180	menu_refresh_top
181	menu_update_scrollbar
182	}
183
184	proc menu_update_scrollbar {} {
185	peek_menu_info
186	set name [dict get $menuinfo name]
187	if {[osd exists ${name}.scrollbar]} {
188	set menu_len [dict get $menuinfo menu_len]
189	set scrollidx [dict get $menuinfo scrollidx]
190	set selectidx [dict get $menuinfo selectidx]
191	set totalitems [llength [dict get $menuinfo lst]]
192	set height [expr {1.0*$menu_len/$totalitems}]
193	set minheight 0.05 ;# TODO: derive from width of bar
194	set height [expr {$height > $minheight ? $height : $minheight}]
195	set pos [expr {1.0*($scrollidx+$selectidx)/($totalitems-1)}]
196	# scale the pos to the usable range
197	set pos [expr {$pos*(1.0-$height)}]
198	osd configure "${name}.scrollbar.thumb" -relh $height -rely $pos
199	}
200	}
201
202	proc menu_refresh_top {} {
203	peek_menu_info
204	foreach {osdid textexpr} [dict get $menuinfo menutextexpressions] {
205	set cmd [list subst $textexpr]
206	osd configure $osdid -text [uplevel #0 $cmd]
207	}
208	foreach {osdid text} [dict get $menuinfo menutexts] {
209	osd configure $osdid -text $text
210	}
211
212	set selectinfo [dict get $menuinfo selectinfo]
213	if {[llength $selectinfo] == 0} return
214	set selectidx [dict get $menuinfo selectidx ]
215	lassign [lindex $selectinfo $selectidx] sely selh
216	osd configure "[dict get $menuinfo name].selection" -y $sely -h $selh
217	}
218
219	proc menu_close_top {} {
220	variable menulevels
221	peek_menu_info
222	menu_on_deselect [dict get $menuinfo selectinfo] [dict get $menuinfo selectidx]
223	uplevel #0 [dict get $menuinfo on_close]
224	osd destroy [dict get $menuinfo name]
225	unset menuinfo
226	incr menulevels -1
227	if {$menulevels == 0} {
228	menu_last_closed
229	}
230	}
231
232	proc menu_close_all {} {
233	variable menulevels
234	while {$menulevels} {
235	menu_close_top
236	}
237	}
238
239	proc menu_close_until {name} {
240	variable menulevels
241	while {$menulevels && [get_current_menu_name] != $name} {
242	menu_close_top
243	}
244	}
245
246	proc menu_setting {cmd_result} {
247	menu_refresh_top
248	}
249
250	proc menu_updown {delta} {
251	peek_menu_info
252	set num [llength [dict get $menuinfo selectinfo]]
253	if {$num == 0} return
254	set old_idx [dict get $menuinfo selectidx]
255	menu_reselect [expr {($old_idx + $delta) % $num}]
256	}
257
258	proc menu_reselect {new_idx} {
259	peek_menu_info
260	set selectinfo [dict get $menuinfo selectinfo]
261	set old_idx [dict get $menuinfo selectidx]
262	menu_on_deselect $selectinfo $old_idx
263	set_selectidx $new_idx
264	menu_on_select $selectinfo $new_idx
265	menu_refresh_top
266	}
267
268	proc menu_on_select {selectinfo selectidx} {
269	set osd_elem [lindex $selectinfo $selectidx 5]
270	if {$osd_elem ne ""} {
271	osd configure $osd_elem -scrollSpeed 20 -scrollPauseLeft 1.0 -scrollPauseRight 0.4
272	}
273	set on_select [lindex $selectinfo $selectidx 3]
274	uplevel #0 $on_select
275	}
276
277	proc menu_on_deselect {selectinfo selectidx} {
278	set osd_elem [lindex $selectinfo $selectidx 5]
279	if {$osd_elem ne ""} {
280	osd configure $osd_elem -scrollSpeed 0
281	}
282	set on_deselect [lindex $selectinfo $selectidx 4]
283	uplevel #0 $on_deselect
284	}
285
286	proc menu_action {button} {
287	# for any menu action, clear the input buffer
288	variable input_buffer
289	set input_buffer ""
290
291	peek_menu_info
292	set selectidx [dict get $menuinfo selectidx ]
293	menu_action_idx $selectidx $button
294	}
295	proc menu_action_idx {idx button} {
296	peek_menu_info
297	set selectinfo [dict get $menuinfo selectinfo]
298	set actions [lindex $selectinfo $idx 2]
299	set_optional actions UP {osd_menu::menu_updown -1}
300	set_optional actions DOWN {osd_menu::menu_updown 1}
301	set_optional actions B {osd_menu::menu_close_top}
302	set cmd [get_optional actions $button ""]
303	uplevel #0 $cmd
304	}
305
306	proc get_mouse_coords {} {
307	peek_menu_info
308	set x 2; set y 2
309	catch {
310	set name [dict get $menuinfo name]
311	lassign [osd info $name -mousecoord] x y
312	}
313	list $x $y
314	}
315	proc menu_get_mouse_idx {xy} {
316	lassign $xy x y
317	if {$x < 0 \|\| 1 < $x \|\| $y < 0 \|\| 1 < $y} {return -1}
318
319	peek_menu_info
320	set name [dict get $menuinfo name]
321
322	set yy [expr {$y * [osd info $name -h]}]
323	set sel 0
324	foreach i [dict get $menuinfo selectinfo] {
325	lassign $i y h actions
326	if {($y <= $yy) && ($yy < ($y + $h))} {
327	return $sel
328	}
329	incr sel
330	}
331	return -1
332	}
333	proc menu_mouse_down {} {
334	variable mouse_coord
335	variable mouse_idx
336	set mouse_coord [get_mouse_coords]
337	set mouse_idx [menu_get_mouse_idx $mouse_coord]
338	if {$mouse_idx != -1} {
339	menu_reselect $mouse_idx
340	}
341	}
342	proc menu_mouse_up {} {
343	variable mouse_coord
344	variable mouse_idx
345	set mouse_coord [get_mouse_coords]
346	set mouse_idx [menu_get_mouse_idx $mouse_coord]
347	if {$mouse_idx != -1} {
348	menu_action_idx $mouse_idx A
349	}
350	unset mouse_coord
351	unset mouse_idx
352	}
353	proc menu_mouse_wheel {event} {
354	lassign $event type1 type2 x y
355	if {$y > 0} {
356	osd_menu::menu_action UP
357	} elseif {$y < 0} {
358	osd_menu::menu_action DOWN
359	}
360	}
361	proc menu_mouse_motion {} {
362	variable mouse_coord
363	variable mouse_idx
364	if {![info exists mouse_coord]} return
365
366	set new_mouse_coord [get_mouse_coords]
367	set new_idx [menu_get_mouse_idx $new_mouse_coord]
368	if {$new_idx != -1 && $new_idx != $mouse_idx} {
369	menu_reselect $new_idx
370	set mouse_coord $new_mouse_coord
371	set mouse_idx $new_idx
372	return
373	}
374
375	if {$mouse_idx != -1} {
376	lassign $mouse_coord old_x old_y
377	lassign $new_mouse_coord new_x new_y
378	set delta_x [expr {$new_x - $old_x}]
379	set delta_y [expr {$new_y - $old_y}]
380	if {$delta_y > 0.1} {
381	menu_action_idx $mouse_idx DOWN
382	set mouse_coord $new_mouse_coord
383	return
384	} elseif {$delta_y < -0.1} {
385	menu_action_idx $mouse_idx UP
386	set mouse_coord $new_mouse_coord
387	return
388	} elseif {$delta_x > 0.1} {
389	menu_action_idx $mouse_idx RIGHT
390	set mouse_coord $new_mouse_coord
391	return
392	} elseif {$delta_x < -0.1} {
393	menu_action_idx $mouse_idx LEFT
394	set mouse_coord $new_mouse_coord
395	return
396	}
397	}
398	}
399
400	proc do_menu_open {top_menu} {
401	# close console, because the menu interferes with it
402	set ::console off
403
404	# also remove other OSD controlled widgets (like the osd keyboard)
405	if {[info exists ::osd_control::close]} {
406	eval $::osd_control::close
407	}
408	# end tell how to close this widget
409	namespace eval ::osd_control {set close ::osd_menu::menu_close_all}
410
411	menu_create $top_menu
412
413	set ::pause true
414	# TODO make these bindings easier to customize
415	bind -layer osd_menu "OSDcontrol UP PRESS" -repeat {osd_menu::menu_action UP }
416	bind -layer osd_menu "OSDcontrol DOWN PRESS" -repeat {osd_menu::menu_action DOWN }
417	bind -layer osd_menu "OSDcontrol LEFT PRESS" -repeat {osd_menu::menu_action LEFT }
418	bind -layer osd_menu "OSDcontrol RIGHT PRESS" -repeat {osd_menu::menu_action RIGHT}
419	bind -layer osd_menu "mouse button1 down" {osd_menu::menu_mouse_down}
420	bind -layer osd_menu "mouse button1 up" {osd_menu::menu_mouse_up}
421	bind -layer osd_menu "mouse button3 up" {osd_menu::menu_close_top}
422	bind -layer osd_menu "mouse motion" {osd_menu::menu_mouse_motion}
423	bind -layer osd_menu "mouse wheel" -event {osd_menu::menu_mouse_wheel}
424	bind -layer osd_menu "OSDcontrol A PRESS" {osd_menu::menu_action A }
425	bind -layer osd_menu "OSDcontrol B PRESS" {osd_menu::menu_action B }
426	bind -layer osd_menu "CTRL+UP" {osd_menu::select_menu_idx 0}
427	bind -layer osd_menu "CTRL+LEFT" {osd_menu::select_menu_idx 0}
428	bind -layer osd_menu "keyb HOME" {osd_menu::select_menu_idx 0}
429	set alphanum {a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9 MINUS SHIFT+MINUS}
430	foreach char $alphanum {
431	bind -layer osd_menu "keyb $char" "osd_menu::handle_keyboard_input $char"
432	}
433	activate_input_layer osd_menu -blocking
434	}
435
436	proc menu_last_closed {} {
437	set ::pause false
438	after realtime 0 {deactivate_input_layer osd_menu}
439
440	namespace eval ::osd_control {unset close}
441	}
442
443	proc prepare_menu_list {lst num menudef} {
444	set execute [dict get $menudef execute]
445	set header [dict get $menudef header]
446	set item_extra [get_optional menudef item ""]
447	set on_select [get_optional menudef on-select ""]
448	set on_deselect [get_optional menudef on-deselect ""]
449	set presentation [get_optional menudef presentation $lst]
450	# 'assert': presentation should have same length as item list!
451	if {[llength $presentation] != [llength $lst]} {
452	error "Presentation should be of same length as item list!"
453	}
454	dict set menudef presentation $presentation
455	lappend header "selectable" "false"
456	set items [list $header]
457	set lst_len [llength $lst]
458	set menu_len [expr {$lst_len < $num ? $lst_len : $num}]
459	for {set i 0} {$i < $menu_len} {incr i} {
460	set actions [list "A" "osd_menu::list_menu_item_exec {$execute} $i"]
461	if {$i == 0} {
462	lappend actions "UP" "osd_menu::move_selection -1"
463	}
464	if {$i == ($menu_len - 1)} {
465	lappend actions "DOWN" "osd_menu::move_selection 1"
466	}
467	lappend actions "LEFT" "osd_menu::move_selection -$menu_len"
468	lappend actions "RIGHT" "osd_menu::move_selection $menu_len"
469	set item [list "textexpr" "\[osd_menu::list_menu_item_show $i\]" \
470	"actions" $actions]
471	if {$on_select ne ""} {
472	lappend item "on-select" "osd_menu::list_menu_item_select $i $on_select"
473	}
474	if {$on_deselect ne ""} {
475	lappend item "on-deselect" "osd_menu::list_menu_item_select $i $on_deselect"
476	}
477	lappend items [concat $item $item_extra]
478	}
479	dict set menudef items $items
480	dict set menudef lst $lst
481	dict set menudef menu_len $menu_len
482	return $menudef
483	}
484
485	proc list_menu_item_exec {execute pos} {
486	peek_menu_info
487	{*}$execute [lindex [dict get $menuinfo lst] [expr {$pos + [dict get $menuinfo scrollidx]}]]
488	}
489
490	proc list_menu_item_show {pos} {
491	peek_menu_info
492	return [lindex [dict get $menuinfo presentation] [expr {$pos + [dict get $menuinfo scrollidx]}]]
493	}
494
495	proc list_menu_item_select {pos select_proc} {
496	peek_menu_info
497	$select_proc [lindex [dict get $menuinfo lst] [expr {$pos + [dict get $menuinfo scrollidx]}]]
498	}
499
500	proc move_selection {delta} {
501	peek_menu_info
502	set lst_last [expr {[llength [dict get $menuinfo lst]] - 1}]
503	set scrollidx [dict get $menuinfo scrollidx]
504	set selectidx [dict get $menuinfo selectidx]
505
506	set old_itemidx [expr {$scrollidx + $selectidx}]
507	set new_itemidx [expr {$old_itemidx + $delta}]
508
509	if {$new_itemidx < 0} {
510	# Before first element
511	if {$old_itemidx == 0} {
512	# if first element was already selected, wrap to last
513	set new_itemidx $lst_last
514	} else {
515	# otherwise, clamp to first element
516	set new_itemidx 0
517	}
518	} elseif {$new_itemidx > $lst_last} {
519	# After last element
520	if {$old_itemidx == $lst_last} {
521	# if last element was already selected, wrap to first
522	set new_itemidx 0
523	} else {
524	# otherwise clam to last element
525	set new_itemidx $lst_last
526	}
527	}
528
529	select_menu_idx $new_itemidx
530	}
531
532	proc select_menu_idx {itemidx} {
533	peek_menu_info
534	set menu_len [dict get $menuinfo menu_len]
535	set scrollidx [dict get $menuinfo scrollidx]
536	set selectidx [dict get $menuinfo selectidx]
537	set selectinfo [dict get $menuinfo selectinfo]
538
539	menu_on_deselect $selectinfo $selectidx
540
541	set selectidx [expr {$itemidx - $scrollidx}]
542	if {$selectidx < 0} {
543	incr scrollidx $selectidx
544	set selectidx 0
545	} elseif {($menu_len > 0) && ($selectidx >= $menu_len)} {
546	set selectidx [expr {$menu_len - 1}]
547	set scrollidx [expr {$itemidx - $selectidx}]
548	}
549
550	set_selectidx $selectidx
551	set_scrollidx $scrollidx
552	menu_on_select $selectinfo $selectidx
553	menu_refresh_top
554	menu_update_scrollbar
555	}
556
557	proc select_menu_item {item} {
558	peek_menu_info
559
560	set index [lsearch -exact [dict get $menuinfo lst] $item]
561	if {$index == -1} return
562
563	select_menu_idx $index
564	}
565
566	proc handle_keyboard_input {char} {
567	variable input_buffer
568	variable input_last_time
569	variable input_timeout
570
571	if {$char eq "MINUS"} {
572	set char "-"
573	} elseif {$char eq "SHIFT+MINUS"} {
574	set char "_"
575	}
576
577	set current_time [openmsx_info realtime]
578	if {[expr {$current_time - $input_last_time}] < $input_timeout} {
579	set input_buffer "$input_buffer$char"
580	} else {
581	set input_buffer $char
582	}
583	set input_last_time $current_time
584
585	osd_menu::select_next_menu_item_starting_with $input_buffer
586	}
587
588	proc select_next_menu_item_starting_with {text} {
589	peek_menu_info
590
591	set items [dict get $menuinfo presentation]
592	if {[llength $items] == 0} return
593
594	set selectidx [dict get $menuinfo selectidx]
595	set scrollidx [dict get $menuinfo scrollidx]
596	set itemidx [expr {$scrollidx + $selectidx}]
597
598	# start after the current item if this is a new search
599	if {[string length $text] == 1} {
600	incr itemidx
601	}
602	# use the list twice to wrap
603	set index [lsearch -glob -nocase -start $itemidx [concat $items $items] "$text*"]
604	if {$index == -1} return
605	set index [expr {$index % [llength $items]}]
606
607	select_menu_idx $index
608	}
609
610	} ;# namespace osd_menu

Keyboard