
# The list of options contains elements of the form:
# 	{value options}
# For example: {a -text "A value" -selector green}
#
# If check is 0 then radio buttons are used instead.

proc check_box {w options size variable {check 1} {all_cmd ""} \
		    {prefix_sep ""} {other_buts ""} {use_pack 0}} {
    global check_box_all check_box_var check_box_check
    global check_box_vals check_box_count check_box_index check_box_command
    global check_box_label check_box_textindex
    global check_box_prefix check_box_prefix_on
    global [lindex [split $variable \(] 0]
    
    set lw 0; set lh 0
    switch [llength $size] {
	1 { set lh $size }
	2 { set lw [lindex $size 0]; set lh [lindex $size 1] }
    }
    
    if ![winfo exists $w.list] {
	listbox $w.list -background white -height $lh -width $lw -selectforeground black \
	    -selectbackground cyan -selectborderwidth 0 -exportselection 0
	
	bind $w.list <1> "tk::ListboxBeginSelect %W \[%W index @%x,%y\]; \
		check_update_variable $w \[%W nearest %y\]; break"
	foreach ev {<B1-Motion> <ButtonRelease-1> <B1-Leave> <B1-Enter>} {
	    bind $w.list $ev break
	}
	
	if $check {
	    $w.list configure -selectmode multiple
	} else {
	    $w.list configure -selectmode single
	}
	frame $w.buts
	
	# Add the buttons.
	if $check {
	    set r 0; set c 0
	    if {$prefix_sep != ""} {
		checkbutton $w.buts.pref -text "Use prefix" \
		    -variable check_box_prefix_on($w)
		grid $w.buts.pref -row 10 -column 0 -columnspan 10 -sticky news
		#pack $w.buts.pref -side bottom -fill x -expand 1
	    }
	    if {$check == 1} {
		button $w.buts.all -text All -width 5 -pady -2 -command \
		    "check_box_button $w 1"
		button $w.buts.none -text None -width 5 -pady -2 -command \
		    "check_box_button $w 0"
		grid $w.buts.all -row $r -column $c -sticky news
		incr c
		grid $w.buts.none -row $r -column $c -sticky news
		incr c
	    } else {
		button $w.buts.none -text None -pady 2 -command \
		    "check_box_button $w 0"
		grid $w.buts.none -row $r -column $c -sticky nws
		incr c
	    }
	    foreach b $other_buts {
		if {$b == "nl"} { incr r; set c 0; continue }
		button $w.buts.[lindex $b 0] -text [lindex $b 1] -width 4 \
		    -pady -2 -command [lindex $b 2]
		grid $w.buts.[lindex $b 0] -row $r -column $c -sticky news
		incr c
	    }
	}
	
	scrollbar $w.scroll -command "$w.list yview"  -relief sunken \
		-borderwidth 2 -orient v
	$w.list configure -yscroll "$w.scroll set"
        if {$use_pack || ([info command grid] == "")} {
            pack $w.buts -side bottom -fill both
            pack $w.list -side left -fill both -expand 1
            pack $w.scroll -side right -fill y
        } else {
	    grid $w.buts -row 1 -column 0 -columnspan 2 -sticky ew
	    grid $w.list -row 0 -column 0 -sticky nsew
	    grid $w.scroll -row 0 -column 1 -sticky ns
	    grid columnconfigure $w 0  -weight 1000  ;# XXXXX
	    grid rowconfigure $w 0  -weight 1000  ;# XXXXX
	}
    }
    
    set check_box_all($w) $all_cmd
    set check_box_var($w) $variable
    set check_box_check($w) $check
    set check_box_count($w) [llength $options]
    set check_box_prefix($w) $prefix_sep
    set check_box_prefix_on($w) 0
    
    # We also should clean up check_box_index but that's too hard.
    $w.list delete 0 end
    
    if {!$check && ![info exists $variable]} {
	set $variable ""
    }
    set i 0
    foreach opt $options {
	set val [lindex $opt 0]
	set text $val
	set cmd ""
	set no [llength $opt]
	set itemconf ""
	for {set j 1} {$j < $no} {incr j 2} {
	    switch -- [lindex $opt $j] {
		-text {
		    set text [lindex $opt [expr {$j + 1}]]
		}
		-command {
		    set cmd [lindex $opt [expr {$j + 1}]]
		}
		-background - -selectbackground -
		-foreground - -selectforeground {
		    lappend itemconf [lindex $opt $j] \
			[lindex $opt [expr {$j + 1}]]
		}
	    }
	}
	set ii [$w.list index end]
	$w.list insert $ii $text
	if {$itemconf != ""} {
	    if [catch {
		eval $w.list itemconfigure $ii $itemconf
	    } res] { puts "WARNING: $res" }
	}
	set check_box_label($w,$i) $text
	set check_box_vals($w,$i) $val
	set check_box_command($w,$i) $cmd
	set check_box_index($w,$val) $i
	set check_box_textindex($w,$text) $i
	if $check {
	    if ![info exists ${variable}($val)] {
		set ${variable}($val) 0
	    }
	    if [set ${variable}($val)] {
		$w.list selection set $i
	    }
	} else {
	    if {$val == [set $variable]} {
		$w.list selection set $i
	    }
	}
	incr i
    }
    if {$variable != ""} {
	check_box_put_trace $w
    }
    $w.list configure -height $lh -width $lw
}

proc form_check_box_setstate {w on} { check_box_active $w $on }

proc check_box_active {w on} {
    if ![winfo exists $w] return
    if $on {
	$w.list configure -fg black -selectforeground black
	foreach b [winfo children $w.buts] {
	    $b configure -state normal
	}
	bind $w.list <1> "tk::ListboxBeginSelect %W \[%W index @%x,%y\]; \
		check_update_variable $w \[%W nearest %y\]; break"
	
	set s [$w.list size]
	for {set i 0} {$i < $s} {incr i} {
	    catch {$w.list itemconfigure $i -foreground black}
	}
    } else {
	$w.list configure -fg gray -selectforeground gray
	foreach b [winfo children $w.buts] {
	    $b configure -state disabled
	}
	bind $w.list <1> break
	
	set s [$w.list size]
	for {set i 0} {$i < $s} {incr i} {
	    catch {$w.list itemconfigure $i -foreground gray}
	}
    }
}

proc check_box_form {w text options size variable {check 1} {all_cmd ""} \
			 {prefix_sep ""} {others_cmd ""} {others_cmd2 ""} \
			 {title Selection}} {
    set d [form_init $w $title "" "done cancel" "" 1 1 1]
    if {$d != ""} {
	if {$text != ""} {
	    form_message $d.mess $text {0 0}
	    $d.mess configure -width 150
	}
	form_frame $d.check flat 0 {1 0 -fill both}
    }
    check_box $w.main.check $options $size $variable $check $all_cmd $prefix_sep
    if !$check {
	bind $w.main.check.list <Double-1> "form_accept_hack $w"
    }
    if {$d != ""} {
	if {$others_cmd != ""} {
	    eval $others_cmd
	}
	form_finish +300+300 1 1
    }
    if {$others_cmd2 != ""} {
	eval $others_cmd2
    }
    set r [form_wait $w]
    return $r
}

proc check_box_add_one {w opt} {
    global check_box_count check_box_label check_box_vals check_box_command
    global check_box_index check_box_textindex check_box_var check_box_check
    
    set variable $check_box_var($w)
    global [lindex [split $variable \(] 0]
    
    set i $check_box_count($w)
    incr check_box_count($w)
    
    set val [lindex $opt 0]
    set text $val
    set cmd ""
    set no [llength $opt]
    for {set j 1} {$j < $no} {incr j 2} {
	switch -- [lindex $opt $j] {
	    -text {
		set text [lindex $opt [expr {$j + 1}]]
	    }
	    -command {
		set cmd [lindex $opt [expr {$j + 1}]]
	    }
	}
    }
    $w.list insert end $text
    set check_box_label($w,$i) $text
    set check_box_vals($w,$i) $val
    set check_box_command($w,$i) $cmd
    set check_box_index($w,$val) $i
    set check_box_textindex($w,$text) $i
    if $check_box_check($w) {
	if ![info exists ${variable}($val)] {
	    set ${variable}($val) 0
	}
	if [set ${variable}($val)] {
	    $w.list selection set $i
	}
    } else {
	if {$val == [set $variable]} {
	    $w.list selection set $i
	}
    }
    incr i
}

proc check_box_val_for_label {w text} {
    global check_box_textindex check_box_vals
    
    if ![info exists check_box_textindex($w,$text)] { return "" }
    return $check_box_val($w,$check_box_textindex($w,$text))
}

proc check_box_put_trace {w} {
    global check_box_var
    
    set v $check_box_var($w)
    global [lindex [split $v (] 0]
    foreach vi [trace vinfo $v] {
	set cmd [lindex $vi 1]
	if {$cmd == "check_box_do_trace $w"} return
    }
    uplevel \#0 trace variable $v w \"check_box_do_trace $w\"
}

proc check_box_remove_trace {w} {
    global check_box_var
    
    set v $check_box_var($w)
    global [lindex [split $v (] 0]
    uplevel \#0 trace vdelete $v w \"check_box_do_trace $w\"
    unset check_box_var($w)
}

proc check_box_do_trace {w v1 v2 wh} {
    global check_box_check check_box_index
    global $v1
    
    if ![winfo exists $w.list] {
	check_box_remove_trace $w
	return
    }
    if $check_box_check($w) {
	if ![info exists check_box_index($w,$v2)] return
	set val [set ${v1}($v2)]
	if $val {
	    $w.list selection set $check_box_index($w,$v2)
	} else {
	    $w.list selection clear $check_box_index($w,$v2)
	}
    } else {
	if {$v2 != ""} {
	    set val [set ${v1}($v2)]
	} else {
	    set val [set $v1]
	}
	$w.list selection clear 0 end
	if ![info exists check_box_index($w,$val)] return
	$w.list selection set $check_box_index($w,$val)
    }
}

proc check_box_adjust_visible {w} {
    global check_box_index check_box_var
    
    set val [uplevel \#0 set $check_box_var($w)]
    $w.list yview $check_box_index($w,$val)
}

proc check_box_button {w on} {
    global check_box_all check_box_var check_box_vals
    global check_box_count check_box_command
    
    set var $check_box_var($w)
    global $var
    
    set all $check_box_all($w)
    set plus [expr {[string index $all 0] == "+"}]
    set useall [expr {($all != "") && !$plus}]
    for {set i 0} {$i < $check_box_count($w)} {incr i} {
	set val $check_box_vals($w,$i)
	set ${var}($val) $on
	if {!$useall && ($check_box_command($w,$i) != "")} {
	    eval $check_box_command($w,$i)
	}
    }
    if $useall {
	eval $check_box_all($w)
    } elseif $plus {
	eval [string range $check_box_all($w) 1 end]
    }
    if $on {
	$w.list selection set 0 end
    } else {
	$w.list selection clear 0 end
    }
}

proc check_update_variable {w i} {
    global check_box_var check_box_check check_box_vals check_box_count
    global check_box_command check_box_prefix check_box_prefix_on
    global check_box_label
    global [lindex [split $check_box_var($w) \(] 0]
    
    if ![info exists check_box_vals($w,$i)] return
    set var $check_box_var($w)
    set val $check_box_vals($w,$i)
    set lab $check_box_label($w,$i)
    
    set pref ""
    if $check_box_prefix_on($w) {
	set sep $check_box_prefix($w)
	if {[string first $sep $lab] >= 0} {
	    set pref [lindex [split $lab $sep] 0]
	}
    }
    
    if $check_box_check($w) { set on [expr ![set ${var}($val)]] }
    if {$pref != ""} {
	set vals ""
	for {set i 0} {$i < $check_box_count($w)} {incr i} {
	    if [info exists check_box_vals($w,$i)] {
		if [string match $pref$sep* $check_box_label($w,$i)] {
		    lappend vals [list $check_box_vals($w,$i) $i]
		}
	    }
	}
    } else {
	set vals [list [list $val $i]]
    }
    
    foreach v $vals {
	set vv [lindex $v 0]
	set commands_found($check_box_command($w,[lindex $v 1])) 1
	if $check_box_check($w) {
	    if [ info exists $var ] {
		 set ${var}($vv) $on
	    } 
	} else {
	    set $var $vv
	}
    }
    
    # This is a trick ...
    foreach cmd [array names commands_found] {
	if {$cmd != ""} { eval $cmd }
    }
}

proc check_box_see {w val {starti 0} {useval 0}} {
    global check_box_label check_box_vals check_box_count
    
    for {set i $starti} {$i < $check_box_count($w)} {incr i} {
	if {(!$useval && $check_box_label($w,$i) == $val) || \
	    ($useval && $check_box_vals($w,$i) == $val)} {
	    $w.list see $i
	    return $i
	}
    }
    return -1
}

proc check_box_see_pat {w val {starti 0}} {
    global check_box_label check_box_count
    
    for {set i $starti} {$i < $check_box_count($w)} {incr i} {
	set vt $check_box_label($w,$i)
	if [string match [string tolower *$val*] [string tolower $vt]] {
	    $w.list see $i
	    return $i
	}
    }
    return -1
}

# ----

#catch {destroy .ch}; frame .ch; pack .ch -fill both
#check_box .ch {{a -text AA} {b -text BB} {c -text CC -command {puts CCCC}}} 6 fooey 0 "puts EVERYTHING"
