#!/usr/bin/tclsh
#
# Copyright 2017 Brad Lanam Walnut Creek CA
#

package require Tcl 8.5-
package require Tk

# cboxassoc is an associative combobox
#   -returnvalues : a list of of return values.  The length of this list
#                   must match the length of the -values list.
# When a value is selected, the corresponding value in the -returnvalues list
# is returned. 'get' and 'set' use the values in the -returnvalues list.
#
proc ::cboxassoc { nm args } {
  cboxassociative new $nm {*}$args
  return $nm
}

proc ::cboxassocHandler { cbox args } {
  $cbox {*}$args
}

::oo::class create ::cboxassociative {
  constructor { nm args } {
    my variable vars

    set widgettype ttk::combobox
    if { [info commands cboxadj] eq "cboxadj" } {
      set widgettype cboxadj
    }

    set vars(widget) [$widgettype ${nm}]
    set vars(cbox) ${nm}_cboxassoc
    rename $vars(widget) ::$vars(cbox)
    interp alias {} $vars(widget) {} ::cboxassocHandler [self]
    uplevel 2 [list $vars(widget) configure {*}$args]

    set bt [my _addBindTag $vars(widget) cboxassocbt]
    bind $bt <Destroy> [list [self] destruct]
    bind $bt <<ComboboxSelected>> [list [self] select]
    bind $bt <Tab> [list [self] select]
  }

  method _addBindTag { w tag } {
    if { [lsearch -exact [bindtags $w] $tag$w] == -1 } {
      bindtags $w [concat $tag$w [bindtags $w]]
    }
    return $tag$w
  }

  method destruct { } {
    my variable vars

    trace remove variable $vars(-textvariable) write [list [self] settrace]
    interp alias {} $vars(widget) {}
    [self] destroy
  }

  method unknown { args } {
    my variable vars

    set nm $vars(cbox)
    return [uplevel 2 [list $nm {*}$args]]
  }

  method select { args } {
    my variable vars

    set curr [$vars(cbox) current]
    if { [info exists vars(-returnvalues)] &&
        [info exists vars(-textvariable)] &&
        [info exists $vars(-textvariable)] } {
      set v [lindex $vars(-returnvalues) $curr]
      set $vars(-textvariable) $v
    }
  }

  method current { args } {
    my variable vars

    if { [llength $args] == 0 } {
      set curr [$vars(cbox) current]
    } else {
      set curr [lindex $args 0]
      $vars(cbox) current $curr
    }
    return $curr
  }

  method get { } {
    my variable vars

    set rv {}
    if { [info exists vars(-textvariable)] &&
        [info exists $vars(-textvariable)] } {
      set rv [set $vars(-textvariable)]
    }
    return $rv
  }

  method settrace { args } {
    my variable vars

    if { [info exists vars(-textvariable)] &&
        [info exists $vars(-textvariable)] } {
      my set [set $vars(-textvariable)]
    }
  }

  method set { val } {
    my variable vars

    if { [info exists vars(-textvariable)] &&
        [info exists $vars(-textvariable)] } {
      set $vars(-textvariable) $val
    }
    set idx -1
    if { [info exists vars(-returnvalues)] } {
      set idx [lsearch -exact $vars(-returnvalues) $val]
    }
    if { $idx != -1 } {
      $vars(cbox) current $idx
    }
    return $val
  }

  method cget { key } {
    my variable vars

    set rv {}
    if { $key eq "-textvariable" ||
        $key eq "-returnvalues" } {
      if { [info exists vars($key)] } {
        set rv $vars($key)
      }
    } else {
      set rv [$vars(cbox) cget $key]
    }
    return $rv
  }

  method configure { args } {
    my variable vars

    foreach {k v} $args {
      if { $k eq "-textvariable" } {
        set fqv {}
        if { [string match {::*} $v] } {
          set fqv $v
        }
        if { $fqv eq {} } {
          set fqv [uplevel 2 [list namespace which -variable $v]]
          if { $fqv eq {} } {
            set ns [uplevel 2 [list namespace current]]
            set fqv $ns$v
            if { [string match ::::* $fqv] } {
              set fqv [string range $fqv 2 end]
            }
          }
        }
        if { [info exists vars($k)] &&
            [info exists $vars($k)] &&
            $vars($k) ne $fqv } {
          trace remove variable $vars($k) write [list [self] settrace]
        }
        set vars($k) $fqv
        if { ! [info exists $vars($k)] } {
          set $vars($k) {}
        }
      } elseif { $k eq "-returnvalues" } {
        set vars($k) $v
      } elseif { $k eq "-values" } {
        set vars($k) $v
        set nm $vars(cbox)
        uplevel 2 [list $nm configure $k $v]
      } else {
        set nm $vars(cbox)
        uplevel 2 [list $nm configure $k $v]
      }
    }

    set k -textvariable
    if { [info exists vars($k)] && [info exists $vars($k)] } {
      trace remove variable $vars($k) write [list [self] settrace]
      my set [set $vars($k)]
      trace add variable $vars($k) write [list [self] settrace]
    }
    return -code ok
  }
}

package provide cboxassoc 1.3