

# See the file "license.txt" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This file contains the data filtering and validation filters for the
# forms package
#   The filters take a window and variable name as an argument, and replace its
#     value with the translated one, then return Success or failure.
#
#   The input filter is invoked just as the data is written onto the form
#		if the input conversion fails, the result should be set to {}
#
#   The output filter translates the data on the form to the format used
#	  by the application.  Upon failure, an error message is placed into
#     the argument, instead of the conversion.  The output filter is called
#	  any time the user "leaves" an entry field
#		output filters take 3 arguments:
#		 The name of the widget
#		 The option being filtered
#		 The name of the variable the old/new value is to be stored in

# map Font names to hide X naming grungyness
# This is temporary until TK supports a better strategy
# These are configured as forms data filters.

# X wants "-*-Helvetica-Bold-R-Normal-*-*-120-*-*-*-*-*-*"
# We'll use: format: <family>,<size>,[<Bold>,<Italic>]

# convert X font representation to UI representation
# convert the data in place, return 1/0 for conversion success

proc InFilter_font {variable args} {
    # Hacked to parse abbreviated font specifications.
    upvar $variable data
    set family {}
    set size   12     ;# default size
    set weight medium ;# default weight
    set style  r      ;# default style
    if {[string index $data 0] == "-"} {
	set fields [split $data -]
	switch [llength $fields] {
	    1 {
		set family [lindex $fields 0]
	    }
	    2 { set family [lindex $fields 0]
		set size   [lindex $fields 1]
	    }
	    3 {
		set family [lindex $fields 0]
		set weight [lindex $fields 1]
		set size   [lindex $fields 2]
	    }
	    15 {
		set family [lindex $fields 2]
		set weight [lindex $fields 3]
		set style  [lindex $fields 4]
		catch {set size [expr [lindex $fields 8] / 10]}
	    }
	    default {
		uplevel "set $variable {}"
		puts stderr "$data"
		return 0
	    }
	}
    } else {
	#this is tough...for font 7x14, the base is '7x14'.  for 
	#a12biluc, the base is 'a12biluc'.  for courier14, it's 'courier'.
	if {[regexp {^[0-9]} $data]} {
	    regexp {([0-9]*)$} $data dummy size
	} elseif {[regexp {([0-9]*)$} $data dummy size]} {
	    regsub {[0-9]*} $data {} data
	}
	# we don't have standard X font syntax...try something else...
	foreach q {bold black demi} {
	    if {[regexp "$q" $data]} {
		regsub "$q" $data {} data
		set weight bold
		break
	    }
	}
	foreach q {italic oblique} {
	    if {[regexp "$q" $data]} {
		regsub "$q" $data {} data
		set style i
		break
	    }
	}
	foreach q {roman normal medium book} {
	    if {[regexp "$q" $data]} {
		regsub "$q" $data {} data
		set style r
		break
	    }
	}
	foreach q {narrow light} {
	    # can't handle these...but we've got to pull them out
	    # if they're here.
	    if {[regexp "$q" $data]} {
		regsub "$q" $data {} data
		break
	    }
	}
	while {[regexp {\-$} $data]} {
	    regsub {\-$} $data {} data
	}
	set family $data
    }
    set result $family,$size
    if {[string tolower $weight] == "bold"} {append result ,Bold}
    if {$style == "I"} {append result ,Italic}
    uplevel "set $variable \"$result\""
    return 1
}

# convert font from UI representation to X representation

proc OutFilter_font {win option variable args} {
    upvar $variable data
    set ok 1
    set fields [split $data ,]
    set family [lindex $fields 0]
    set size [lindex $fields 1]0
    set weight Medium
    set style R
    foreach i {2 3} {
	switch -glob [set arg [lindex $fields $i]] {
	    {[iI]talic}	{set style I}
	    {[bB]old}	{set weight Bold}
	    {}			{;}
	    default {
		set error \
		    "Invalid font style \"$arg\", try \"Bold\" or \"Italic\""
		uplevel "[list set $variable $error]"
		return 0
	    }
	}
    }
    if {$size == {}} {set size 100}
    if {$family == {}} {set family Times}
    set result "-*-${family}-${weight}-${style}-Normal-*-*-${size}-*-*-*-*-*-*"
    catch  "label ._font_test_"
    
    # bad font.  Figure out why for message
    
    if {[catch "._font_test_ configure -font [list $result]"]} {
	set wrong 1
	if {$weight == "Bold"} {
	    set tryweight {bold black demi}
	} else {
	    set tryweight {{}}
	}
	if {$style == "R"} {
	    set trystyle {{} normal medium book roman} 
	} elseif {$style == "I"} {
	    set trystyle {oblique italic}
	} else {
	    set trystyle {{}}
	}
	set result {}
	foreach fweight $tryweight {
	    foreach fstyle $trystyle {
		set test "${family}${fweight}${fstyle}"
		if {[catch "._font_test_ config -font $test"]} {
		    set test "${family}-${fweight}${fstyle}"
		    if {[catch "._font_test_ config -font $test"]} {
			set test "${family}-${fweight}-${fstyle}"
			if {[catch "._font_test_ config -font $test"]} {
			} else {
			    set result $test
			    break
			}
		    } else {
			set result $test
			break
		    }
		} else {
		    set result $test
		    break
		}
	    }
	    if {$result != ""} {
		break
	    }
	}
	if {$result == ""} {
	    set test "-*-${family}-${weight}-${style}-Normal-*-*-*-*-*-*-*-*-*"
	    if {![catch "._font_test_ configure -font [list $test]"]} {
		set result "Invalid font size \"[expr $size/10]\" for $family,$style"
	    } else {
		set test "-*-${family}-*-*-Normal-*-*-*-*-*-*-*-*-*"
		if {[catch "._font_test_ configure -font [list $test]"]} {
		    set result "Invalid font family \"$family\""
		} else {
		    set result "Unsupported font style combination"
		}
	    }
	    set ok 0
	}
    }
    uplevel "[list set $variable $result]"
    return $ok
}


proc recipe_box {canvas args} {
    frame $canvas -bd 0 -relief flat
    frame $canvas.holder -bd 2 -relief raised
    grid $canvas.holder -row 1 -column 0 -sticky nsew
    grid rowconfigure $canvas.holder 0 -minsize 5
    grid rowconfigure $canvas.holder 1 -weight 1
    grid columnconfigure $canvas.holder 0 -weight 1
    upvar \#0 [winfo name $canvas]combobox c
    grid rowconfigure $canvas 0 -minsize 20
    grid rowconfigure $canvas 1 -weight 1
    grid columnconfigure $canvas 0 -weight 1
    grid propagate $canvas 1
    frame $canvas.hide -bd 0 -relief flat 
    grid $canvas.hide -in $canvas.holder -row 0 -column 0 -sticky nsew -rowspan 2
    set c(currenttab) 0
    set c(totaltabs) 0
    set c(next) 15
#    set c(xpadding) 5
set c(xpadding) 0
    set c(ypadding) 5
    set c(top) 5
    set c(contentheight) 0
    catch { unset c(last) }
    foreach {t f} $args {
	if {$t != "" && $f != ""} {
	    eval "recipe_tab $canvas [list $t] [list $f]"
	}
    }
    return $canvas
}

proc recipe_tab {canvas text win { commandname "" } } {
    upvar \#0 [winfo name $canvas]combobox c
    frame $canvas.[incr c(totaltabs)] -bd 2 -relief raised
    set font "Helvetica,12,Bold"
    OutFilter_font dummy font font
    label $canvas.$c(totaltabs).l -text $text -padx $c(xpadding) -pady $c(ypadding) -font $font 
    set wideness [expr [winfo reqwidth $canvas.$c(totaltabs).l]+14]
    pack $canvas.$c(totaltabs).l -side top
    if { $commandname == "" } { 
	bind $canvas.$c(totaltabs).l <1> "recipe_raise_tab $canvas $c(totaltabs)"
	bind $canvas.$c(totaltabs) <1> "recipe_raise_tab $canvas $c(totaltabs)"
    } else {
	bind $canvas.$c(totaltabs).l <1> "recipe_raise_tab $canvas $c(totaltabs) \
		; $commandname $text"
	bind $canvas.$c(totaltabs) <1> "recipe_raise_tab $canvas $c(totaltabs) \
		; $commandname $text"
    }
    set c($c(totaltabs)) $win
    recipe_raise_tab $canvas $c(totaltabs)
    update idletasks
    if {$c(totaltabs) > 1} {
	set idx 1
	set x 0
	while {$idx < $c(totaltabs)} {
	    set x [expr $x + [winfo reqwidth $canvas.$idx] + 8]
	    incr idx
	}
	set h [winfo reqheight $canvas.[expr $c(totaltabs)-1].l]
    } else {
	set x 0
	set y 0
	set h 0
    }
    set height [grid rowconfigure $canvas 0 -minsize]
    if {$h > $height} {
	grid rowconfigure $canvas 0 -minsize [expr $h + 5]
    }
    place $canvas.$c(totaltabs) -x [expr $x] -y 0 -height 100 -width $wideness
    grid $win -in $canvas.holder -row 1 -column 0 -sticky nsew
}

proc recipe_raise_tab {canvas tab} {
    upvar \#0 [winfo name $canvas]combobox c
    if {[info exist c(last)]} {
	set f [$canvas.$c(last).l cget -font]
	InFilter_font f
	set base {}
	set style {}
	if {[regexp {([^,]*,[^,]*)(.*)} $f dummy base style]} {
	    regsub -- {Bold} $style {} style
	    set f $base,$style
	    OutFilter_font dummy f f
	    catch {$canvas.$c(last).l config -font $f}
	}
    }
    
    set c(last) $tab
    set f [$canvas.$tab.l cget -font]
    InFilter_font f
    set base {}
    set style {}
    if {[regexp {([^,]*,[^,]*)(.*)} $f dummy base style]} {
	regsub -- {Bold} $style {} style
	set f "$base,${style}Bold"
	OutFilter_font dummy f f
	catch {$canvas.$tab.l config -font $f}
    }
    raise $canvas.holder
    raise $canvas.$tab
    raise $c($tab)
    raise $canvas.hide
}
