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

foreach pair {{get_widget aux/teach.tcl}} {
  if {[info procs [lindex $pair 0]] == ""} {
    source "[file dirname [info script]]/../[lindex $pair 1]"
}}


# 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 Menu

  Menu Traversal

Select the "Menu Traversal" entry in the Teach menu 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. You can select a menubutton, or its frame; the frame will
receive Tk's standard menu traversal features.

} $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 {} {
  global App Widget Class TH_Dir
  if {![get_widget]} {th_beep ; return}
  if {$Class == "Menubutton"} {
    set Widget [send $App winfo parent $Widget]
  }
  
  if {[set menubuttons [return_menubuttons]] == ""} {th_beep ; return}
  clear_output
  do_cmd "tk_menuBar $Widget $menubuttons\n" 0
  underline_menubutton_labels $menubuttons
  foreach button $menubuttons {
    underline_menuentry_labels [lindex [send $App $button configure -menu] 4]
}}

# Returns the menubuttons descended from w, in a 'decent' order.
proc return_menubuttons {} {
  global App Widget
  set left_result "" ; set right_result ""
  set w $Widget
  while {1} {
    if {$w == $Widget} {
      set w [remote_next_widget $w Menubutton]
    } else {set w [remote_next_widget $w]}
    if {($w == "") || ![string match "$Widget.*" $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 {{w "."} {class ""}} {
  global App
  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 [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 [lindex $children $i] $class]
      }
      incr i
    }
    set w $parent
  }
  return ""
}

# Makes sure each menubutton has a unique underlined character
proc underline_menubutton_labels {menubuttons} {
  global App
  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 "$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 {menu} {
  global App
  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 "$menu entryconfigure $e -underline $i\n" 0
        lappend chars [string index $label $i]
        break
}}}}


catch "destroy .buttons.source"
.buttons.teach.m add command -label "Menu Traversal" -com {teach_menu_traversal}
