
set rcsId {$Id: demo,v 2.6 2002/02/09 19:54:58 jfontain Exp $}

if {[catch {package require stooop 4.1}]} {


package require Tcl 8.3

package provide stooop 4.3

catch {rename proc _proc}

namespace eval ::stooop {
    variable check
    variable trace

    set check(code) {}
    if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} {
        array set ::env\
            {STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1}
    }
    set check(procedures) [expr {\
        [info exists ::env(STOOOPCHECKPROCEDURES)]&&\
        $::env(STOOOPCHECKPROCEDURES)\
    }]
    set check(data) [expr {\
        [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)\
    }]
    set check(objects) [expr {\
        [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)\
    }]
    if {$check(procedures)} {
        append check(code) {::stooop::checkProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEALL)]} {
        set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
        set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
    }
    if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
        set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES)
        if {![regexp {^(stdout|stderr)$} $trace(procedureChannel)]} {
            set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+]
        }
        set trace(procedureFormat)\
            {class: %C, procedure: %p, object: %O, arguments: %a}
        catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)}
        append check(code) {::stooop::traceProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEDATA)]} {
        set trace(dataChannel) $::env(STOOOPTRACEDATA)
        if {![regexp {^(stdout|stderr)$} $trace(dataChannel)]} {
            set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+]
        }
        set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
        catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)}
        set trace(dataOperations) rwu
        catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)}
    }

    namespace export class virtual new delete classof

    if {![info exists newId]} {
        variable newId 0
    }

    _proc new {classOrId args} {
        variable newId
        variable fullClass

        if {[string is integer $classOrId]} {
            if {[catch {\
                set fullClass([set id [incr newId]]) $fullClass($classOrId)\
            }]} {
                error "invalid object identifier $classOrId"
            }
            uplevel $fullClass($classOrId)::_copy $id $classOrId
        } else {
            set constructor ${classOrId}::[namespace tail $classOrId]
            uplevel $constructor [set id [incr newId]] $args
            set fullClass($id) [namespace qualifiers\
                [uplevel namespace which -command $constructor]\
            ]
        }
        return $id
    }

    _proc delete {args} {
        variable fullClass

        foreach id $args {
            uplevel ::stooop::deleteObject $fullClass($id) $id
            unset fullClass($id)
        }
    }

    _proc deleteObject {fullClass id} {
        uplevel ${fullClass}::~[namespace tail $fullClass] $id
        array unset ${fullClass}:: $id,*
    }

    _proc classof {id} {
        variable fullClass

        return $fullClass($id)
    }

    _proc copy {fullClass from to} {
        set index [string length $from]
        foreach {name value} [array get ${fullClass}:: $from,*] {
            set ${fullClass}::($to[string range $name $index end]) $value
        }
    }
}

_proc ::stooop::class {args} {
    variable declared

    set class [lindex $args 0]
    set declared([uplevel namespace eval $class {namespace current}]) {}
    uplevel namespace eval $class [list "::variable {}\n[lindex $args end]"]
}

_proc ::stooop::parseProcedureName {\
    namespace name fullClassVariable procedureVariable messageVariable\
} {
    variable declared
    upvar $fullClassVariable fullClass $procedureVariable procedure\
        $messageVariable message

    if {\
        [info exists declared($namespace)]&&\
        ([string length [namespace qualifiers $name]]==0)\
    } {
        set fullClass $namespace
        set procedure $name
        return 1
    } else {
        if {![string match ::* $name]} {
            if {[string equal $namespace ::]} {
                set name ::$name
            } else {
                set name ${namespace}::$name
            }
        }
        set fullClass [namespace qualifiers $name]
        if {[info exists declared($fullClass)]} {
            set procedure [namespace tail $name]
            return 1
        } else {
            if {[string length $fullClass]==0} {
                set message "procedure $name class name is empty"
            } else {
                set message "procedure $name class $fullClass is unknown"
            }
            return 0
        }
    }
}

_proc ::stooop::virtual {keyword name arguments args} {
    variable pureVirtual

    if {![string equal [uplevel namespace which -command $keyword] ::proc]} {
        error "virtual operator works only on proc, not $keyword"
    }
    if {![parseProcedureName\
        [uplevel namespace current] $name fullClass procedure message\
    ]} {
        error $message
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        error "cannot make class $fullClass constructor virtual"
    }
    if {[string equal ~$class $procedure]} {
        error "cannot make class $fullClass destructor virtual"
    }
    if {![string equal [lindex $arguments 0] this]} {
        error "cannot make static procedure $procedure of class $fullClass virtual"
    }
    set pureVirtual [expr {[llength $args]==0}]
    uplevel ::proc [list $name $arguments [lindex $args 0]]
    unset pureVirtual
}

_proc proc {name arguments args} {
    if {![::stooop::parseProcedureName\
        [uplevel namespace current] $name fullClass procedure message\
    ]} {
        uplevel _proc [list $name $arguments] $args
        return
    }
    if {[llength $args]==0} {
        error "missing body for ${fullClass}::$procedure"
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass constructor first argument must be this"
        }
        if {[string equal [lindex $arguments 1] copy]} {
            if {[llength $arguments]!=2} {
                error "class $fullClass copy constructor must have 2 arguments exactly"
            }
            if {[catch {info body ::${fullClass}::$class}]} {
                error "class $fullClass copy constructor defined before constructor"
            }
            eval ::stooop::constructorDeclaration\
                $fullClass $class 1 \{$arguments\} $args
        } else {
            eval ::stooop::constructorDeclaration\
                $fullClass $class 0 \{$arguments\} $args
            ::stooop::generateDefaultCopyConstructor $fullClass
        }
    } elseif {[string equal ~$class $procedure]} {
        if {[llength $arguments]!=1} {
            error "class $fullClass destructor must have 1 argument exactly"
        }
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass destructor argument must be this"
        }
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass destructor defined before constructor"
        }
        ::stooop::destructorDeclaration\
            $fullClass $class $arguments [lindex $args 0]
    } else {
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass member procedure $procedure defined before constructor"
        }
        ::stooop::memberProcedureDeclaration\
            $fullClass $class $procedure $arguments [lindex $args 0]
    }
}

_proc ::stooop::constructorDeclaration {fullClass class copy arguments args} {
    variable check
    variable fullBases
    variable variable

    set number [llength $args]
    if {($number%2)==0} {
        error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing"
    }
    if {[string equal [lindex $arguments end] args]} {
        set variable($fullClass) {}
    }
    if {!$copy} {
        set fullBases($fullClass) {}
    }
    foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] {
        set constructor ${base}::[namespace tail $base]
        catch {$constructor}
        set fullBase [namespace qualifiers\
            [uplevel 2 namespace which -command $constructor]\
        ]
        if {[string length $fullBase]==0} {
            if {[string match *$base $fullClass]} {
                error "class $fullClass cannot be derived from itself"
            } else {
                error "class $fullClass constructor defined before base class $base constructor"
            }
        }
        if {!$copy} {
            if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} {
                error "class $fullClass directly inherits from class $fullBase more than once"
            }
            lappend fullBases($fullClass) $fullBase
        }
        regsub -all {\n} $baseArguments { } constructorArguments($fullBase)
    }
    set constructorBody \
"::variable {}
$check(code)
"
    if {[llength $fullBases($fullClass)]>0} {
        if {[info exists variable($fullClass)]} {
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                if {\
                    [info exists variable($fullBase)]&&\
                    ([string first {$args} $constructorArguments($fullBase)]>=0)\
                } {
                    append constructorBody \
"::set _list \[::list $constructorArguments($fullBase)\]
::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\]
::unset _list
::set ${fullBase}::(\$this,_derived) $fullClass
"
                } else {
                    append constructorBody \
"$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
                }
            }
        } else {
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                append constructorBody \
"$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
            }
        }
    }
    if {$copy} {
        append constructorBody \
"::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)}
"
    }
    append constructorBody [lindex $args end]
    if {$copy} {
        _proc ${fullClass}::_copy $arguments $constructorBody
    } else {
        _proc ${fullClass}::$class $arguments $constructorBody
    }
}

_proc ::stooop::destructorDeclaration {fullClass class arguments body} {
    variable check
    variable fullBases

    set body \
"::variable {}
$check(code)
$body
"
    for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}\
        {incr index -1}\
    {
        set fullBase [lindex $fullBases($fullClass) $index]
        append body \
"::stooop::deleteObject $fullBase \$this
"
    }
    _proc ${fullClass}::~$class $arguments $body
}

_proc ::stooop::memberProcedureDeclaration {\
    fullClass class procedure arguments body\
} {
    variable check
    variable pureVirtual

    if {[info exists pureVirtual]} {
        if {$pureVirtual} {
            _proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
::uplevel \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]
"
        } else {
            _proc ${fullClass}::_$procedure $arguments \
"::variable {}
$check(code)
$body
"
            _proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} {
::return \[::uplevel \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\]
"
        }
    } else {
        _proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
$body
"
    }
}

_proc ::stooop::generateDefaultCopyConstructor {fullClass} {
    variable fullBases

    foreach fullBase $fullBases($fullClass) {
        append body \
"${fullBase}::_copy \$this \$sibling
"
    }
    append body \
"::stooop::copy $fullClass \$sibling \$this
"
    _proc ${fullClass}::_copy {this sibling} $body
}


if {[llength [array names ::env STOOOP*]]>0} {

    catch {rename ::stooop::class ::stooop::_class}
    _proc ::stooop::class {args} {
        variable trace
        variable check

        set class [lindex $args 0]
        if {$check(data)} {
            uplevel namespace eval $class\
                [list {::trace variable {} wu ::stooop::checkData}]
        }
        if {[info exists ::env(STOOOPTRACEDATA)]} {
            uplevel namespace eval $class [list\
                "::trace variable {} $trace(dataOperations) ::stooop::traceData"\
            ]
        }
        uplevel ::stooop::_class $args
    }

    if {$::stooop::check(procedures)} {
        catch {rename ::stooop::virtual ::stooop::_virtual}
        _proc ::stooop::virtual {keyword name arguments args} {
            variable interface

            uplevel ::stooop::_virtual [list $keyword $name $arguments] $args
            parseProcedureName [uplevel namespace current] $name\
                fullClass procedure message
            if {[llength $args]==0} {
                set interface($fullClass) {}
            }
        }
    }

    if {$::stooop::check(objects)} {
        _proc invokingProcedure {} {
            if {[catch {set procedure [lindex [info level -2] 0]}]} {
                return {top level}
            } elseif {[string length $procedure]==0} {
                return "namespace [uplevel 2 namespace current]"
            } else {
                return [uplevel 3 namespace which -command $procedure]
            }
        }
    }

    if {$::stooop::check(procedures)||$::stooop::check(objects)} {
        catch {rename ::stooop::new ::stooop::_new}
        _proc ::stooop::new {classOrId args} {
            variable newId
            variable check

            if {$check(procedures)} {
                variable fullClass
                variable interface
            }
            if {$check(objects)} {
                variable creator
            }
            if {$check(procedures)} {
                if {[string is integer $classOrId]} {
                    set fullName $fullClass($classOrId)
                } else {
                    set constructor ${classOrId}::[namespace tail $classOrId]
                    catch {$constructor}
                    set fullName [namespace qualifiers\
                        [uplevel namespace which -command $constructor]\
                    ]
                    set fullClass([expr {$newId+1}]) $fullName
                }
                if {[info exists interface($fullName)]} {
                    error "class $fullName with pure virtual procedures should not be instanciated"
                }
            }
            if {$check(objects)} {
                set creator([expr {$newId+1}]) [invokingProcedure]
            }
            return [uplevel ::stooop::_new $classOrId $args]
        }
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::delete {args} {
            variable fullClass
            variable deleter

            set procedure [invokingProcedure]
            foreach id $args {
                uplevel ::stooop::deleteObject $fullClass($id) $id
                unset fullClass($id)
                set deleter($id) $procedure
            }
        }
    }

    _proc ::stooop::ancestors {fullClass} {
        variable ancestors
        variable fullBases

        if {[info exists ancestors($fullClass)]} {
            return $ancestors($fullClass)
        }
        set list {}
        foreach class $fullBases($fullClass) {
            set list [concat $list [list $class] [ancestors $class]]
        }
        set ancestors($fullClass) $list
        return $list
    }

    _proc ::stooop::debugInformation {\
        className fullClassName procedureName fullProcedureName\
        thisParameterName\
    } {
        upvar $className class $fullClassName fullClass\
            $procedureName procedure $fullProcedureName fullProcedure\
            $thisParameterName thisParameter
        variable declared

        set namespace [uplevel 2 namespace current]
        if {[lsearch -exact [array names declared] $namespace]<0} return
        set fullClass [string trimleft $namespace :]
        set class [namespace tail $fullClass]
        set list [info level -2]
        if {[llength $list]==0} return
        set procedure [lindex $list 0]
        set fullProcedure [uplevel 3 namespace which -command $procedure]
        set procedure [namespace tail $procedure]
        if {[string equal $class $procedure]} {
            set procedure constructor
        } elseif {[string equal ~$class $procedure]} {
            set procedure destructor
        }
        if {[string equal [lindex [info args $fullProcedure] 0] this]} {
            set thisParameter [lindex $list 1]
        }
    }

    _proc ::stooop::checkProcedure {} {
        variable fullClass

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists this]} return
        if {[string equal $procedure constructor]} return
        if {![info exists fullClass($this)]} {
            error "$this is not a valid object identifier"
        }
        set fullName [string trimleft $fullClass($this) :]
        if {[string equal $fullName $qualifiedClass]} return
        if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} {
            error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName"
        }
    }

    _proc ::stooop::traceProcedure {} {
        variable trace

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(procedureFormat)
        regsub -all %C $text $qualifiedClass text
        regsub -all %c $text $class text
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        if {[info exists this]} {
            regsub -all %O $text $this text
            regsub -all %a $text [lrange [info level -1] 2 end] text
        } else {
            regsub -all %O $text {} text
            regsub -all %a $text [lrange [info level -1] 1 end] text
        }
        puts $trace(procedureChannel) $text
    }

    _proc ::stooop::checkData {array name operation} {
        scan $name %u,%s identifier member
        if {[info exists member]&&[string equal $member _derived]} return

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists class]} return
        set array [uplevel [list namespace which -variable $array]]
        if {![info exists procedure]} {
            if {![string equal $array ::${qualifiedClass}::]} {
                error\
                    "class access violation in class $qualifiedClass namespace"
            }
            return
        }
        if {[string equal $qualifiedProcedure ::stooop::copy]} return
        if {![string equal $array ::${qualifiedClass}::]} {
            error "class access violation in procedure $qualifiedProcedure"
        }
        if {![info exists this]} return
        if {![info exists identifier]} return
        if {$this!=$identifier} {
            error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this"
        }
    }

    _proc ::stooop::traceData {array name operation} {
        variable trace

        scan $name %u,%s identifier member
        if {[info exists member]&&[string equal $member _derived]} return

        if {\
            ![catch {lindex [info level -1] 0} procedure]&&\
            [string equal ::stooop::deleteObject $procedure]\
        } return
        set class {}
        set qualifiedClass {}
        set procedure {}
        set qualifiedProcedure {}

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(dataFormat)
        regsub -all %C $text $qualifiedClass text
        regsub -all %c $text $class text
        if {[info exists member]} {
            regsub -all %m $text $member text
        } else {
            regsub -all %m $text $name text
        }
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        regsub -all %A $text [string trimleft\
            [uplevel [list namespace which -variable $array]] :\
        ] text
        if {[info exists this]} {
            regsub -all %O $text $this text
        } else {
            regsub -all %O $text {} text
        }
        array set string {r read w write u unset}
        regsub -all %o $text $string($operation) text
        if {[string equal $operation u]} {
            regsub -all %v $text {} text
        } else {
            regsub -all %v $text [uplevel set ${array}($name)] text
        }
        puts $trace(dataChannel) $text
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::printObjects {{pattern *}} {
            variable fullClass
            variable creator

            puts "stooop::printObjects invoked from [invokingProcedure]:"
            foreach id [lsort -integer [array names fullClass]] {
                if {[string match $pattern $fullClass($id)]} {
                    puts "$fullClass($id)\($id\) + $creator($id)"
                }
            }
        }

        _proc ::stooop::record {} {
            variable fullClass
            variable checkpointFullClass

            puts "stooop::record invoked from [invokingProcedure]"
            catch {unset checkpointFullClass}
            array set checkpointFullClass [array get fullClass]
        }

        _proc ::stooop::report {{pattern *}} {
            variable fullClass
            variable checkpointFullClass
            variable creator
            variable deleter

            puts "stooop::report invoked from [invokingProcedure]:"
            set checkpointIds [lsort -integer [array names checkpointFullClass]]
            set currentIds [lsort -integer [array names fullClass]]
            foreach id $currentIds {
                if {\
                    [string match $pattern $fullClass($id)]&&\
                    ([lsearch -exact $checkpointIds $id]<0)\
                } {
                    puts "+ $fullClass($id)\($id\) + $creator($id)"
                }
            }
            foreach id $checkpointIds {
                if {\
                    [string match $pattern $checkpointFullClass($id)]&&\
                    ([lsearch -exact $currentIds $id]<0)\
                } {
                    puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)"
                }
            }
        }
    }

}
}
namespace import stooop::*
if {[catch {package require switched 2.2}]} {

package provide switched 2.2


::stooop::class switched {

    proc switched {this args} {
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        set ($this,complete) 0
        set ($this,arguments) $args
    }

    proc ~switched {this} {}

    ::stooop::virtual proc options {this}

    proc complete {this} {
        foreach description [options $this] {
            set option [lindex $description 0]
            set ($this,$option) [set default [lindex $description 1]]
            if {[llength $description]<3} {
                set initialize($option) {}
            } elseif {![string equal $default [lindex $description 2]]} {
                set ($this,$option) [lindex $description 2]
                set initialize($option) {}
            }
        }
        foreach {option value} $($this,arguments) {
            if {[catch {string compare $($this,$option) $value} different]} {
                error "$($this,_derived): unknown option \"$option\""
            }
            if {$different} {
                set ($this,$option) $value
                set initialize($option) {}
            }
        }
        unset ($this,arguments)
        foreach option [array names initialize] {
            $($this,_derived)::set$option $this $($this,$option)
        }
        set ($this,complete) 1
    }

    proc configure {this args} {
        if {[llength $args]==0} {
            return [descriptions $this]
        }
        foreach {option value} $args {
            if {![info exists ($this,$option)]} {
                error "$($this,_derived): unknown option \"$option\""
            }
        }
        if {[llength $args]==1} {
            return [description $this [lindex $args 0]]
        }
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        foreach {option value} $args {
            if {![string equal $($this,$option) $value]} {
                $($this,_derived)::set$option $this [set ($this,$option) $value]
            }
        }
    }

    proc cget {this option} {
        if {[catch {set value $($this,$option)}]} {
            error "$($this,_derived): unknown option \"$option\""
        }
        return $value
    }

    proc description {this option} {
        foreach description [options $this] {
            if {[string equal [lindex $description 0] $option]} {
                if {[llength $description]<3} {
                    lappend description $($this,$option)
                    return $description
                } else {
                    return [lreplace $description 2 2 $($this,$option)]
                }
            }
        }
    }

    proc descriptions {this} {
        set descriptions {}
        foreach description [options $this] {
            if {[llength $description]<3} {
                lappend description $($this,[lindex $description 0])
                lappend descriptions $description
            } else {
                lappend descriptions [lreplace\
                    $description 2 2 $($this,[lindex $description 0])\
                ]
            }
        }
        return $descriptions
    }

}
}

if {[catch {package require tkpiechart 6.3}]} {
set rcsId {$Id: pielabel.tcl,v 2.6 2002/05/19 10:34:41 jfontain Exp $}

::stooop::class pieLabeler {

    set (default,font) {Helvetica -12}

    proc pieLabeler {this canvas args} {
        ::set ($this,canvas) $canvas
    }

    proc ~pieLabeler {this} {}

    ::stooop::virtual proc new {this slice args}

    ::stooop::virtual proc delete {this label}

    ::stooop::virtual proc set {this label value}

    ::stooop::virtual proc label {this args}

    ::stooop::virtual proc labelBackground {this args}

    ::stooop::virtual proc selectState {this label {state {}}}

    ::stooop::virtual proc update {this left top right bottom}
    ::stooop::virtual proc updateSlices {this left top right bottom} {}

    ::stooop::virtual proc room {this arrayName}

}
set rcsId {$Id: perilabel.tcl,v 2.10 2002/05/19 15:19:59 jfontain Exp $}


::stooop::class piePeripheralLabeler {

    variable PI 3.14159265358979323846

    proc piePeripheralLabeler {this canvas args} pieLabeler {$canvas $args} switched {$args} {
        switched::complete $this
        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas -justify $switched::($this,-justify)]
        ::set ($this,valueWidth) [font measure $switched::($this,-smallfont) $switched::($this,-widestvaluetext)]
        ::set ($this,valueHeight) [font metrics $switched::($this,-smallfont) -ascent]
    }

    proc ~piePeripheralLabeler {this} {
        ::stooop::delete $($this,array)
        $pieLabeler::($this,canvas) delete pieLabeler($this)
    }

    proc options {this} {
        return [list\
            [list -bulletwidth 20 20]\
            [list -font $pieLabeler::(default,font) $pieLabeler::(default,font)]\
            [list -justify left left]\
            [list -offset 5 5]\
            [list -smallfont {Helvetica -10} {Helvetica -10}]\
            [list -widestvaluetext 0.00 0.00]\
        ]
    }

    foreach option {-bulletwidth -font -justify -offset -smallfont -widestvaluetext} {
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc set-smallfont {this value} {
        if {$switched::($this,complete)} {
            error {option -smallfont cannot be set dynamically}
        }
    }

    proc new {this slice args} {
        ::set canvas $pieLabeler::($this,canvas)
        ::set text [$canvas create text 0 0 -font $switched::($this,-smallfont) -tags pieLabeler($this)]
        ::set label [eval ::stooop::new canvasLabel $pieLabeler::($this,canvas) $args\
            [list\
                -justify $switched::($this,-justify) -bulletwidth $switched::($this,-bulletwidth)\
                -font $switched::($this,-font) -selectrelief sunken\
            ]\
        ]
        canvasLabelsArray::manage $($this,array) $label
        $canvas addtag pieLabeler($this) withtag canvasLabelsArray($($this,array))
        ::set ($this,textItem,$label) $text
        ::set ($this,slice,$label) $slice
        ::set ($this,selected,$label) 0
        return $label
    }

    proc anglePosition {degrees} {
        return [expr {(2*($degrees/90))+(($degrees%90)!=0)}]
    }

    ::set index 0
    foreach anchor {w sw s se e ne n nw} {
        ::set (anchor,[anglePosition [expr {$index*45}]]) $anchor
        incr index
    }
    unset index anchor

    proc set {this label value} {
        ::set text $($this,textItem,$label)
        position $this $text $($this,slice,$label)
        $pieLabeler::($this,canvas) itemconfigure $text -text $value
    }

    proc label {this label args} {
        if {[llength $args]==0} {
            return [switched::cget $label -text]
        } else {
            switched::configure $label -text [lindex $args 0]
        }
    }

    proc labelBackground {this label args} {
        if {[llength $args]==0} {
            return [switched::cget $label -textbackground]
        } else {
            switched::configure $label -textbackground [lindex $args 0]
        }
    }

    proc position {this text slice} {
        variable PI

        slice::data $slice data
        ::set midAngle [expr {$data(start)+($data(extent)/2.0)}]
        ::set radians [expr {$midAngle*$PI/180}]
        ::set x [expr {($data(xRadius)+$switched::($this,-offset))*cos($radians)}]
        ::set y [expr {($data(yRadius)+$switched::($this,-offset))*sin($radians)}]
        ::set angle [expr {round($midAngle)%360}]
        if {$angle>180} {
            ::set y [expr {$y-$data(height)}]
        }

        ::set canvas $pieLabeler::($this,canvas)
        ::set coordinates [$canvas coords $text]
        $canvas move $text [expr {$data(xCenter)+$x-[lindex $coordinates 0]}] [expr {$data(yCenter)-$y-[lindex $coordinates 1]}]
        $canvas itemconfigure $text -anchor $(anchor,[anglePosition $angle])
    }

    proc delete {this label} {
        canvasLabelsArray::delete $($this,array) $label
        $pieLabeler::($this,canvas) delete $($this,textItem,$label)
        unset ($this,textItem,$label) ($this,slice,$label) ($this,selected,$label)
        foreach label [canvasLabelsArray::labels $($this,array)] {
            position $this $($this,textItem,$label) $($this,slice,$label)
        }
    }

    proc selectState {this label {selected {}}} {
        if {[string length $selected]==0} {
            return $($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set ($this,selected,$label) $selected
    }

    proc update {this left top right bottom} {
        ::set canvas $pieLabeler::($this,canvas)
        ::set array $($this,array)
        ::set width [expr {$right-$left}]
        if {$width!=[switched::cget $array -width]} {
            switched::configure $array -width $width
        } else {
            canvasLabelsArray::update $array
        }
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left-$x}] [expr {$bottom-[canvasLabelsArray::height $array]-$y}]
    }

    proc updateSlices {this left top right bottom} {
        foreach label [canvasLabelsArray::labels $($this,array)] {
            position $this $($this,textItem,$label) $($this,slice,$label)
        }
    }

    proc room {this arrayName} {
        upvar $arrayName data

        ::set data(left) [expr {$($this,valueWidth)+$switched::($this,-offset)}]
        ::set data(right) $data(left)
        ::set data(top) [expr {$switched::($this,-offset)+$($this,valueHeight)}]
        ::set box [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
        if {[llength $box]==0} {
            ::set data(bottom) $data(top)
        } else {
            ::set data(bottom) [expr {$data(top)+[lindex $box 3]-[lindex $box 1]}]
        }
    }

}
set rcsId {$Id: boxlabel.tcl,v 2.10 2002/05/19 15:19:59 jfontain Exp $}


::stooop::class pieBoxLabeler {

    proc pieBoxLabeler {this canvas args} pieLabeler {$canvas $args} switched {$args} {
        ::set ($this,array) [::stooop::new canvasLabelsArray $canvas]
        switched::complete $this
    }

    proc ~pieBoxLabeler {this} {
        ::stooop::delete $($this,array)
    }

    proc options {this} {
        return [list\
            [list -font $pieLabeler::(default,font) $pieLabeler::(default,font)]\
            [list -justify left left]\
            [list -offset 5 5]\
            [list -xoffset 0 0]\
        ]
    }

    foreach option {-font -justify -offset -xoffset} {
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc new {this slice args} {
        ::set label [eval ::stooop::new canvasLabel $pieLabeler::($this,canvas) $args\
            [list -justify $switched::($this,-justify) -font $switched::($this,-font) -selectrelief sunken]\
        ]
        canvasLabelsArray::manage $($this,array) $label
        $pieLabeler::($this,canvas) addtag pieLabeler($this) withtag canvasLabelsArray($($this,array))
        switched::configure $label -text [switched::cget $label -text]:
        ::set ($this,selected,$label) 0
        return $label
    }

    proc delete {this label} {
        canvasLabelsArray::delete $($this,array) $label
        unset ($this,selected,$label)
    }

    proc set {this label value} {
        regsub {:[^:]*$} [switched::cget $label -text] ": $value" text
        switched::configure $label -text $text
    }

    proc label {this label args} {
        ::set text [switched::cget $label -text]
        if {[llength $args]==0} {
            regexp {^(.*):} $text dummy text
            return $text
        } else {
            regsub {^.*:} $text [lindex $args 0]: text
            switched::configure $label -text $text
        }
    }

    proc labelBackground {this label args} {
        if {[llength $args]==0} {
            return [switched::cget $label -textbackground]
        } else {
            switched::configure $label -textbackground [lindex $args 0]
        }
    }

    proc selectState {this label {selected {}}} {
        if {[string length $selected]==0} {
            return $($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set ($this,selected,$label) $selected
    }

    proc update {this left top right bottom} {
        ::set canvas $pieLabeler::($this,canvas)
        ::set array $($this,array)
        ::set width [expr {$right-$left}]
        if {$width!=[switched::cget $array -width]} {
            switched::configure $array -width $width
        } else {
            canvasLabelsArray::update $array
        }
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left-$x}] [expr {$bottom-[canvasLabelsArray::height $array]-$y}]
    }

    proc room {this arrayName} {
        upvar $arrayName data

        ::set data(left) 0
        ::set data(right) 0
        ::set data(top) 0
        ::set box [$pieLabeler::($this,canvas) bbox canvasLabelsArray($($this,array))]
        if {[llength $box]==0} {
            ::set data(bottom) 0
        } else {
            ::set data(bottom) [expr {[lindex $box 3]-[lindex $box 1]+$switched::($this,-offset)}]
        }
    }
}
set rcsId {$Id: relirect.tcl,v 1.3 2002/05/19 10:32:12 jfontain Exp $}


::stooop::class canvasReliefRectangle {

    proc canvasReliefRectangle {this canvas args} switched {$args} {
        set ($this,topLeft) [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)]
        set ($this,bottomRight) [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)]
        set ($this,canvas) $canvas
        switched::complete $this
    }

    proc ~canvasReliefRectangle {this} {
        $($this,canvas) delete canvasReliefRectangle($this)
    }

    proc options {this} {
        return [list\
            [list -background white]\
            [list -coordinates {0 0 0 0} {0 0 0 0}]\
            [list -relief flat flat]\
        ]
    }

    proc set-background {this value} {
        set intensity 65535
        foreach {red green blue} [winfo rgb $($this,canvas) $value] {}
        if {(($red*0.5*$red)+($green*1.0*$green)+($blue*0.28*$blue))<($intensity*0.05*$intensity)} {
            set ($this,dark) [format {#%04X%04X%04X}\
                [expr {($intensity+(3*$red))/4}] [expr {($intensity+(3*$green))/4}] [expr {($intensity+(3*$blue))/4}]\
            ]
        } else {
            set ($this,dark) [format {#%04X%04X%04X} [expr {(60*$red)/100}] [expr {(60*$green)/100}] [expr {(60*$blue)/100}]]
        }
        if {$green>($intensity*0.95)} {
            set ($this,light) [format {#%04X%04X%04X} [expr {(90*$red)/100}] [expr {(90*$green)/100}] [expr {(90*$blue)/100}]]
        } else {
            set tmp1 [expr {(14*$red)/10}]
            if {$tmp1>$intensity} {set tmp1 $intensity}
            set tmp2 [expr {($intensity+$red)/2}]
            set lightRed [expr {($tmp1>$tmp2)?$tmp1:$tmp2}]
            set tmp1 [expr {(14*$green)/10}]
            if {$tmp1>$intensity} {set tmp1 $intensity}
            set tmp2 [expr {($intensity+$green)/2}]
            set lightGreen [expr {($tmp1>$tmp2)?$tmp1:$tmp2}]
            set tmp1 [expr {(14*$blue)/10}]
            if {$tmp1>$intensity} {set tmp1 $intensity}
            set tmp2 [expr {($intensity+$blue)/2}]
            set lightBlue [expr {($tmp1>$tmp2)?$tmp1:$tmp2}]
            set ($this,light) [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue]
        }
        update $this
    }

    proc set-coordinates {this value} {
        foreach {left top right bottom} $value {}
        $($this,canvas) coords $($this,topLeft) $left $bottom $left $top $right $top
        $($this,canvas) coords $($this,bottomRight) $right $top $right $bottom $left $bottom
    }

    proc set-relief {this value} {
        if {![info exists ($this,dark)]} return
        update $this
    }

    proc update {this} {
        switch $switched::($this,-relief) {
            flat {
                $($this,canvas) itemconfigure canvasReliefRectangle($this) -fill $switched::($this,-background)
            }
            raised {
                $($this,canvas) itemconfigure $($this,topLeft) -fill $($this,light)
                $($this,canvas) itemconfigure $($this,bottomRight) -fill $($this,dark)
            }
            sunken {
                $($this,canvas) itemconfigure $($this,topLeft) -fill $($this,dark)
                $($this,canvas) itemconfigure $($this,bottomRight) -fill $($this,light)
            }
            default {
                error "bad relief value \"$value\": must be flat, raised or sunken"
            }
        }
    }

}
set rcsId {$Id: canlabel.tcl,v 2.9 2002/05/19 15:19:59 jfontain Exp $}


::stooop::class canvasLabel {

    proc canvasLabel {this canvas args} switched {$args} {
        set ($this,canvas) $canvas
        set ($this,origin) [$canvas create image 0 0 -tags canvasLabel($this)]
        set ($this,selectRectangle) [$canvas create rectangle 0 0 0 0 -tags canvasLabel($this)]
        set ($this,rectangle) [$canvas create rectangle 0 0 0 0 -tags canvasLabel($this)]
        set ($this,text) [$canvas create text 0 0 -tags canvasLabel($this)]
        switched::complete $this
    }

    proc ~canvasLabel {this} {
        eventuallyDeleteRelief $this
        $($this,canvas) delete canvasLabel($this)
    }

    proc options {this} {
        return [list\
            [list -anchor center center]\
            [list -background {} {}]\
            [list -bordercolor black black]\
            [list -borderwidth 1 1]\
            [list -bulletwidth 10 10]\
            [list -font {Helvetica -12}]\
            [list -foreground black black]\
            [list -justify left left]\
            [list -minimumwidth 0 0]\
            [list -padding 2 2]\
            [list -scale {1 1} {1 1}]\
            [list -select 0 0]\
            [list -selectrelief flat flat]\
            [list -stipple {} {}]\
            [list -text {} {}]\
            [list -textbackground {} {}]\
            [list -width 0 0]\
        ]
    }

    proc set-background {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -fill $value
    }

    proc set-bordercolor {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -outline $value
    }

    proc set-borderwidth {this value} {
        if {![string equal $switched::($this,-selectrelief) flat]&&($value>1)} {
            error "border width greater than 1 is not supported with $switched::($this,-selectrelief) select relief"
        }
        $($this,canvas) itemconfigure $($this,selectRectangle) -width $value
        $($this,canvas) itemconfigure $($this,rectangle) -width $value
        update $this
    }

    proc set-foreground {this value} {
        $($this,canvas) itemconfigure $($this,text) -fill $value
    }

    proc set-scale {this value} {
        update $this
    }

    proc set-stipple {this value} {
        $($this,canvas) itemconfigure $($this,rectangle) -stipple $value
    }

    foreach option {-anchor -bulletwidth -minimumwidth -padding -select -textbackground} {
        proc set$option {this value} {update $this}
    }

    foreach option {-font -justify -text -width} {
        proc set$option {this value} "
            \$(\$this,canvas) itemconfigure \$(\$this,text) $option \$value
            update \$this
        "
    }

    proc set-selectrelief {this value} {
        if {![regexp {^(flat|raised|sunken)$} $value]} {
            error "bad relief value \"$value\": must be flat, raised or sunken"
        }
        if {[string equal $value flat]} {
            eventuallyDeleteRelief $this
        } else {
            if {$switched::($this,-borderwidth)>1} {
                error "border width greater than 1 is not supported with $value select relief"
            }
        }
        update $this
    }

    proc eventuallyDeleteRelief {this} {
        if {[info exists ($this,relief)]} {
            ::stooop::delete $($this,relief)
            unset ($this,relief)
        }
    }

    proc updateRelief {this coordinates} {
        if {$switched::($this,-select)} {
            set relief $switched::($this,-selectrelief)
            if {[string equal $relief flat]} {
                eventuallyDeleteRelief $this
            } else {
                set canvas $($this,canvas)
                if {![info exists ($this,relief)]} {
                    set ($this,relief) [::stooop::new canvasReliefRectangle $canvas -relief $relief]
                    set reliefTag canvasReliefRectangle($($this,relief))
                    foreach tag [$canvas gettags canvasLabel($this)] {
                        $canvas addtag $tag withtag $reliefTag
                    }
                }
                set background $switched::($this,-textbackground)
                if {[string length $background]==0} {
                    set background [$canvas cget -background]
                }
                switched::configure $($this,relief) -background $background -coordinates {0 0 0 0}
                switched::configure $($this,relief) -coordinates $coordinates
            }
        } else {
            eventuallyDeleteRelief $this
        }
    }

    proc update {this} {
        set canvas $($this,canvas)
        set rectangle $($this,rectangle)
        set selectRectangle $($this,selectRectangle)
        set text $($this,text)

        foreach {x y} [$canvas coords $($this,origin)] {}

        set border [$canvas itemcget $rectangle -width]
        set textBox [$canvas bbox $text]
        set textWidth [expr {[lindex $textBox 2]-[lindex $textBox 0]}]
        set padding [winfo fpixels $canvas $switched::($this,-padding)]
        set bulletWidth [winfo fpixels $canvas $switched::($this,-bulletwidth)]

        $canvas itemconfigure $selectRectangle -fill {} -outline {}

        set width [expr {$bulletWidth+$border+$padding+$textWidth}]
        set halfHeight [expr {(([lindex $textBox 3]-[lindex $textBox 1])/2.0)+$border}]
        if {$width<$switched::($this,-minimumwidth)} {
            set width $switched::($this,-minimumwidth)
        }
        set halfWidth [expr {$width/2.0}]
        set left [expr {$x-$halfWidth}]
        set top [expr {$y-$halfHeight}]
        set right [expr {$x+$halfWidth}]
        set bottom [expr {$y+$halfHeight}]
        $canvas coords $text [expr {$left+$bulletWidth+$border+$padding+($textWidth/2.0)}] $y
        $canvas coords $selectRectangle $left $top $right $bottom
        $canvas coords $rectangle $left $top [expr {$left+$bulletWidth}] $bottom
        $canvas itemconfigure $selectRectangle\
            -fill $switched::($this,-textbackground) -outline $switched::($this,-textbackground)
        updateRelief $this [list [expr {$left+$bulletWidth+1}] $top $right $bottom]
        set anchor $switched::($this,-anchor)
        set xDelta [expr {([string match *w $anchor]-[string match *e $anchor])*$halfWidth}]
        set yDelta [expr {([string match n* $anchor]-[string match s* $anchor])*$halfHeight}]
        $canvas move $rectangle $xDelta $yDelta
        $canvas move $selectRectangle $xDelta $yDelta
        $canvas move $text $xDelta $yDelta
        if {[info exists ($this,relief)]} {
            $canvas move canvasReliefRectangle($($this,relief)) $xDelta $yDelta
        }
        eval $canvas scale canvasLabel($this) $x $y $switched::($this,-scale)
    }

}
set rcsId {$Id: labarray.tcl,v 2.6 2002/05/19 15:19:59 jfontain Exp $}


::stooop::class canvasLabelsArray {

    proc canvasLabelsArray {this canvas args} switched {$args} {
        set ($this,canvas) $canvas
        set ($this,origin) [$canvas create image 0 0 -tags canvasLabelsArray($this)]
        set ($this,labels) {}
        switched::complete $this
    }

    proc ~canvasLabelsArray {this} {
        eval ::stooop::delete $($this,labels)
        $($this,canvas) delete canvasLabelsArray($this)
    }

    proc options {this} {
        return [list\
            [list -justify left left]\
            [list -width 100]\
        ]
    }

    proc set-justify {this value} {
        if {$switched::($this,complete)} {
            error {option -justify cannot be set dynamically}
        }
    }

    proc set-width {this value} {
        set ($this,width) [winfo fpixels $($this,canvas) $value]
        update $this
    }

    proc manage {this label} {
        $($this,canvas) addtag canvasLabelsArray($this) withtag canvasLabel($label)
        lappend ($this,labels) $label
        update $this
    }

    proc delete {this label} {
        set index [lsearch -exact $($this,labels) $label]
        if {$index<0} {
            error "invalid label $label for canvas labels array $this"
        }
        set ($this,labels) [lreplace $($this,labels) $index $index]
        ::stooop::delete $label
        update $this
    }

    proc update {this} {
        set canvas $($this,canvas)
        set halfWidth [expr {round($($this,width)/2.0)}]
        foreach {xOrigin yOrigin} [$canvas coords $($this,origin)] {}
        set x 0; set y 0
        set height 0
        set column 0
        foreach label $($this,labels) {
            foreach {left top right bottom} [$canvas bbox canvasLabel($label)] {}
            set wide [expr {($right-$left)>$halfWidth}]
            if {$wide} {
                set x 0; incr y $height; set height 0
            }
            switched::configure $label -anchor nw
            foreach {xDelta yDelta} [$canvas coords canvasLabel($label)] {}
            $canvas move canvasLabel($label) [expr {$xOrigin+$x-$xDelta}] [expr {$yOrigin+$y-$yDelta}]
            set value [expr {$bottom-$top}]
            if {$value>$height} {
                set height $value
            }
            if {([incr x $halfWidth]>$halfWidth)||$wide} {
                set x 0; incr y $height; set height 0
            }
        }
    }

    proc labels {this} {
        return $($this,labels)
    }

    proc height {this} {
        set list [$($this,canvas) bbox canvasLabelsArray($this)]
        if {[llength $list]==0} {
            return 0
        }
        foreach {left top right bottom} $list {}
        return [expr {$bottom-$top}]
    }

}
set rcsId {$Id: slice.tcl,v 2.5 2002/05/19 15:14:38 jfontain Exp $}


::stooop::class slice {
    variable PI 3.14159265358979323846
}

proc slice::slice {this canvas xRadius yRadius args} switched {$args} {
    set ($this,canvas) $canvas
    set ($this,xRadius) $xRadius
    set ($this,yRadius) $yRadius
    switched::complete $this
    complete $this
    update $this
}

proc slice::~slice {this} {
    if {[string length $switched::($this,-deletecommand)]>0} {
        uplevel #0 $switched::($this,-deletecommand)
    }
    $($this,canvas) delete slice($this)
}

proc slice::options {this} {
    return [list\
        [list -bottomcolor {} {}]\
        [list -deletecommand {} {}]\
        [list -height 0 0]\
        [list -scale {1 1} {1 1}]\
        [list -startandextent {0 0} {0 0}]\
        [list -topcolor {} {}]\
    ]
}

foreach option {-bottomcolor -height -topcolor} {
    proc slice::set$option {this value} "
        if {\$switched::(\$this,complete)} {
            error {option $option cannot be set dynamically}
        }
    "
}

proc slice::set-deletecommand {this value} {}

proc slice::set-scale {this value} {
    if {$switched::($this,complete)&&($value>0)} {
        update $this
    }
}

proc slice::set-startandextent {this value} {
    foreach {start extent} $value {}
    set ($this,start) [normalizedAngle $start]
    if {$extent<0} {
        set ($this,extent) 0
    } elseif {$extent>=360} {
        set ($this,extent) [expr {360-pow(10,-$::tcl_precision+3)}]
    } else {
        set ($this,extent) $extent
    }
    if {$switched::($this,complete)} {
        update $this
    }
}

proc slice::normalizedAngle {value} {
    while {$value>=180} {
        set value [expr {$value-360}]
    }
    while {$value<-180} {
        set value [expr {$value+360}]
    }
    return $value
}

proc slice::complete {this} {
    set canvas $($this,canvas)
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    set bottomColor $switched::($this,-bottomcolor)
    set ($this,origin) [$canvas create image -$xRadius -$yRadius -tags slice($this)]
    if {$switched::($this,-height)>0} {
        set ($this,startBottomArcFill) [$canvas create arc\
            0 0 0 0 -style chord -extent 0 -fill $bottomColor -outline $bottomColor -tags slice($this)\
        ]
        set ($this,startPolygon) [$canvas create polygon 0 0 0 0 0 0 -fill $bottomColor -tags slice($this)]
        set ($this,startBottomArc) [$canvas create arc 0 0 0 0 -style arc -extent 0 -fill black -tags slice($this)]

        set ($this,endBottomArcFill) [$canvas create arc\
            0 0 0 0 -style chord -extent 0 -fill $bottomColor -outline $bottomColor -tags slice($this)\
        ]
        set ($this,endPolygon) [$canvas create polygon 0 0 0 0 0 0 -fill $bottomColor -tags slice($this)]
        set ($this,endBottomArc) [$canvas create arc 0 0 0 0 -style arc -extent 0 -fill black -tags slice($this)]

        set ($this,startLeftLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,startRightLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,endLeftLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set ($this,endRightLine) [$canvas create line 0 0 0 0 -tags slice($this)]
    }
    set ($this,topArc) [$canvas create arc\
        -$xRadius -$yRadius $xRadius $yRadius -fill $switched::($this,-topcolor) -tags slice($this)\
    ]
    $canvas move slice($this) $xRadius $yRadius
}

proc slice::update {this} {
    set canvas $($this,canvas)
    set coordinates [$canvas coords $($this,origin)]
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    $canvas coords $($this,origin) -$xRadius -$yRadius
    $canvas coords $($this,topArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas itemconfigure $($this,topArc) -start $($this,start) -extent $($this,extent)
    if {$switched::($this,-height)>0} {
        updateBottom $this
    }
    $canvas move slice($this) [expr {[lindex $coordinates 0]+$xRadius}] [expr {[lindex $coordinates 1]+$yRadius}]
    eval $canvas scale slice($this) $coordinates $switched::($this,-scale)
}

proc slice::updateBottom {this} {
    variable PI

    set start $($this,start)
    set extent $($this,extent)

    set canvas $($this,canvas)
    set xRadius $($this,xRadius)
    set yRadius $($this,yRadius)
    set height $switched::($this,-height)

    $canvas itemconfigure $($this,startBottomArcFill) -extent 0
    $canvas coords $($this,startBottomArcFill) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,startBottomArcFill) 0 $height
    $canvas itemconfigure $($this,startBottomArc) -extent 0
    $canvas coords $($this,startBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,startBottomArc) 0 $height
    $canvas coords $($this,startLeftLine) 0 0 0 0
    $canvas coords $($this,startRightLine) 0 0 0 0
    $canvas itemconfigure $($this,endBottomArcFill) -extent 0
    $canvas coords $($this,endBottomArcFill) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,endBottomArcFill) 0 $height
    $canvas itemconfigure $($this,endBottomArc) -extent 0
    $canvas coords $($this,endBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $($this,endBottomArc) 0 $height
    $canvas coords $($this,endLeftLine) 0 0 0 0
    $canvas coords $($this,endRightLine) 0 0 0 0
    $canvas coords $($this,startPolygon) 0 0 0 0 0 0 0 0
    $canvas coords $($this,endPolygon) 0 0 0 0 0 0 0 0

    set startX [expr {$xRadius*cos($start*$PI/180)}]
    set startY [expr {-$yRadius*sin($start*$PI/180)}]
    set end [normalizedAngle [expr {$start+$extent}]]
    set endX [expr {$xRadius*cos($end*$PI/180)}]
    set endY [expr {-$yRadius*sin($end*$PI/180)}]

    set startBottom [expr {$startY+$height}]
    set endBottom [expr {$endY+$height}]

    if {(($start>=0)&&($end>=0))||(($start<0)&&($end<0))} {
        if {$extent<=180} {
            if {$start<0} {
                $canvas itemconfigure $($this,startBottomArcFill) -start $start -extent $extent
                $canvas itemconfigure $($this,startBottomArc) -start $start -extent $extent
                $canvas coords $($this,startPolygon) $startX $startY $endX $endY $endX $endBottom $startX $startBottom
                $canvas coords $($this,startLeftLine) $startX $startY $startX $startBottom
                $canvas coords $($this,startRightLine) $endX $endY $endX $endBottom
            }
        } else {
            if {$start<0} {
                $canvas itemconfigure $($this,startBottomArcFill) -start 0 -extent $start
                $canvas itemconfigure $($this,startBottomArc) -start 0 -extent $start
                $canvas coords $($this,startPolygon) $startX $startY $xRadius 0 $xRadius $height $startX $startBottom
                $canvas coords $($this,startLeftLine) $startX $startY $startX $startBottom
                $canvas coords $($this,startRightLine) $xRadius 0 $xRadius $height

                set bottomArcExtent [expr {$end+180}]
                $canvas itemconfigure $($this,endBottomArcFill) -start -180 -extent $bottomArcExtent
                $canvas itemconfigure $($this,endBottomArc) -start -180 -extent $bottomArcExtent
                $canvas coords $($this,endPolygon) -$xRadius 0 $endX $endY $endX $endBottom -$xRadius $height
                $canvas coords $($this,endLeftLine) -$xRadius 0 -$xRadius $height
                $canvas coords $($this,endRightLine) $endX $endY $endX $endBottom
            } else {
                $canvas itemconfigure $($this,startBottomArcFill) -start 0 -extent -180
                $canvas itemconfigure $($this,startBottomArc) -start 0 -extent -180
                $canvas coords $($this,startPolygon) -$xRadius 0 $xRadius 0 $xRadius $height -$xRadius $height
                $canvas coords $($this,startLeftLine) -$xRadius 0 -$xRadius $height
                $canvas coords $($this,startRightLine) $xRadius 0 $xRadius $height
            }
        }
    } else {
        if {$start<0} {
            $canvas itemconfigure $($this,startBottomArcFill) -start 0 -extent $start
            $canvas itemconfigure $($this,startBottomArc) -start 0 -extent $start
            $canvas coords $($this,startPolygon) $startX $startY $xRadius 0 $xRadius $height $startX $startBottom
            $canvas coords $($this,startLeftLine) $startX $startY $startX $startBottom
            $canvas coords $($this,startRightLine) $xRadius 0 $xRadius $height
        } else {
            set bottomArcExtent [expr {$end+180}]
            $canvas itemconfigure $($this,endBottomArcFill) -start -180 -extent $bottomArcExtent
            $canvas itemconfigure $($this,endBottomArc) -start -180 -extent $bottomArcExtent
            $canvas coords $($this,endPolygon) -$xRadius 0 $endX $endY $endX $endBottom -$xRadius $height
            $canvas coords $($this,startLeftLine) -$xRadius 0 -$xRadius $height
            $canvas coords $($this,startRightLine) $endX $endY $endX $endBottom
        }
    }
}

proc slice::rotate {this angle} {
    if {$angle==0} return
    set ($this,start) [normalizedAngle [expr {$($this,start)+$angle}]]
    update $this
}

proc slice::data {this arrayName} {
    upvar $arrayName data

    set data(start) $($this,start)
    set data(extent) $($this,extent)
    foreach {x y} $switched::($this,-scale) {}
    set data(xRadius) [expr {$x*$($this,xRadius)}]
    set data(yRadius) [expr {$y*$($this,yRadius)}]
    set data(height) [expr {$y*$switched::($this,-height)}]
    foreach {x y} [$($this,canvas) coords $($this,origin)] {}
    set data(xCenter) [expr {$x+$data(xRadius)}]
    set data(yCenter) [expr {$y+$data(yRadius)}]
}
set rcsId {$Id: selector.tcl,v 2.4 2002/05/19 10:34:41 jfontain Exp $}


::stooop::class selector {

    proc selector {this args} switched {$args} {
        ::set ($this,order) 0
        switched::complete $this
    }

    proc ~selector {this} {
        variable ${this}selected
        variable ${this}order

        catch {::unset ${this}selected ${this}order}
    }

    proc options {this} {
        return [::list\
            [::list -selectcommand {} {}]\
        ]
    }

    proc set-selectcommand {this value} {}

    proc set {this indices selected} {
        variable ${this}selected
        variable ${this}order

        ::set select {}
        ::set deselect {}
        foreach index $indices {
            if {[info exists ${this}selected($index)]&&($selected==[::set ${this}selected($index)])} continue
            if {$selected} {
                lappend select $index
                ::set ${this}selected($index) 1
            } else {
                lappend deselect $index
                ::set ${this}selected($index) 0
            }
            ::set ${this}order($index) $($this,order)
            incr ($this,order)
        }
        update $this $select $deselect
    }

    proc update {this selected deselected} {
        if {[string length $switched::($this,-selectcommand)]==0} return
        if {[llength $selected]>0} {
            uplevel #0 $switched::($this,-selectcommand) [::list $selected] 1
        }
        if {[llength $deselected]>0} {
            uplevel #0 $switched::($this,-selectcommand) [::list $deselected] 0
        }
    }

    proc unset {this indices} {
        variable ${this}selected
        variable ${this}order

        foreach index $indices {
            ::unset ${this}selected($index) ${this}order($index)
        }
    }

    proc ordered {this index1 index2} {
        variable ${this}order

        return [expr {[::set ${this}order($index1)]-[::set ${this}order($index2)]}]
    }


    proc add {this indices} {
        set $this $indices 0
    }

    proc remove {this indices} {
        unset $this $indices
    }

    proc select {this indices} {
        clear $this
        set $this $indices 1
        ::set ($this,lastSelected) [lindex $indices end]
    }

    proc deselect {this indices} {
        set $this $indices 0
    }

    proc toggle {this indices} {
        variable ${this}selected
        variable ${this}order

        ::set select {}
        ::set deselect {}
        foreach index $indices {
            if {[::set ${this}selected($index)]} {
                lappend deselect $index
                ::set ${this}selected($index) 0
                if {[info exists ($this,lastSelected)]&&($index==$($this,lastSelected))} {
                    ::unset ($this,lastSelected)
                }
            } else {
                lappend select $index
                ::set ${this}selected($index) 1
                ::set ($this,lastSelected) $index
            }
            ::set ${this}order($index) $($this,order)
            incr ($this,order)
        }
        update $this $select $deselect
    }

    ::stooop::virtual proc extend {this index} {}

    proc clear {this} {
        variable ${this}selected

        set $this [array names ${this}selected] 0
    }

    ::stooop::virtual proc selected {this} {
        variable ${this}selected

        ::set list {}
        foreach {index value} [array get ${this}selected] {
            if {$value} {
                lappend list $index
            }
        }
        return [lsort -command "ordered $this" $list]
    }

    ::stooop::virtual proc list {this} {
        variable ${this}selected

        return [lsort -command "ordered $this" [array names ${this}selected]]
    }

}

set rcsId {$Id: objselec.tcl,v 1.9 2002/05/19 10:32:12 jfontain Exp $}



::stooop::class objectSelector {

    proc objectSelector {this args} selector {$args} {}

    proc ~objectSelector {this} {}


    proc extend {this id} {
        if {[info exists selector::($this,lastSelected)]} {
            set list [lsort -integer [selector::list $this]]
            set last [lsearch -exact $list $selector::($this,lastSelected)]
            set index [lsearch -exact $list $id]
            selector::clear $this
            if {$index>$last} {
                selector::set $this [lrange $list $last $index] 1
            } else {
                selector::set $this [lrange $list $index $last] 1
            }
        } else {
            selector::select $this $id
        }
    }

}
set rcsId {$Id: pie.tcl,v 2.15 2002/05/19 15:19:59 jfontain Exp $}


package provide tkpiechart 6.5

::stooop::class pie {
    set (colors) {#7FFFFF #7FFF7F #FF7F7F #FFFF7F #7F7FFF #FFBF00 #BFBFBF #FF7FFF #FFFFFF}
}

proc pie::pie {this canvas x y args} switched {$args} {
    set ($this,canvas) $canvas
    set ($this,colorIndex) 0
    set ($this,slices) {}
    set ($this,origin) [$canvas create image $x $y -tags pie($this)]
    switched::complete $this
    complete $this
}

proc pie::~pie {this} {
    if {[info exists ($this,title)]} {
        $($this,canvas) delete $($this,title)
    }
    ::stooop::delete $($this,labeler)
    eval ::stooop::delete $($this,slices) $($this,backgroundSlice)
    if {[info exists ($this,selector)]} {
        ::stooop::delete $($this,selector)
    }
    $($this,canvas) delete $($this,origin)
}

proc pie::options {this} {
    return [list\
        [list -autoupdate 1 1]\
        [list -background {} {}]\
        [list -colors $(colors) $(colors)]\
        [list -height 200]\
        [list -labeler 0 0]\
        [list -selectable 0 0]\
        [list -thickness 0]\
        [list -title {} {}]\
        [list -titlefont {Helvetica -12 bold} {Helvetica -12 bold}]\
        [list -titleoffset 2 2]\
        [list -width 200]\
    ]
}

proc pie::set-autoupdate {this value} {}

foreach option {-background -colors -labeler -selectable -title -titlefont -titleoffset} {
    proc pie::set$option {this value} "
        if {\$switched::(\$this,complete)} {
            error {option $option cannot be set dynamically}
        }
    "
}

proc pie::set-thickness {this value} {
    if {$switched::($this,complete)} {
        error {option -thickness cannot be set dynamically}
    }
    set ($this,thickness) [winfo fpixels $($this,canvas) $value]
}

proc pie::set-height {this value} {
    set ($this,height) [expr {[winfo fpixels $($this,canvas) $value]-1}]
    if {$switched::($this,complete)} {
        update $this
    } else {
        set ($this,initialHeight) $($this,height)
    }
}
proc pie::set-width {this value} {
    set ($this,width) [expr {[winfo fpixels $($this,canvas) $value]-1}]
    if {$switched::($this,complete)} {
        update $this
    } else {
        set ($this,initialWidth) $($this,width)
    }
}

proc pie::complete {this} {
    set canvas $($this,canvas)

    if {$switched::($this,-labeler)==0} {
        set ($this,labeler) [::stooop::new pieBoxLabeler $canvas]
    } else {
        set ($this,labeler) $switched::($this,-labeler)
    }
    $canvas addtag pie($this) withtag pieLabeler($($this,labeler))

    if {[string length $switched::($this,-background)]==0} {
        set bottomColor {}
    } else {
        set bottomColor [darken $switched::($this,-background) 60]
    }
    set slice [::stooop::new slice\
        $canvas [expr {$($this,initialWidth)/2}] [expr {$($this,initialHeight)/2}]\
        -startandextent {90 360} -height $($this,thickness) -topcolor $switched::($this,-background) -bottomcolor $bottomColor\
    ]
    $canvas addtag pie($this) withtag slice($slice)
    $canvas addtag pieSlices($this) withtag slice($slice)
    set ($this,backgroundSlice) $slice
    if {[string length $switched::($this,-title)]==0} {
        set ($this,titleRoom) 0
    } else {
        set ($this,title) [$canvas create text 0 0\
            -anchor n -text $switched::($this,-title) -font $switched::($this,-titlefont) -tags pie($this)\
        ]
        set ($this,titleRoom) [expr {\
            [font metrics $switched::($this,-titlefont) -ascent]+[winfo fpixels $canvas $switched::($this,-titleoffset)]\
        }]
    }
    update $this
}

proc pie::newSlice {this {text {}}} {
    set canvas $($this,canvas)

    set start 90
    foreach slice $($this,slices) {
        set start [expr {$start-$slice::($slice,extent)}]
    }
    set color [lindex $switched::($this,-colors) $($this,colorIndex)]
    set ($this,colorIndex) [expr {($($this,colorIndex)+1)%[llength $switched::($this,-colors)]}]

    set slice [::stooop::new slice\
        $canvas [expr {$($this,initialWidth)/2}] [expr {$($this,initialHeight)/2}] -startandextent "$start 0"\
        -height $($this,thickness) -topcolor $color -bottomcolor [darken $color 60]\
    ]
    eval $canvas move slice($slice) [$canvas coords pieSlices($this)]
    $canvas addtag pie($this) withtag slice($slice)
    $canvas addtag pieSlices($this) withtag slice($slice)
    lappend ($this,slices) $slice

    if {[string length $text]==0} {
        set text "slice [llength $($this,slices)]"
    }
    set labeler $($this,labeler)
    set label [pieLabeler::new $labeler $slice -text $text -background $color]
    set ($this,sliceLabel,$slice) $label
    $canvas addtag pie($this) withtag pieLabeler($labeler)

    update $this

    if {$switched::($this,-selectable)} {
        if {![info exists ($this,selector)]} {
            set ($this,selector) [::stooop::new objectSelector -selectcommand "pie::setLabelsState $this"]
        }
        set selector $($this,selector)
        selector::add $selector $label
        $canvas bind canvasLabel($label) <ButtonRelease-1> "selector::select $selector $label"
        $canvas bind slice($slice) <ButtonRelease-1> "selector::select $selector $label"
        $canvas bind canvasLabel($label) <Control-ButtonRelease-1> "selector::toggle $selector $label"
        $canvas bind slice($slice) <Control-ButtonRelease-1> "selector::toggle $selector $label"
        $canvas bind canvasLabel($label) <Shift-ButtonRelease-1> "selector::extend $selector $label"
        $canvas bind slice($slice) <Shift-ButtonRelease-1> "selector::extend $selector $label"
    }

    return $slice
}

proc pie::deleteSlice {this slice} {
    set index [lsearch -exact $($this,slices) $slice]
    if {$index<0} {
        error "invalid slice $slice for pie $this"
    }
    set ($this,slices) [lreplace $($this,slices) $index $index]
    set extent $slice::($slice,extent)
    ::stooop::delete $slice
    foreach following [lrange $($this,slices) $index end] {
        slice::rotate $following $extent
    }
    pieLabeler::delete $($this,labeler) $($this,sliceLabel,$slice)
    if {$switched::($this,-selectable)} {
        selector::remove $($this,selector) $($this,sliceLabel,$slice)
    }
    unset ($this,sliceLabel,$slice)
    update $this
}

proc pie::sizeSlice {this slice unitShare {valueToDisplay {}}} {
    set index [lsearch -exact $($this,slices) $slice]
    if {$index<0} {
        error "invalid slice $slice for pie $this"
    }
    set newExtent [expr {[maximum [minimum $unitShare 1] 0]*360}]
    set growth [expr {$newExtent-$slice::($slice,extent)}]
    switched::configure $slice -startandextent "[expr {$slice::($slice,start)-$growth}] $newExtent"
    if {[string length $valueToDisplay]>0} {
        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice) $valueToDisplay
    } else {
        pieLabeler::set $($this,labeler) $($this,sliceLabel,$slice) $unitShare
    }
    set value [expr {-1*$growth}]
    foreach slice [lrange $($this,slices) [incr index] end] {
        slice::rotate $slice $value
    }
    if {$switched::($this,-autoupdate)} {
        update $this
    }
}

proc pie::labelSlice {this slice text} {
    pieLabeler::label $($this,labeler) $($this,sliceLabel,$slice) $text
    update $this
}

proc pie::setSliceLabelBackground {this slice text} {
    pieLabeler::labelBackground $($this,labeler) $($this,sliceLabel,$slice) $text
}

proc pie::selectedSlices {this} {
    set list {}
    foreach slice $($this,slices) {
        if {[pieLabeler::selectState $($this,labeler) $($this,sliceLabel,$slice)]} {
            lappend list $slice
        }
    }
    return $list
}

proc pie::setLabelsState {this labels selected} {
    set labeler $($this,labeler)
    foreach label $labels {
        pieLabeler::selectState $labeler $label $selected
    }
}

proc pie::currentSlice {this} {
    set tags [$($this,canvas) gettags current]
    if {([scan $tags slice(%u) slice]>0)&&($slice!=$($this,backgroundSlice))} {
        return $slice
    }
    if {[scan $tags canvasLabel(%u) label]>0} {
        foreach slice $($this,slices) {
            if {$($this,sliceLabel,$slice)==$label} {
                return $slice
            }
        }
    }
    return 0
}

proc pie::update {this} {
    set canvas $($this,canvas)
    foreach {x y} [$canvas coords $($this,origin)] {}
    set right [expr {$x+$($this,width)}]
    set bottom [expr {$y+$($this,height)}]
    pieLabeler::update $($this,labeler) $x $y $right $bottom
    pieLabeler::room $($this,labeler) room
    foreach {xSlices ySlices} [$canvas coords pieSlices($this)] {}
    $canvas move pieSlices($this) [expr {$x+$room(left)-$xSlices}] [expr {$y+$room(top)+$($this,titleRoom)-$ySlices}]
    set scale [list\
        [expr {($($this,width)-$room(left)-$room(right))/$($this,initialWidth)}]\
        [expr {($($this,height)-$room(top)-$room(bottom)-$($this,titleRoom))/($($this,initialHeight)+$($this,thickness))}]\
    ]
    switched::configure $($this,backgroundSlice) -scale $scale
    foreach slice $($this,slices) {
        switched::configure $slice -scale $scale
    }
    pieLabeler::updateSlices $($this,labeler) $x $y $right $bottom
    if {$($this,titleRoom)>0} {
        $canvas coords $($this,title) [expr {$x+($($this,width)/2)}] $y
    }
}

::stooop::class pie {
    proc maximum {a b} {return [expr {$a>$b?$a:$b}]}
    proc minimum {a b} {return [expr {$a<$b?$a:$b}]}

    catch ::tk::Darken
    if {[llength [info procs ::tk::Darken]]>0} {
        proc darken {color percent} {::tk::Darken $color $percent}
    } else {
        proc darken {color percent} {::tkDarken $color $percent}
    }
}
}

pack [label .m -relief sunken -text\
    "you may move a pie by holding down mouse button 1 over any part of it"\
] -fill x

set canvas [canvas .c -highlightthickness 0]
pack $canvas -fill both -expand 1

set pie1 [new pie\
    $canvas 0 0 -height 100 -thickness 20 -background gray\
    -labeler [new pieBoxLabeler $canvas -justify center -offset 10]\
    -title "this is pie #1" -titlefont fixed -titleoffset 6 -selectable 1\
]
set slice11 [pie::newSlice $pie1]
set slice12 [pie::newSlice $pie1]
set slice13 [pie::newSlice $pie1]
set slice14 [pie::newSlice $pie1 {some text}]

set pie2 [new pie\
    $canvas 0 0 -height 100 -thickness 10 -background white\
    -labeler [\
        new piePeripheralLabeler $canvas -font {-weight bold -family Helvetica -size -20}\
            -smallfont {-family Helvetica -size -8} -bulletwidth 1c\
    ]\
    -title "this is pie #2" -titleoffset 10\
]
set slice21 [pie::newSlice $pie2]
set slice22 [pie::newSlice $pie2]

$canvas move pie($pie1) 10 40
$canvas move pie($pie2) 240 40

for {set index 1} {$index<=2} {incr index} {
    $canvas bind pie([set pie$index]) <ButtonPress-1> "
        set xLast($index) %x
        set yLast($index) %y
    "
    $canvas bind pie([set pie$index]) <Button1-Motion> "
        $canvas move pie([set pie$index])\
            \[expr %x-\$xLast($index)\] \[expr %y-\$yLast($index)\]
        set xLast($index) %x
        set yLast($index) %y
    "
}

button .d -text {Delete Pies} -command "
    delete $pie1 $pie2
    .d configure -state disabled
    set delete 1
"
button .q -text Exit -command exit
pack .d .q -side left -fill x -expand 1


set delete 0
set u 1

proc refresh {} {
    global delete u pie1 pie2 slice11 slice12 slice13 slice14 slice21 slice22

    if {$delete} {
        return
    }

    set u [expr (3*$u)%31]
    pie::sizeSlice $pie1 $slice11 [expr $u/100.0]
    set u [expr (5*$u)%31]
    pie::sizeSlice $pie1 $slice12 [expr $u/100.0]
    set u [expr (7*$u)%31]
    pie::sizeSlice $pie1 $slice13 [expr $u/100.0] "$u %"
    pie::sizeSlice $pie2 $slice21 [expr $u/100.0] $u
    set u [expr (11*$u)%31]
    pie::sizeSlice $pie1 $slice14 [expr $u/100.0]
    pie::sizeSlice $pie2 $slice22 [expr $u/100.0] $u

    update
    after 3000 refresh
}

proc resize {width height} {
    set width [expr {$width/2.0}]
    set height [expr {$height/2.0}]
    switched::configure $::pie1 -width $width -height $height
    switched::configure $::pie2 -width $width -height $height
    $::canvas configure -scrollregion [$::canvas bbox all]
}

$canvas configure -width 400 -height 300
bind $canvas <Configure> "resize %w %h"
refresh

