#!/afs/ece/usr/tcl/bin/wish -f

source "[file dirname [info script]]/../aux/teach.tcl"

# Help text.

set Help "" ; append Help {Menutraverseth -- Add Tk traversal bindings to menus

This program endows a set of Tk menus with Tk's menu traversal functions. For
more information on menu traversal, see the Tk menubar manpage. Given a frame
in which several menubuttons reside, menutraverseth calls the tk_menuBar
procedure on the menubuttons. It also underlines one unique character in each
menubutton, if that button doesn't already have an underlined character, and it
underlines one unique character for each menuentry that has no underlined
character.


Widgets of Menutraverseth

The Teach Button

Click on Teach to select a 'menubar'. While teaching, the cursor changes to a
cross, and all mouseclicks get shunted to menutraverseth. Menutraverseth takes a
'menubar' as input, that is, a frame that contains menubuttons. Clicking button
1 on a frame selects that frame, clicking button 1 on a menubutton selects the
frame that button lives in, and clicking button 2 on a widget selects that
widget's parent, and clicking button 3 on a widget selects that widget's
grandparent.

} $TH_Help {

Bugs / Limitations

None
I hope!
}

## A slight modification of the focus code.

# Executes the pack command over a widget
proc teach_menu_traversal {x y b} {
  toggle_grab
  if {![which_widget $x $y $b app widget]} {th_beep ; return}
  if {[send $app winfo class $widget] == "Menubutton"} {
    set widget [send $app winfo parent $widget]
  }
  set menubuttons [return_menubuttons $app $widget]
  if {$menubuttons == ""} {th_beep ; return}
  clear_output
  do_cmd $app "tk_menuBar $widget $menubuttons\n" 0
  underline_menubutton_labels $app $menubuttons
  foreach button $menubuttons {
    underline_menuentry_labels $app [lindex [send $app $button configure -menu] 4]
}}

# Returns the menubuttons descended from w, in a 'decent' order.
proc return_menubuttons {app menubar} {
  set left_result "" ; set right_result ""
  set w $menubar
  while {1} {
    if {$w == $menubar} {
      set w [remote_next_widget $app $w Menubutton]
    } else {set w [remote_next_widget $app $w]}
    if {($w == "") || ![string match "$menubar.*" $w]} {
      return [concat $left_result $right_result]}

# Which side does w go on?
    set packinfo [send $app pack newinfo $w]
    set i [lsearch $packinfo "-side"] ; incr i
    set side [lindex $packinfo $i]
    if {($side == "right") || ($side == "bottom")} {
      set right_result "$right_result $w"
    } else {lappend left_result $w
}}}

# Searches the window hierarchy for a widget of appropriate class that
# follows w. If class is unspecified, it becomes w's class.
proc remote_next_widget {app {w "."} {class ""}} {
  if {$class == ""} {set class [send $app winfo class $w]
  } elseif {[send $app winfo class $w] == $class} {
# Widget must be packed and not disabled.
    if {([catch "send $app $w configure -state" result] || \
        ([lindex $result 4] != "disabled")) && [send $app winfo ismapped $w]} {
           return $w}}

  set children [send $app winfo children $w]
  if {$children != ""} { return [remote_next_widget $app [lindex $children 0] $class]}

  while {$w != "."} {
    set parent [send $app winfo parent $w]
    set children [send $app winfo children $parent]
    set i [lsearch $children $w] ; incr i
    set l [llength $children]
    while {$i != $l} {
      set child [lindex $children $i]
      if {([send $app winfo class $child] == "Toplevel") ||
          ([lsearch [send $app pack slaves $parent] $child] >= 0)} {
        return [remote_next_widget $app [lindex $children $i] $class]
      }
      incr i
    }
    set w $parent
  }
  return ""
}

# Makes sure each menubutton has a unique underlined character
proc underline_menubutton_labels {app menubuttons} {
  set chars ""

# First, get all the chars that are underlined.
  foreach mb $menubuttons {
    if {![catch "send \"$app\" $mb configure -text" result]} {
      set char [string index [lindex $result 4] \
		[lindex [send $app $mb configure -underline] 4]]
      if {$char != ""} {lappend chars $char}}}
  set chars [string toupper $chars]

# Now, assign chars that aren't used to entries w/o underlined chars.
  foreach mb $menubuttons {
    if {[catch "send \"$app\" $mb configure -underline" result]} {continue}
    if {[lindex $result 4] != -1} {continue}
    set label [string toupper [lindex [send $app $mb configure -text] 4]]
    set l [string length $label]
    for {set i 0} {$i < $l} {incr i} {
      if {[lsearch $chars [string index $label $i]] == -1} {
        do_cmd $app "$mb configure -underline $i\n" 0
        lappend chars [string index $label $i]
        break
}}}}

# Makes sure each menuentry has a unique underlined character
proc underline_menuentry_labels {app menu} {
  set chars ""
  set entries [send $app $menu index last]

# First, get all the chars that are underlined.
  for {set e 0} {$e <= $entries} {incr e} {
    if {![catch "send \"$app\" $menu entryconfigure $e -label" result]} {
      set char [string index [lindex $result 4] \
		[lindex [send $app $menu entryconfigure $e -underline] 4]]
      if {$char != ""} {lappend chars $char}}}
  set chars [string toupper $chars]
# Now, assign chars that aren't used to entries w/o underlined chars.
  for {set e 0} {$e <= $entries} {incr e} {
    if {[catch "send \"$app\" $menu entryconfigure $e -underline" result]} {continue}
    if {[lindex $result 4] != -1} {continue}
    set label [string toupper [lindex [send $app $menu entryconfigure $e -label] 4]]
    set l [string length $label]
    for {set i 0} {$i < $l} {incr i} {
      if {[lsearch $chars [string index $label $i]] == -1} {
        do_cmd $app "$menu entryconfigure $e -underline $i\n" 0
        lappend chars [string index $label $i]
        break
}}}}


catch "destroy .buttons.source"

# These bindings only should take effect when packeth does a global grab.
bind all <Any-Button>			"teach_menu_traversal %X %Y %b"
