#----------------------------------------------------------------
 # popups.tcl
 #----------------------------------------------------------------
 # Created by William J Giddings, 2005.
 #
 # Description:
 # -----------
 # In automating the conversion of Chinese hanzi into roman pinyin, 
 # a single character may a have number of variant pronunciations. 
 # Rather than including all the available choices in the displayed output
 # the first item in the list is offered, the text tagged with a unique 
 # id and the alternatives are then used to create selectable items in a popup-menu. 
 # Access to the menu occurs when a <Button-3> event occurs over the tagged text. 
 # Should one of the menu items be selected, the currently displayed 
 # word is replaced with the new choice. 
 #
 # Usage:
 # -----
 # See demo proc for example 
 #----------------------------------------------------------------

 namespace eval popup {
  set cursor ""   ;# store default widget cursor during rollovers
 }

 #----------------------------------------------------------------
 # create menu (m) with from list of supplied items (a) 
 #----------------------------------------------------------------
 proc popup::create {m a} {
  # destroy any pre-exising menu with the same name
  destroy $m

  # create new menus
  menu $m -tearoff 0  
  foreach i $a {
    $m add command -label $i -command "popup::swap $m $i" 
  }
  popup::config [winfo parent $m] $m
 }

 #----------------------------------------------------------------
 # display the popup menu adjacent to the current pointer location
 #----------------------------------------------------------------
 proc popup::show {m} {
  set w [winfo parent $m]
  lassign [winfo pointerxy $w] x y
  set ::active(tag) $m
  #get active ta
  tk_popup $m $x $y
 }  
 
 #----------------------------------------------------------------
 # swap text displayed in the text widget with the selected menu item
 #----------------------------------------------------------------
 proc popup::swap {m i} {

  # get ranges of tag $m
  lassign [[winfo parent $m] tag ranges $m] from to
  # swap range content for $i
  
  [winfo parent $m] delete $from $to
  [winfo parent $m] insert $from "$i " $m
  
 }

 #----------------------------------------------------------------
 # configure tag display options and bindings
 #----------------------------------------------------------------
 proc popup::config {path name} {

  $path tag configure $name -foreground red
  
  $path tag bind $name <Button-3> "popup::show $name"
  
  $path tag bind $name <Enter> {
      set popup::cursor [%W cget -cursor]
      %W configure -cursor arrow
      } 
  
  $path tag bind $name <Leave> {
      %W configure -cursor $popup::cursor
      } 
 }

 #----------------------------------------------------------------
 # the ubiquitous demo
 #----------------------------------------------------------------
 proc demo {} {

  package require Tk
  # build simple GUI
  text .txt -font {Palatino 12}
  pack .txt -fill both -expand 1
  focus .txt
 
  # A few examples 
  .txt insert insert "A demonstration of alternatives.\nSimply click Button-3 over a red word for a popup menu of choices.\n"
  
  # Step 1) add some tagged words 
  .txt insert insert "Fruit " .txt.menu_1
  # Step 2) build a list of alternatives
  set menuitems(1) [list Apple Bannana Cherry Damson Elder]
  # Step 3) create popup
  popup::create .txt.menu_1 $menuitems(1) 
  
  # just a few other entries for company....
  .txt insert insert "Trees " .txt.menu_2
   set menuitems(2) [list Ash Birch Chestnut ]
  popup::create .txt.menu_2 $menuitems(2)
   
  .txt insert insert "Birds " .txt.menu_3
  set menuitems(3) [list Blue-Tit Great-Tit Coal-Tit Robin]
  popup::create .txt.menu_3 $menuitems(3)

 }

 demo