# measurement.tcl --
#
#     An entry widget which understands measurement units
#
#
# Copyright 2000 Pinebush Technologies Inc.
#
#
# Exported procs:
#     measurement::measurement - Create a measurement widget
#
# A measurement widget is an enhanced entry widget that makes it
# easier to get dimensions from user input.  
#
# It supports separate display and reporting units so the user's
# assumptions and the system's assuptions need not be the same.  For
# example, a measurement widget could be configure to assume the user
# meant centimeters but that the system required inches.  If the user
# typed "3.81" into the widget, the textvariable associated with the
# widget would have a value of "1.5".
#
# The user may enter explicit unit suffixes to override the
# assumption.  Continuing the previous example, if the user typed
# "54pt" into the widget, the textvariable would be set to ".75"
#
#
# The measurement widget behaves like an entry except for the addition
# of new options and subcommands as follows.
#
# Measurement widgets recognize the following additional options:
#
#     -units : Specifies the implied units for the value stored in the
#        widget's textvariable and returned by the widget's get
#        command. The value of this option may be any unit string
#        recognized by the units package.
#
#     -displayunits : Specifies the default units for the text displayed
#        in the widget.  If the user does not type a unit suffix in
#        the entry, these units are assumed.  The value of this option
#        may be any unit string recognized by the units package. If
#        not specified, displayunits defaults to the same value as units.
#
#     -invalidforeground : Specifies a text color to use when the
#        contents of the widget are not a valid measurement.  For
#        example, when the unit suffix is incomplete such as "2.54c"
#        on the way to typing "2.54cm".  If not specified,
#        invalidforeground defaults to red.
#
#     -invalidbackground : Specifies a background color to use when
#        the contents of the widget are not a valid measurement.  If
#        not specified, invalidbackground defaults to the normal
#        background.
#
# Measurement widgets respond to the following additional or changed
# commands:
#
#      $m get ?export? - Returns the value exported by the widget (the
#         same value that would be in the textvariable if one is
#         assigned). Raises an error if the text in the widget does
#         not represent a valid measurement.
#
#      $m get display - Returns the text shown to the user.
#
#      $m isvalid - Returns 1 if [$m get export] would raise an error,
#         0 otherwise.
#
# Also, trying to set the measurement widget's textvariable to a value
# that does not represent a valid measurement raises an error.
#
#
# WUZ - doesn't work with option database. Yet.
#
# Example:
#     See measurement::Test at the bottom of this file.
#
#
# Global data:
#     None.
#
#-----------------------------------------------------------------------

# package require units
source units.tcl

namespace eval ::measurement {
    namespace export \
            meas \

    # "global" array(s)
    variable Options

    # Some defaults
    set Options(-units) ""
    set Options(-invalidforeground) red
}

#=======================================================================
# Public procs
#=======================================================================
# measurement::measurement --
#
#     Create a new widget
# 
# Arguments:
#     
# Results:
#     
proc ::measurement::measurement { w args } {
    variable Options

    # Create a namespace for the widget
    namespace eval $w {}

    # The hull frame
    frame $w -class Meas

    # Rename the widget command for the outer frame into the namespace
    # We never really use this command again.
    rename $w measurement::${w}::frame

    # Make sure that closing this window does the right things.
    #
    # We bind to the Meas class rather than to the window because
    # the caller might bind to the window's destroy event; the class is
    # *ours*, the window path is "public"
    bind Meas <Destroy> [namespace code [list Done %W CLOSE]]


    #========================================
    # Create the widget
    set e [entry $w.entry]
    pack $e -expand 1 -fill both

    # Create a new widget command
    proc ::$w [info args measurement::WidgetProc] \
            "set w $w;[info body measurement::WidgetProc]"

    upvar ::measurement::${w}::options options
    set options(-units) ""
    set options(-invalidforeground) $Options(-invalidforeground)
    set options(-invalidbackground) [$e cget -background]
    set options(-validfg) [$e cget -foreground]
    set options(-validbg) [$e cget -background]

    $w.entry configure -textvariable ::measurement::${w}::data(internalValue)
    trace add variable ::measurement::${w}::data(internalValue) write \
            [namespace code [list UpdateExternalVar $w]]

    # Pressing <Return> reformats to add units
    bind $e <Return> [namespace code [list NormalizeValue $w]]

    # Configure the widget
    if {[llength $args]} {
        eval [list $w configure] $args
    }

    return $w
}
# measurement::measurement
# 
#=======================================================================
# Private procs only below this line
#=======================================================================
# measurement::Done --
#
#     Clean up when the user's done with the option tree
# 
# Arguments:
#     
# Results:
#     Returns the number of changes made.
#
proc ::measurement::Done { w why } {
    variable meas

    switch -- $why {
        OK {

        }
        CLOSE -
        CANCEL {
            namespace delete measurement::$w
        }
    }
}
# measurement::Done
# 
#-----------------------------------------------------------------------
# measurement::WidgetProc --
#
#     The widget proc for a measurement entry; processes widget commands.
# 
# Arguments:
#     
# Results:
#     
proc ::measurement::WidgetProc { cmd args } {
    switch -- $cmd {
        cget {
            set result [measurement::Configure $w $args]
            lindex $result 4
        }

        configure {
            eval [list measurement::Configure $w] $args
        }

        get {
            eval [list measurement::Get $w] $args
        }

        isvalid {
            eval [list measurement::IsValid $w] $args
        }

        default {
            # Pass the command down to the embedded entry
            eval [list $w.entry $cmd] $args
        }
    }
}
# measurement::WidgetProc
# 
#-----------------------------------------------------------------------
# measurement::Configure --
#
#     Handle configure sub-command for widget.
# 
# Arguments:
#     w    - Path to the widget
#     args - Arguments to command
#
# Results:
#     
proc ::measurement::Configure { w args} {
    upvar ::measurement::${w}::options options

    # If 0 args, get the full list from the base proc then post-process
    #    wrapped commands
    # If 1 arg, handle wrapped commands directly, ask base proc for others
    # If odd number of arguments, let the base proc generat the error
    # Otherwise, set options, checking for the ones we have to handle specially
    if {[llength $args] == 0} {
        # List all the entry's options
        set result [eval [list $w.entry configure] $args]

        # Remove entry's textvariable, we'll add our own
        set index [lsearch -glob $result "-textvariable*"]
        set result [lreplace $result $index $index]

        # Add our custom options, including textvariable
        foreach opt {
            -displayunits 
            -invalidforeground 
            -invalidbackground 
            -textvariable
            -units 
        } {
            lappend result [Configure $w $opt]
        }

        # We added some things out of order at the end, so fix it up.
        lsort -index 0 -dictionary $result
    } elseif {[llength $args] == 1 } {
        # Get the value for a single option
        set option [lindex $args 0]
        switch -- $option {
            -units {
                set result [list -units units Units \
                        "" $options($option)]
            }

            -displayunits {
                set result [list -displayunits displayUnits DisplayUnits \
                        "" $options($option)]
            }

            -invalidforeground {
                set result [list -invalidforeground invalidForeground \
                        InvalidForeground "" \
                        $options($option)]
            }

            -invalidbackground {
                set result [list -invalidbackground invalidBackground \
                        InvalidBackground "" \
                        $options($option)]
            }

            -textvariable {
                # Get the name, defaults, etc. from entry
                set result [eval [list $w.entry configure] $args]
                # Put the real user's value in, not our wrapper
                if {[info exists options(-textvariable)]} {
                    set textVar $options(-textvariable)
                } else { 
                    set textVar {}
                }
                lreplace $result 4 4 $textVar
            }
            default {
                eval [list $w.entry configure] $args
            }
        }
    } elseif {[llength $args]%2 == 1} {
        # Odd number > 1, let the entry complain
        eval [list $w.entry configure] $args
    } else {
        # Even number, set a bunch of option values
        array set opt $args
        foreach option [array names opt] {
            switch -- $option {
                -units -
                -displayunits {
                    set units $opt($option)

                    # An empty string means no conversion
                    # Normalize any non-empty unit string
                    if {[string length $units]} {
                        set units [units::normalize $units] 
                    }

                    set options($option) $units
                    unset opt($option)

                    if {[string equal $option -units]} {
                        UpdateExternalVar $w
                    } else {
                        UpdateInternalVar $w
                    }
                }

                -invalidforeground -
                -invalidbackground {
                    set options($option) $opt($option)
                    unset opt($option)
                }

                -textvariable {
                    set varName "::$opt($option)"
                    # Remember what the user wanted.
                    set options(-textvariable) $varName

                    # Put a read trace on the user's variable
                    # to raise an error when reading a variable from 
                    # an inconsistent measurement.
                    trace add variable $varName read \
                            [namespace code [list ValidateRead $w]]

                    # Put a write trace on the user's variable to
                    # update the widget internal variable
                    trace add variable $varName write \
                            [namespace code [list UpdateInternalVar $w]]

                    # Set measurement from user var
                    if {[info exists $varName]} {
                        UpdateInternalVar $w
                    }
                    # We always have our own text variable set so just
                    # unset this.
                    unset opt($option)
                }
            }
        }
        # foreach

        if {[array size opt] != 0} {
            eval [list $w.entry configure] [array get opt]
        }
    }
    # if
}
# measurement::Configure
# 
#-----------------------------------------------------------------------
# measurement::UpdateExternalVar --
#
#     Update the external variable when the user modifies the
#     measurement.
# 
# Arguments:
#     
# Results:
#     
proc ::measurement::UpdateExternalVar { w args } {
    upvar ::measurement::${w}::options options
    upvar ::measurement::${w}::data data

    if {[info exists measurement::InUpdate]} {
        return
    }
    set measurement::InUpdate 1

    set units $options(-units)
    if {[info exists options(-displayunits)]} {
        set displayunits $options(-displayunits)
    } else {
        set displayunits $options(-units)
    }

    set valueIn $data(internalValue)

    if {[string length $valueIn] == 0} {
        set valueOut $valueIn
    } else {
        if {[catch {units::parse $valueIn} meaIn]} {
            $w.entry configure -foreground $options(-invalidforeground)
            $w.entry configure -background $options(-invalidbackground)
            unset measurement::InUpdate
            return
        }
        if {[llength $meaIn] == 1} {
            lappend meaIn $displayunits
        }
        if {[catch {units::convert $meaIn $units} meaOut]} {
            $w.entry configure -foreground $options(-invalidforeground)
            $w.entry configure -background $options(-invalidbackground)
            unset measurement::InUpdate
            return
        }
        set valueOut [lindex $meaOut 0]
    }

    $w.entry configure \
            -foreground $options(-validfg) \
            -background $options(-validbg)

    # Set the user's variable, if there is one
    if {[info exists options(-textvariable)]} {
        set $options(-textvariable) $valueOut
    }
    unset measurement::InUpdate
}
# measurement::UpdateExternalVar
# 
#-----------------------------------------------------------------------
# measurement::UpdateInternalVar --
#
#     Update the internal variable which is tied to the text the user
#     sees.
# 
# Arguments:
#     
# Results:
#     
proc ::measurement::UpdateInternalVar { w args } {
    upvar ::measurement::${w}::options options
    upvar ::measurement::${w}::data data

    if {[info exists measurement::InUpdate]} {
        return
    }
    set measurement::InUpdate 1

    set units $options(-units)

    # Get the variable name
    set varName $options(-textvariable)

    if {[info exists $varName]} {
        # Get the external value
        set valueIn [set ::$varName]
        if {[string length $valueIn]} {
            if {[catch {units::parse $valueIn} meaIn]} {
                # Restore the last, valid external value.
                set $varName $data(externalValue)
                # Clear our semaphore
                unset measurement::InUpdate
                # Raise an error.
                error "'$valueIn' cannot be parsed for units conversion"
            }
            # Now that it's valid, save it for later
            set data(externalValue) $valueIn

            # If there was no unit in the external variable, add one.
            if {[llength $meaIn] == 1} {
                lappend meaIn $units
            }

            # Update the measurement
            set data(internalValue) [join $meaIn ""]
            NormalizeValue $w
        }
    }
    unset measurement::InUpdate
}
# measurement::UpdateInternalVar
# 
#-----------------------------------------------------------------------
# measurement::NormalizeValue --
#
#     Normalize the value displayed, include units, etc.
# 
# Arguments:
#     
# Results:
#     
proc ::measurement::NormalizeValue { w } {
    upvar ::measurement::${w}::options options
    upvar ::measurement::${w}::data data

    # Get the default units for this measurement
    if {[info exists options(-displayunits)]} {
        set units $options(-displayunits)
    } else {
        set units $options(-units)
    }

    # Get the current value
    set valueIn $data(internalValue)
    # If we can't parse the current value, give up.
    if { [catch {units::parse $valueIn} meaIn] } {
        return
    }
    # If there aren't units in the current value, use the default
    if {[llength $meaIn] == 1} {
        lappend meaIn $units
    }

    # Convert to expected units
    set meaOut [units::convert $meaIn $units]
    set valueOut [join $meaOut ""]

    # Update the display with the normalized value.
    set data(internalValue) $valueOut
}
# measurement::NormalizeValue
# 
#-----------------------------------------------------------------------
# measurement::Get --
#
#     Get the value of the widget
# 
# Arguments:
#     w    - The measurement widget
#     what - What to return, "export" (the textvariable value) or
#            "display" (what the user typed and sees).  export is the
#            default.
#
# Results:
#     Returns the value of the widget.
#
proc measurement::Get { w {what "export"} } {
    upvar ::measurement::${w}::data data
    switch -- $what {
        display {
            set result $data(internalValue)
        }

        export {
            # Raise an error if inconsistent
            set result foo
        }
        default {
            error "Invalid option, '$what'; must be display or export"
        }
    }
    return $result
}
# measurement::Get
# 
#-----------------------------------------------------------------------
# measurement::IsValid --
#
#     Make sure that the text typed by the user is valid and that the
#     value reported by [$m get export] and [$m get display] are
#     consistent.
# 
# Arguments:
#     w - The measurement widget.
#
# Results:
#     Returns 1 if the text is valid and the internal and external
#     values are consistent, 0 otherwise.
#
proc measurement::IsValid { w } {
    upvar ::measurement::${w}::data data

    # If we can't parse the current value, it's invalid
    if {[catch {units::parse $data(internalValue)}]} {
        return 0
    } else {
        return 1
    }
}
# measurement::IsValid
# 
#-----------------------------------------------------------------------
# measurement::ValidateRead --
#
#     <short description>
# 
# Arguments:
#     
# Results:
#     
proc measurement::ValidateRead { w args } {
    upvar ::measurement::${w}::data data
    if { ! [IsValid $w] } {
        error "'$data(internalValue)' cannot be parsed for units conversion"
    }
}
# measurement::ValidateRead
# 
#-----------------------------------------------------------------------
# measurement::Test --
#
#     <short description>
# 
# Arguments:
#     
# Results:
#     
proc ::measurement::Test { {w ""} } {
    # Just in case.
    destroy $w.test

    set f [frame $w.test]
    pack $f

    set ::edit cm
    set ::show cm

    frame $f.top
    pack $f.top -side top -expand 1 -fill both -padx 2m -pady 2m
    label $f.top.label -text "Input:"
    pack $f.top.label -side left 
    measurement $f.top.entry \
            -units $::edit \
            -displayunits $::show \
            -textvariable foo
    $f.top.entry configure -invalidforeground red
    pack $f.top.entry -side left -expand 1 -fill x

    frame $f.edit
    pack $f.edit -side top -expand 1 -fill both -padx 2m -pady 2m
    label $f.edit.label -text "Edit in:" -width 10
    pack $f.edit.label -side left
    foreach unit {pt cm in ft} {
        radiobutton $f.edit.$unit -text $unit -width 3 \
                -command [list $f.top.entry configure -displayunits $unit] \
                -variable edit -value $unit
        pack $f.edit.$unit -side left
    }

    frame $f.show
    pack $f.show -side top -expand 1 -fill both -padx 2m -pady 2m
    label $f.show.label -text "Export in:" -width 10
    pack $f.show.label -side left
    foreach unit {pt cm in ft} {
        radiobutton $f.show.$unit -text $unit -width 3 \
                -command [list $f.top.entry configure -units $unit] \
                -variable show -value $unit
        pack $f.show.$unit -side left
    }

    frame $f.btm
    pack $f.btm -side top -expand 1 -fill both -padx 2m -pady 2m
    label $f.btm.label -textvariable show
    pack $f.btm.label -side left 
    entry $f.btm.entry -textvariable foo
    pack $f.btm.entry -side left -expand 1 -fill x
}
# measurement::Test
# 

# Make it easier to create measurement widgets
namespace import measurement::measurement