# joptionbutton.tcl - one-of-many choice button with popup list
#
######################################################################
# Copyright 1992-1995 by Jay Sekora.  This file may be freely        #
# distributed, modified or unmodified, for any purpose, provided     #
# that this copyright notice is retained verbatim in all copies and  #
# no attempt is made to obscure the authorship of this file.  If you #
# distribute any modified versions, I ask, but do not require, that  #
# you clearly mark any changes you make as such and that you provide #
# your users with instructions for getting the original sources.     #
######################################################################

######################################################################
# create a new option button.  -font and -width can adjust appearance.
#   -list is not really optional.  -current can set current value.
######################################################################

proc j:option { w args } {
  j:parse_args {
    {font {}}
    {list {(none)}}
    {width 20}
    {current {}}
  }
  # should do error checking on args.
  
  global LIST_FOR_$w
  global OPTION_FOR_$w
  
  if {"x$current" == "x"} {
    set current [lindex $list 0]
  }
  set OPTION_FOR_$w $current
  
  set LIST_FOR_$w $list
  
  # parameterise following:
  label $w -width $width -textvariable OPTION_FOR_$w \
    -borderwidth 2 -relief raised
  if [string length $font] {
    $w configure -font $font
  }
  
  frame $w.bump -height 6 -width 10 -borderwidth 2 -relief raised
  place $w.bump -in $w -relx 0.95 -rely 0.5 -anchor e
  
  bind $w <ButtonPress-1> [list \
    j:option:popup .option_popup $w \
  ]
  j:tk4 {bind $w <ButtonPress-1> "+\nbreak"}
  
  catch {rename ${w}-orig {}}
  rename $w ${w}-orig
  proc $w { option args } [format {
    set tmp %s
    global OPTION_FOR_$tmp
    
    switch -exact $option {
      get {
        return [set OPTION_FOR_$tmp]
      }
      set {
        return [set OPTION_FOR_$tmp [lindex $args 0]]
      }
      configure {
        return [j:option:configure $tmp $args]
      }
      default {
        error [j:ldb optionbutton:invalidarg \
          "Invalid argument $option to option widget command $tmp."]
      }
    }
  } $w]
}

######################################################################
# configure a setting for an optionbutton widget.
#   this should be more general, and it should be used by initial
#   arg-parsing code for j:option .
######################################################################

proc j:option:configure { w arglist } {
  upvar #0 OPTION_FOR_$w current_value
  upvar #0 LIST_FOR_$w current_list
  
  if {[llength $arglist] == 1} {
    set option [lindex $arglist 0]
    switch -exact -- $option {
      -font {
        return [${w}-orig configure -font]
      }
      -list {
        return [list -list list List {(none)} $current_list]
      }
      -current {
        return [list -current current Current {} $current_value]
      }
      -width {
        return [${w}-orig configure -width]
      }
      default {
        error [j:ldb optionbutton:unknownoption \
          "Unknown option \"$option\""]
      }
    }
  }
  
  while {[llength $arglist] > 0} {
    set option [lindex $arglist 0]
    set value [lindex $arglist 1]
    if {"x$value" == "x"} {
      error [j:ldb optionbutton:novalue \
        "No value given to option \"$option\"."]
    }
    
    set arglist [lreplace $arglist 0 1]	;# with nothing
    
    switch -exact -- $option {
      -font {
        ${w}-orig configure -font $value
      }
      -list {
        set current_list $value
      }
      -current {
        set current_value $value
      }
      -width {
        ${w}-orig configure -width $value
      }
      default {
        error [j:ldb optionbutton:unknownoption \
          "Unknown option \"$option\""]
      }
    }
  }
}

######################################################################
# create (and position properly) the popup list invoked by <1>
######################################################################

proc j:option:popup { w button } {
  upvar #0 OPTION_FOR_$button value
  upvar #0 LIST_FOR_$button list
  
  # make sure the current value is in the list:
  if {[lsearch -exact $list $value] == -1} {
    set list [linsert $list 0 $value]
  }
  
  toplevel $w
  wm transient $w [winfo toplevel $button]
  wm overrideredirect $w 1
  wm withdraw $w
  
  set width [lindex [$button configure -width] 4]
  set font [lindex [$button configure -font] 4]
  
  listbox $w.lb \
    -font $font \
    -exportselection 0 \
    -borderwidth 2 -relief raised -cursor arrow
  
  j:tk3 {$w.lb configure -geometry ${width}x[llength $list]}
  j:tk4 {
    $w.lb configure -width $width -height [llength $list]
    $w.lb configure -highlightthickness 0
  }
  pack $w.lb -in $w
    
  foreach item $list {
    $w.lb insert end $item
  }
  
  # guess positioning of listbox so current value is over button:
  
  # get pixels per line - toplevel size is in pixels
  update
  set lines [llength $list]
  set pixels [winfo reqheight $w]
  set pixels_per_line [expr $pixels / $lines]
  
  # index is position of current value in list;
  # offset is that times pixels per line:
  set index [lsearch -exact $list $value]
  set offset [expr $index * $pixels_per_line]

  # subtract offset (position of current in list) from button y position:
  set x [winfo rootx $button]
  set y [expr [winfo rooty $button] - $offset]
  
  wm geometry $w +$x+$y
  wm deiconify $w
  
  # disable all current bindings:
  j:tk3 {
    foreach event [bind Listbox] {
      j:tk3 {bind $w.lb $event {}}
    }
  }
  j:tk4 {
    bindtags $w.lb $w.lb
  }
  
  j:tk3 {
    bind $w.lb <Visibility> "
      update
      grab -global %W
      %W select from $index
      %W select to $index
    "
  }
  j:tk4 {
    bind $w.lb <Visibility> "
      update
      grab -global %W
      %W selection clear 0 end
      %W selection set $index $index
      break
    "
  }
  
  bind $w.lb <Any-ButtonRelease-1> "
    set OPTION_FOR_$button \[%W get \[%W nearest %y\]\]
    grab release %W
    destroy \[winfo toplevel %W\]
  "
  j:tk4 {
    bind $w.lb "+\nbreak"
  }
  
  j:tk3 {
    bind $w.lb <Any-B1-Motion> {
      %W select from [%W nearest %y]
      %W select to [%W nearest %y]
    }
  }
  j:tk4 {
    bind $w.lb <Any-B1-Motion> {
      %W selection clear 0 end
      %W selection set [%W nearest %y] [%W nearest %y]
      break
    }
  }
}


