
##------------------------------------------------------------------------
## PROCEDURE
##	combobox
##
## DESCRIPTION
##	Implements a ComboBox mega-widget
##
## ARGUMENTS
##	combobox <window pathname> <options>
##
## OPTIONS
##	(Any entry widget option may be used in addition to these)
##
## -editable TCL_BOOLEAN		Defaults to 0
##	Whether to allow the user to edit the entry widget contents
##
## -history list			Defaults to {}
##	History list for the listbox
##
## -keephistory TCL_BOOLEAN		Defaults to 1
##	Whether to keep user input in history
##
## -tabexpand TCL_BOOLEAN		Defaults to 0
##	Whether to allow tab expansion in entry widget (uses listbox items)
##
## -prunehistory TCL_BOOLEAN		Defaults to 0
##	Whether to prevent duplicate listbox items
##
## -grab type				Defaults to global
##	Type of grab (local, none, global) to use when listbox appears.
##
## -state  normal or disabled           Defaults to normal
##
##
## RETURNS: the window pathname
##
## BINDINGS (in addition to default widget bindings)
##
## <Double-1> or <Escape> in the entry widget, or selecting the
## button will toggle the listbox portion.
## 
## Escape> will close the listbox without a selection.
## 
## <Return> in the entry widget adds items to the listbox.
## 
## <Tab> in the entry widget searches the listbox for a unique match.
## 
## <Double-1> in the listbox selects that item.
##
## <Up> and <Down> arrows selects previus and next items
## 
## EXAMPLE USAGE:
##
## pack [combobox .combo]
## pack [combobox .combo -width 20 -textvariable myvar]
##
##------------------------------------------------------------------------

image create bitmap ComboBoxImage -data {#define downbut_width 14
#define downbut_height 14
static char downbut_bits[] = {
   0x00, 0x00, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xfc, 0x0f,
   0xf8, 0x07, 0xf0, 0x03, 0xe0, 0x01, 0xc0, 0x00, 0x00, 0x00, 0xfe, 0x1f,
   0xfe, 0x1f, 0x00, 0x00};
}

bind ComboEntry <Double-1> { %W popup }
# bind ComboEntry <Escape>   { %W popup }
# tab only is activated if -tabexpand is on
#bind ComboEntry <Tab>      { %W expand [%W get]; break }
bind ComboEntry <Up>      { %W nextprev -1; break }
bind ComboEntry <Down>      { %W nextprev 1; break }
bind ComboEntry <Return>   { %W add [%W get] }

bind ComboList <Escape>   { wm withdraw [winfo toplevel %W] }
bind ComboList <1> { tkComboGet %W [%W get [%W nearest %y]] }
bind ComboList <Return>   { tkComboGet %W [%W get active] }

bind ComboTopLevel <1> { wm withdraw [winfo toplevel %W]}

bind ComboBoxGiD <Destroy> { tkComboDestroy %W }

bind ComboBoxGiD <FocusIn> { tkComboFocusToEntry %W }

proc combobox {w args} {
  frame $w -class ComboBoxGiD

  upvar \#0 $w data
  array set data {
    -editable		0
    -history		{}
    -keephistory	1
    -tabexpand		0
    -prunehistory	0
    -grab		global
    -state              normal
  }
  array set data [list \
      entrycmd		.$w.e \
      entry		$w.e \
      toplevel		$w.drop \
      listbox		$w.drop.lbox \
      scrollbar		$w.drop.sy \
      button            $w.b
      ]

  set entry [entry $data(entry) -state disabled -bd 1]
  ## Removable List Box
  toplevel $data(toplevel) -cursor arrow
  wm withdraw $data(toplevel)
  wm overrideredirect $data(toplevel) 1
  wm transient $data(toplevel) [winfo toplevel $w]
  wm group $data(toplevel) [winfo toplevel $w]
  bind $data(toplevel) <Unmap> { tkComboReleaseGrab %W }

  listbox $data(listbox) -bd 1 -relief sunken -width 5 -height 5 \
      -yscrollcommand [list $data(scrollbar) set] -selectmode single
  scrollbar $data(scrollbar) -orient vertical \
      -command [list $data(listbox) yview] -bd 1 \
      -elementborderwidth 1

  rename $w .$w
  rename $entry $data(entrycmd)
  if {[string comp {} $args] && \
      [catch {eval tkCombo_configure $w $args} err]} {
    destroy $w
    unset data
    return -code error $err
  }

  ## Button.  With the symbol font, it should be a down arrow
    button $w.b -image ComboBoxImage -command [list tkCombo_popup $w] \
	    -takefocus 0 -bd 1

    pack $w.b -side right -fill y
    pack $data(entry) -side left -fill x -expand 1
  
  pack $data(listbox) -side left -fill both -expand 1

  ## Gotta watch what you put in this list
  bindtags $entry [list $w $entry ComboEntry Entry [winfo toplevel $w] all]
  bindtags $data(listbox) [linsert [bindtags $data(listbox)] 1 ComboList]
  bindtags $data(toplevel) [linsert [bindtags $data(toplevel)] 1 ComboTopLevel]

  proc $w args "eval tkComboEval [list $w] \$args"
  proc $entry args "eval tkComboEval [list $w] \$args"

  after idle wm withdraw $data(toplevel)

  return $w
}

proc tkComboReleaseGrab { w } {
  upvar \#0 [winfo parent $w] data

    catch {
	grab release [grab current]
	catch {focus $data(oldFocus)}

	if {$data(oldGrab) != ""} {
	    if {$data(grabStatus) == "global"} {
		grab -global $data(oldGrab)
	    } else {
		grab $data(oldGrab)
	    }
	}
    }   
}


proc tkComboEval { w args } {
  upvar \#0 $w data

  switch -glob -- [lindex $args 0] {
    {} {
      return -code error "wrong \# args: should be \"$w option ?arg ...?\""
    }
    conf*	{ eval tkCombo_configure $w [lrange $args 1 end] }
    cg*		{ eval tkCombo_cget $w [lrange $args 1 end] }
    expand	{ eval tkCombo_expand $w [lrange $args 1 end] }
    nextprev    { eval tkCombo_nextprev $w [lrange $args 1 end] }
    popup	{ eval tkCombo_popup $w [lrange $args 1 end] }
    add		{ eval tkCombo_add $w [lrange $args 1 end] }
    list*       { eval $data(listbox) [lrange $args 1 end] }
    entry       { eval $data(entrycmd) [lrange $args 1 end] }
    default	{ eval $data(entrycmd) $args }
  }
}

proc tkComboDestroy w {
    upvar \#0 $w data
    tkComboReleaseGrab $w
    catch { rename $w {}; unset data }
}

proc tkCombo_configure { w args } {
  upvar \#0 $w data

  set num [llength $args]
  if {$num==1} {
    set arg [array names data ${args}*]
    set num [llength $arg]
    if {$num==1} {
      return [list $arg {} {} {} $data($arg)]
    } elseif $num {
      return -code error "ambiguous option \"$args\""
    } elseif [catch {$data(entrycmd) config $args} err] {
      return -code error $err
    } else {
      return $err
    }
  } elseif $num {
    set truth {^(1|yes|true|on)$}
    for {set i 0;set cargs {}} {$i<$num} {incr i} {
      set arg [string tolower [lindex $args $i]]
      set val [lindex $args [incr i]]
      switch -glob -- $arg {
	-editable	{
	  if [set data(-editable) [regexp $truth $val]] {
	    $data(entrycmd) config -state normal
	  } else {
	    $data(entrycmd) config -state disabled
	  }
	}
	-grab		{ regexp {^(local|global)$} $val data(-grab) }
	-keephistory	{ set data(-keephistory) [regexp $truth $val] }
	-history	{
	  set data(-history) $val
	  $data(listbox) delete 0 end
	  eval $data(listbox) insert end $val
	}
	-tabexpand	{ 
	    set data(-tabexpand) $val
	    if { $val } {
		bind $data(entrycmd) <Tab> { %W expand [%W get]; break }
	    } else {
		bind $data(entrycmd) <Tab> ""
	    }
	}
	-prunehistory	{ set data(-prunehistory) [regexp $truth $val] }
	-state          {
	    if { $val == "normal" } {
		set data(-state) normal
		$data(button) conf -state normal
		if { $data(-editable) == 1 } { 
		    $data(entrycmd) config -state normal
		}
	    } elseif { $val == "disabled" } {
		set data(-state) disabled
		$data(button) conf -state disabled
		$data(entrycmd) config -state disabled
	    } else {
		return -code error \
	"wrong \# args: should be \"$w configure -state enabled|disabled\""
	    }
	}
	default	{ lappend cargs $arg $val }
      }
    }
    if {[string comp {} $cargs] && \
	[catch {eval $data(entrycmd) config $cargs} err]} {
	return -code error $err
    }
    return
  } else {
    set conf [$data(entrycmd) config]
    foreach i [array names data -*] {
      lappend conf [list $i {} {} {} $data($i)]
    }
    return [lsort $conf]
  }
}

proc tkCombo_cget { w args } {
  if {[llength $args] != 1} {
    return -code error "wrong \# args: should be \"$w cget option\""
  }
  upvar \#0 $w data

  set arg [array names data $args]
  set num [llength $arg]
  if { $num != 1 } {
      set arg [array names data ${args}*]
      set num [llength $arg]
  }
  if {$num==1} {
    return $data($arg)
  } elseif $num {
    return -code error "ambiguous option \"$args\""
  } elseif [catch {$data(entrycmd) cget $args} err] {
    return -code error $err
  } else {
    return $err
  }
}

proc tkCombo_popup {w} {
    upvar \#0 $w data
    if { $data(-state) == "disabled" } { return }
    if [winfo ismapped $data(toplevel)] {
	wm withdraw $data(toplevel)
    } else {
	set NumItems [$data(listbox) size]
	set listboxheight $NumItems
	if { $listboxheight<5 } { set listboxheight 5 }
	if { $listboxheight>15 } { set listboxheight 15 }

	$data(listbox) conf -height $listboxheight

	wm geometry $data(toplevel) [winfo width $data(entry)]x[winfo \
		reqheight $data(listbox)]+[winfo rootx $data(entry)]+[expr \
		[winfo rooty $data(entry)]+[winfo reqheight $data(entry)]]

	update

	if { $NumItems > $listboxheight } {
	    pack $data(scrollbar) -side right -fill y
	} else {
	    pack forget $data(scrollbar)
	}
	wm deiconify $data(toplevel)

	set data(oldFocus) [focus]
	set data(oldGrab) [grab current $w]
	if {$data(oldGrab) != ""} {
	    set data(grabStatus) [grab status $data(oldGrab)]
	}

	if {$data(-grab)=="local"} {
	    grab $data(toplevel)
	    focus $data(listbox)
	} elseif {$data(-grab)=="global"} {
	    grab -global $data(toplevel)
	    focus $data(listbox)
	}
	raise $data(toplevel)
    }
}

proc tkCombo_expand {w {str {}}} {
  upvar \#0 $w data
  if !$data(-tabexpand) return
  if [string match {} $str] { set str [$data(entrycmd) get] }
  set found 0
  foreach item [$data(listbox) get 0 end] {
    if [string match ${str}* $item] {
      incr found
      lappend match $item
    }
  }
  if $found {
    set state [$data(entrycmd) cget -state]
    $data(entrycmd) config -state normal
    $data(entrycmd) delete 0 end
    if {$found>1} {
      set match [tkComboBestMatch $match]
    } else {
      set match [lindex $match 0]
    }
    $data(entrycmd) insert end $match
    $data(entrycmd) config -state $state
  } else { bell }
}

proc tkCombo_nextprev {w {next 1 } } {
    upvar \#0 $w data
    
    set str [$data(entrycmd) get]
    set state [$data(entrycmd) cget -state]
    $data(entrycmd) config -state normal
    $data(entrycmd) delete 0 end
    
    set size [$data(listbox) size]
    for { set i 0 } { $i < $size } { incr i } {
	set item [$data(listbox) get $i]
	if { [string compare $str $item] == 0 } {
	    if { $next == 1 } {
		set reti [expr $i+1]
	    } else { set reti [expr $i-1] }
	    if { $reti >= $size } { set reti 0 }
	    if { $reti < 0 } { set reti [expr $size-1] }

	    $data(entrycmd) insert end [$data(listbox) get $reti]
	    $data(entrycmd) config -state $state
	    return
	}
    }
    if { $next == 1 } {
	set reti 0
    } else { set reti [expr $size-1] }

    $data(entrycmd) insert end [$data(listbox) get $reti]
	    $data(entrycmd) config -state $state
}

proc tkCombo_add {w {str {}}} {
  upvar \#0 $w data
  if !$data(-keephistory) return
  if [string match {} $str] { set str [$data(entrycmd) get] }
  set i 1
  if !$data(-prunehistory) {
    foreach l [$data(listbox) get 0 end] {
      if ![string compare $l $str] { set i 0 ; break }
    }
  }
  if $i { $data(listbox) insert end $str }
  wm withdraw $data(toplevel)
}

proc tkComboGet {w i} {
  set e [winfo parent [winfo parent $w]].e
  if [$w size] {
    set state [$e entry cget -state]
    $e entry config -state normal
    $e delete 0 end
    $e insert end $i
    $e entry config -state $state
  }
  wm withdraw [winfo parent $w]
}

proc tkComboBestMatch l {
  set s [lindex $l 0]
  if {[llength $l]>1} {
    set i [expr [string length $s]-1]
    foreach l $l {
      while {$i>=0 && [string first $s $l]} {
	set s [string range $s 0 [incr i -1]]
      }
    }
  }
  return $s
}

proc tkComboFocusToEntry { w } {
    upvar \#0 $w data
    focus $data(entry)
}