
set rcsId {$Id: demo,v 1.42.1.1 2000/03/26 09:31:03 jfontain Exp $}

if {[catch {package require stooop 3.7}]} {
set rcsId {$Id: stooop.tcl,v 3.66 1998/10/28 21:50:15 jfontain Exp $}

package provide stooop 3.7

catch {rename proc _proc}

namespace eval ::stooop {
    variable checkCode
    variable traceProcedureChannel
    variable traceProcedureFormat
    variable traceDataChannel
    variable traceDataFormat
    variable traceDataOperations

    set checkCode {}
    if {[info exists ::env(STOOOPCHECKALL)]} {
        array set ::env {STOOOPCHECKPROCEDURES {} STOOOPCHECKDATA {} STOOOPCHECKOBJECTS {}}
    }
    if {[info exists ::env(STOOOPCHECKPROCEDURES)]} {
        append checkCode {::stooop::checkProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEALL)]} {
        set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
        set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
    }
    if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
        set traceProcedureChannel $::env(STOOOPTRACEPROCEDURES)
        if {![regexp {^stdout|stderr$} $traceProcedureChannel]} {
            set traceProcedureChannel [open $::env(STOOOPTRACEPROCEDURES) w+]
        }
        set traceProcedureFormat {class: %C, procedure: %p, object: %O, arguments: %a}
        catch {set traceProcedureFormat $::env(STOOOPTRACEPROCEDURESFORMAT)}
        append checkCode {::stooop::traceProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEDATA)]} {
        set traceDataChannel $::env(STOOOPTRACEDATA)
        if {![regexp {^stdout|stderr$} $traceDataChannel]} {
            set traceDataChannel [open $::env(STOOOPTRACEDATA) w+]
        }
        set traceDataFormat {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
        catch {set traceDataFormat $::env(STOOOPTRACEDATAFORMAT)}
        set traceDataOperations rwu
        catch {set traceDataOperations $::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 {[scan $classOrId %u dummy]==0} {
            set constructor ${classOrId}::[namespace tail $classOrId]
            uplevel $constructor [set id [incr newId]] $args
            set fullClass($id) [namespace qualifiers [uplevel namespace which -command $constructor]]
        } else {
            if {[catch {set fullClass([set id [incr newId]]) $fullClass($classOrId)}]} {
                error "invalid object identifier $classOrId"
            }
            uplevel $fullClass($classOrId)::_copy $id $classOrId
        }
        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
        foreach name [array names ${fullClass}:: $id,*] {
            unset ${fullClass}::($name)
        }
    }

    _proc classof {id} {
        variable fullClass

        return $fullClass($id)
    }

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

_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 compare $namespace ::]==0} {
                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 compare [uplevel namespace which -command $keyword] ::proc]!=0} {
        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 compare $class $procedure]==0} {
        error "cannot make class $fullClass constructor virtual"
    }
    if {[string compare ~$class $procedure]==0} {
        error "cannot make class $fullClass destructor virtual"
    }
    if {[string compare [lindex $arguments 0] this]!=0} {
        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 compare $class $procedure]==0} {
        if {[string compare [lindex $arguments 0] this]!=0} {
            error "class $fullClass constructor first argument must be this"
        }
        if {[string compare [lindex $arguments 1] copy]==0} {
            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 compare ~$class $procedure]==0} {
        if {[llength $arguments]!=1} {
            error "class $fullClass destructor must have 1 argument exactly"
        }
        if {[string compare [lindex $arguments 0] this]!=0} {
            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 checkCode
    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 compare [lindex $arguments end] args]==0} {
        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 {}
$checkCode
"
    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 ${fullClass}::(\$this,_derived) \[::set ${fullClass}::(\$[::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 checkCode
    variable fullBases

    set body \
"::variable {}
$checkCode
$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 checkCode
    variable pureVirtual

    if {[info exists pureVirtual]} {
        if {$pureVirtual} {
            _proc ${fullClass}::$procedure $arguments \
"::variable {}
$checkCode
::uplevel \$${fullClass}::(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]
"
        } else {
            _proc ${fullClass}::_$procedure $arguments \
"::variable {}
$checkCode
$body
"
            _proc ${fullClass}::$procedure $arguments \
"::variable {}
$checkCode
if {!\[::catch {::info body \$${fullClass}::(\$this,_derived)::$procedure}\]} {
::return \[::uplevel \$${fullClass}::(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\]
"
        }
    } else {
        _proc ${fullClass}::$procedure $arguments \
"::variable {}
$checkCode
$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 traceDataOperations

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

    if {[info exists ::env(STOOOPCHECKPROCEDURES)]} {
        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 {[info exists ::env(STOOOPCHECKOBJECTS)]} {
        _proc invokingProcedure {} {
            if {[catch {set procedure [lindex [info level -2] 0]}]} {
                return {main script}
            } elseif {[string length $procedure]==0} {
                return "namespace [uplevel 2 namespace current]"
            } else {
                return [uplevel 3 namespace which -command $procedure]
            }
        }
    }

    if {[info exists ::env(STOOOPCHECKPROCEDURES)]||[info exists ::env(STOOOPCHECKOBJECTS)]} {
        catch {rename ::stooop::new ::stooop::_new}
        _proc ::stooop::new {classOrId args} {
            variable newId
            if {[info exists ::env(STOOOPCHECKPROCEDURES)]} {
                variable fullClass
                variable interface
            }
            if {[info exists ::env(STOOOPCHECKOBJECTS)]} {
                variable creator
            }

            if {[info exists ::env(STOOOPCHECKPROCEDURES)]} {
                if {[scan $classOrId %u dummy]==0} {
                    set constructor ${classOrId}::[namespace tail $classOrId]
                    catch {$constructor}
                    set fullName [namespace qualifiers [uplevel namespace which -command $constructor]]
                    set fullClass([expr {$newId+1}]) $fullName
                } else {
                    set fullName $fullClass($classOrId)
                }
                if {[info exists interface($fullName)]} {
                    error "class $fullName with pure virtual procedures should not be instanciated"
                }
            }
            if {[info exists ::env(STOOOPCHECKOBJECTS)]} {
                set creator([expr {$newId+1}]) [invokingProcedure]
            }
            return [uplevel ::stooop::_new $classOrId $args]
        }

    }

    _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 compare $class $procedure]==0} {
            set procedure constructor
        } elseif {[string compare ~$class $procedure]==0} {
            set procedure destructor
        }
        if {[string compare [lindex [info args $fullProcedure] 0] this]==0} {
            set thisParameter [lindex $list 1]
        }
    }

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

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        if {![info exists this]} return
        if {[string compare $procedure constructor]==0} return
        if {![info exists fullClass($this)]} {
            error "$this is not a valid object identifier"
        }
        set fullName [string trimleft $fullClass($this) :]
        if {[string compare $fullName $qualifiedClass]==0} 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 traceProcedureChannel
        variable traceProcedureFormat

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $traceProcedureFormat
        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 $traceProcedureChannel $text
    }

    _proc ::stooop::checkData {array name operation} {
        scan $name %u,%s identifier member
        if {[info exists member]&&([string compare $member _derived]==0)} 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 compare $array ::${qualifiedClass}::]!=0} {
                error "class access violation in class $qualifiedClass namespace"
            }
            return
        }
        if {[string compare $qualifiedProcedure ::stooop::copy]==0} return
        if {[string compare $array ::${qualifiedClass}::]!=0} {
            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 traceDataChannel
        variable traceDataFormat

        scan $name %u,%s identifier member
        if {[info exists member]&&([string compare $member _derived]==0)} return

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

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $traceDataFormat
        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 compare $operation u]==0} {
            regsub -all %v $text {} text
        } else {
            regsub -all %v $text [uplevel set ${array}($name)] text
        }
        puts $traceDataChannel $text
    }

    if {[info exists ::env(STOOOPCHECKOBJECTS)]} {
        _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\) created in $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

            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\) created in $creator($id)"
                }
            }
            foreach id $checkpointIds {
                if {[string match $pattern $checkpointFullClass($id)]&&([lsearch -exact $currentIds $id]<0)} {
                    puts "- $checkpointFullClass($id)\($id\) created in $creator($id)"
                }
            }
        }
    }

}
}
namespace import stooop::*
if {[catch {package require switched 1.4}]} {
set rcsId {$Id: switched.tcl,v 1.4 1998/03/30 08:26:05 jfontain Exp $}

package provide switched [lindex {$Revision: 1.4 $} 1]

class switched {

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

    proc ~switched {this} {}

    virtual proc options {this}

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

    proc configure {this args} {
        if {[llength $args]==0} {
            return [descriptions $this]
        }
        foreach {option value} $args {
            if {![info exists switched::($this,$option)]} {
                error "$switched::($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 compare $switched::($this,$option) $value]!=0} {
                $switched::($this,_derived)::set$option $this [set switched::($this,$option) $value]
            }
        }
    }

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

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

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

}
}

if {[catch {package require tkpiechart 5.4}]} {
set rcsId {$Id: pielabel.tcl,v 1.40.1.1 2000/03/05 20:54:00 jfontain Exp $}

class pieLabeler {

    set pieLabeler::(default,font) {Helvetica -12}

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

    proc ~pieLabeler {this} {}

    virtual proc new {this slice args}

    virtual proc delete {this label}

    virtual proc set {this label value}

    virtual proc label {this args}

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

    virtual proc update {this left top right bottom}

    virtual proc room {this arrayName}

}
set rcsId {$Id: perilabel.tcl,v 1.47.1.1 2000/03/05 21:04:00 jfontain Exp $}

class piePeripheralLabeler {

    variable PI 3.14159265358979323846

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

    proc ~piePeripheralLabeler {this} {
        ::delete $piePeripheralLabeler::($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 ::new canvasLabel $pieLabeler::($this,canvas) $args\
            [list\
                -style split -justify $switched::($this,-justify) -bulletwidth $switched::($this,-bulletwidth)\
                -font $switched::($this,-font)\
            ]\
        ]
        canvasLabelsArray::manage $piePeripheralLabeler::($this,array) $label
        $canvas addtag pieLabeler($this) withtag canvasLabelsArray($piePeripheralLabeler::($this,array))
        ::set piePeripheralLabeler::($this,textItem,$label) $text
        ::set piePeripheralLabeler::($this,slice,$label) $slice
        ::set piePeripheralLabeler::($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 piePeripheralLabeler::(anchor,[anglePosition [expr {$index*45}]]) $anchor
        incr index
    }
    unset index anchor

    proc set {this label value} {
        ::set text $piePeripheralLabeler::($this,textItem,$label)
        position $this $text $piePeripheralLabeler::($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 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 $piePeripheralLabeler::(anchor,[anglePosition $angle])
    }

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

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

    proc update {this left top right bottom} {
        ::set canvas $pieLabeler::($this,canvas)
        ::set array $piePeripheralLabeler::($this,array)
        foreach {x y} [$canvas coords canvasLabelsArray($array)] {}
        $canvas move canvasLabelsArray($array) [expr {$left-$x}] [expr {$bottom-[canvasLabelsArray::height $array]-$y}]
        switched::configure $array -width [expr {$right-$left}]
        foreach label [canvasLabelsArray::labels $array] {
            position $this $piePeripheralLabeler::($this,textItem,$label) $piePeripheralLabeler::($this,slice,$label)
        }
    }

    proc room {this arrayName} {
        upvar $arrayName data

        ::set data(left) [expr {$piePeripheralLabeler::($this,valueWidth)+$switched::($this,-offset)}]
        ::set data(right) $data(left)
        ::set data(top) [expr {$switched::($this,-offset)+$piePeripheralLabeler::($this,valueHeight)}]
        ::set box [$pieLabeler::($this,canvas) bbox canvasLabelsArray($piePeripheralLabeler::($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 1.41.1.1 2000/03/05 20:55:56 jfontain Exp $}

class pieBoxLabeler {

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

    proc ~pieBoxLabeler {this} {
        ::delete $pieBoxLabeler::($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 ::new canvasLabel $pieLabeler::($this,canvas)\
            $args [list -justify $switched::($this,-justify) -font $switched::($this,-font)]\
        ]
        canvasLabelsArray::manage $pieBoxLabeler::($this,array) $label
        $pieLabeler::($this,canvas) addtag pieLabeler($this) withtag canvasLabelsArray($pieBoxLabeler::($this,array))
        switched::configure $label -text [switched::cget $label -text]:
        ::set pieBoxLabeler::($this,selected,$label) 0
        return $label
    }

    proc delete {this label} {
        canvasLabelsArray::delete $pieBoxLabeler::($this,array) $label
        unset pieBoxLabeler::($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 selectState {this label {selected {}}} {
        if {[string length $selected]==0} {
            return $pieBoxLabeler::($this,selected,$label)
        }
        switched::configure $label -select $selected
        ::set pieBoxLabeler::($this,selected,$label) $selected
    }

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

    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($pieBoxLabeler::($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: canlabel.tcl,v 1.25 1999/03/30 20:11:01 jfontain Exp $}

class canvasLabel {

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

    proc ~canvasLabel {this} {
        $canvasLabel::($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 -padding 2 2]\
            [list -scale {1 1} {1 1}]\
            [list -select 0 0]\
            [list -selectcolor white white]\
            [list -stipple {} {}]\
            [list -style box box]\
            [list -text {} {}]\
            [list -width 0 0]\
        ]
    }

    proc set-background {this value} {
        $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,rectangle) -fill $value
    }
    proc set-bordercolor {this value} {
        $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,rectangle) -outline $value
        if {[string compare $switched::($this,-style) box]==0} {
            $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,selectRectangle) -outline $value
        }
    }
    proc set-borderwidth {this value} {
        $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,selectRectangle) -width $value
        $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,rectangle) -width $value
        update $this
    }
    proc set-foreground {this value} {
        $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,text) -fill $value
    }
    proc set-scale {this value} {
        update $this
    }
    proc set-stipple {this value} {
        $canvasLabel::($this,canvas) itemconfigure $canvasLabel::($this,rectangle) -stipple $value
    }
    proc set-style {this value} {
        switch $value {
            box {
                $canvasLabel::($this,canvas) raise $canvasLabel::($this,selectRectangle) $canvasLabel::($this,rectangle)
            }
            split {
                $canvasLabel::($this,canvas) lower $canvasLabel::($this,selectRectangle) $canvasLabel::($this,rectangle)
            }
            default {
                error "bad style value \"$value\": must be box or split"
            }
        }
        update $this
    }
    foreach option {-anchor -bulletwidth -padding -select -selectcolor} {
        proc set$option {this value} {update $this}
    }
    foreach option {-font -justify -text -width} {
        proc set$option {this value} "
            \$canvasLabel::(\$this,canvas) itemconfigure \$canvasLabel::(\$this,text) $option \$value
            update \$this
        "
    }

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

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

        set border [$canvas itemcget $rectangle -width]
        set textBox [$canvas bbox $text]
        set padding [winfo fpixels $canvas $switched::($this,-padding)]
        set bulletWidth [winfo fpixels $canvas $switched::($this,-bulletwidth)]

        $canvas itemconfigure $selectRectangle -fill {} -outline {}
        set split [expr {[string compare $switched::($this,-style) split]==0}]

        if {$split} {
            set halfWidth [expr {($bulletWidth+$border+$padding+([lindex $textBox 2]-[lindex $textBox 0]))/2.0}]
            set halfHeight [expr {(([lindex $textBox 3]-[lindex $textBox 1])/2.0)+$border}]
        } else {
            set width [expr {$switched::($this,-width)==0?[lindex $textBox 2]-[lindex $textBox 0]:$switched::($this,-width)}]
            set halfWidth [expr {$bulletWidth+$border+$padding+($width/2.0)}]
            set halfHeight [expr {(([lindex $textBox 3]-[lindex $textBox 1])/2.0)+$border+$padding}]
        }
        set left [expr {$x-$halfWidth}]
        set top [expr {$y-$halfHeight}]
        set right [expr {$x+$halfWidth}]
        set bottom [expr {$y+$halfHeight}]
        $canvas coords $text [expr {$x+(($bulletWidth+$border+$padding)/2.0)}] $y
        if {$split} {
            $canvas coords $selectRectangle $left $top $right $bottom
            $canvas coords $rectangle $left $top [expr {$left+$bulletWidth}] $bottom
            if {$switched::($this,-select)} {
                $canvas itemconfigure $selectRectangle\
                    -fill $switched::($this,-selectcolor) -outline $switched::($this,-selectcolor)
            }
        } else {
            $canvas coords $selectRectangle $left $top [expr {$left+$bulletWidth}] $bottom
            $canvas coords $rectangle $left $top $right $bottom
            $canvas itemconfigure $selectRectangle -outline $switched::($this,-bordercolor)
            if {$switched::($this,-select)} {
                $canvas itemconfigure $selectRectangle -fill $switched::($this,-selectcolor)
            }
        }

        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
        eval $canvas scale canvasLabel($this) $x $y $switched::($this,-scale)
    }

}
set rcsId {$Id: labarray.tcl,v 1.20 1998/06/07 13:47:02 jfontain Exp $}

class canvasLabelsArray {

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

    proc ~canvasLabelsArray {this} {
        eval ::delete $canvasLabelsArray::($this,labels)
        $canvasLabelsArray::($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 canvasLabelsArray::($this,width) [winfo fpixels $canvasLabelsArray::($this,canvas) $value]
        update $this
    }

    proc update {this} {
        set index 0
        foreach label $canvasLabelsArray::($this,labels) {
            position $this $label $index
            incr index
        }
    }

    proc manage {this label} {
        $canvasLabelsArray::($this,canvas) addtag canvasLabelsArray($this) withtag canvasLabel($label)
        set index [llength $canvasLabelsArray::($this,labels)]
        lappend canvasLabelsArray::($this,labels) $label
        position $this $label $index
    }

    proc delete {this label} {
        set index [lsearch -exact $canvasLabelsArray::($this,labels) $label]
        if {$index<0} {
            error "invalid label $label for canvas labels array $this"
        }
        set canvasLabelsArray::($this,labels) [lreplace $canvasLabelsArray::($this,labels) $index $index]
        ::delete $label
        foreach label [lrange $canvasLabelsArray::($this,labels) $index end] {
            position $this $label $index
            incr index
        }
    }

    proc position {this label index} {
        set canvas $canvasLabelsArray::($this,canvas)

        foreach {x y} [$canvas coords $canvasLabelsArray::($this,origin)] {}
        set coordinates [$canvas bbox canvasLabel($label)]
        set y [expr {$y+(($index/2)*([lindex $coordinates 3]-[lindex $coordinates 1]))}]

        switch $switched::($this,-justify) {
            left {
                set x [expr {$x+(($index%2)*($canvasLabelsArray::($this,width)/2.0))}]
                set anchor nw
            }
            right {
                set x [expr {$x+((($index%2)+1)*($canvasLabelsArray::($this,width)/2.0))}]
                set anchor ne
            }
            default {
                set x [expr {$x+((1.0+(2*($index%2)))*$canvasLabelsArray::($this,width)/4)}]
                set anchor n
            }
        }
        switched::configure $label -anchor $anchor
        foreach {xDelta yDelta} [$canvas coords canvasLabel($label)] {}
        $canvas move canvasLabel($label) [expr {$x-$xDelta}] [expr {$y-$yDelta}]
    }

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

    proc height {this} {
        set number [llength $canvasLabelsArray::($this,labels)]
        if {$number==0} {
            return 0
        }
        set coordinates [$canvasLabelsArray::($this,canvas) bbox canvasLabel([lindex $canvasLabelsArray::($this,labels) 0])]
        return [expr {(($number+1)/2)*([lindex $coordinates 3]-[lindex $coordinates 1])}]
    }

}
set rcsId {$Id: slice.tcl,v 1.39 1998/06/07 10:19:25 jfontain Exp $}


class slice {
    variable PI 3.14159265358979323846
}

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

proc slice::~slice {this} {
    if {[string length $switched::($this,-deletecommand)]>0} {
        uplevel $switched::($this,-deletecommand)
    }
    $slice::($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)} {
        update $this
    }
}

proc slice::set-startandextent {this value} {
    foreach {start extent} $value {}
    set slice::($this,start) [normalizedAngle $start]
    if {$extent<0} {
        set slice::($this,extent) 0
    } elseif {$extent>=360} {
        set slice::($this,extent) [expr {360-pow(10,-$::tcl_precision+3)}]
    } else {
        set slice::($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 $slice::($this,canvas)
    set xRadius $slice::($this,xRadius)
    set yRadius $slice::($this,yRadius)
    set bottomColor $switched::($this,-bottomcolor)
    set slice::($this,origin) [$canvas create image -$xRadius -$yRadius -tags slice($this)]
    if {$switched::($this,-height)>0} {
        set slice::($this,startBottomArcFill) [$canvas create arc\
            0 0 0 0 -style chord -extent 0 -fill $bottomColor -outline $bottomColor -tags slice($this)\
        ]
        set slice::($this,startPolygon) [$canvas create polygon 0 0 0 0 0 0 -fill $bottomColor -tags slice($this)]
        set slice::($this,startBottomArc) [$canvas create arc 0 0 0 0 -style arc -extent 0 -fill black -tags slice($this)]

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

        set slice::($this,startLeftLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set slice::($this,startRightLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set slice::($this,endLeftLine) [$canvas create line 0 0 0 0 -tags slice($this)]
        set slice::($this,endRightLine) [$canvas create line 0 0 0 0 -tags slice($this)]
    }
    set slice::($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 $slice::($this,canvas)
    set coordinates [$canvas coords $slice::($this,origin)]
    set xRadius $slice::($this,xRadius)
    set yRadius $slice::($this,yRadius)
    $canvas coords $slice::($this,origin) -$xRadius -$yRadius
    $canvas coords $slice::($this,topArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas itemconfigure $slice::($this,topArc) -start $slice::($this,start) -extent $slice::($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 $slice::($this,start)
    set extent $slice::($this,extent)

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

    $canvas itemconfigure $slice::($this,startBottomArcFill) -extent 0
    $canvas coords $slice::($this,startBottomArcFill) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $slice::($this,startBottomArcFill) 0 $height
    $canvas itemconfigure $slice::($this,startBottomArc) -extent 0
    $canvas coords $slice::($this,startBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $slice::($this,startBottomArc) 0 $height
    $canvas coords $slice::($this,startLeftLine) 0 0 0 0
    $canvas coords $slice::($this,startRightLine) 0 0 0 0
    $canvas itemconfigure $slice::($this,endBottomArcFill) -extent 0
    $canvas coords $slice::($this,endBottomArcFill) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $slice::($this,endBottomArcFill) 0 $height
    $canvas itemconfigure $slice::($this,endBottomArc) -extent 0
    $canvas coords $slice::($this,endBottomArc) -$xRadius -$yRadius $xRadius $yRadius
    $canvas move $slice::($this,endBottomArc) 0 $height
    $canvas coords $slice::($this,endLeftLine) 0 0 0 0
    $canvas coords $slice::($this,endRightLine) 0 0 0 0
    $canvas coords $slice::($this,startPolygon) 0 0 0 0 0 0 0 0
    $canvas coords $slice::($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 $slice::($this,startBottomArcFill) -start $start -extent $extent
                $canvas itemconfigure $slice::($this,startBottomArc) -start $start -extent $extent
                $canvas coords $slice::($this,startPolygon) $startX $startY $endX $endY $endX $endBottom $startX $startBottom
                $canvas coords $slice::($this,startLeftLine) $startX $startY $startX $startBottom
                $canvas coords $slice::($this,startRightLine) $endX $endY $endX $endBottom
            }
        } else {
            if {$start<0} {
                $canvas itemconfigure $slice::($this,startBottomArcFill) -start 0 -extent $start
                $canvas itemconfigure $slice::($this,startBottomArc) -start 0 -extent $start
                $canvas coords $slice::($this,startPolygon) $startX $startY $xRadius 0 $xRadius $height $startX $startBottom
                $canvas coords $slice::($this,startLeftLine) $startX $startY $startX $startBottom
                $canvas coords $slice::($this,startRightLine) $xRadius 0 $xRadius $height

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

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

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

    set data(start) $slice::($this,start)
    set data(extent) $slice::($this,extent)
    foreach {x y} $switched::($this,-scale) {}
    set data(xRadius) [expr {$x*$slice::($this,xRadius)}]
    set data(yRadius) [expr {$y*$slice::($this,yRadius)}]
    set data(height) [expr {$y*$switched::($this,-height)}]
    foreach {x y} [$slice::($this,canvas) coords $slice::($this,origin)] {}
    set data(xCenter) [expr {$x+$data(xRadius)}]
    set data(yCenter) [expr {$y+$data(yRadius)}]
}
set rcsId {$Id: selector.tcl,v 1.4 1999/08/16 20:59:03 jfontain Exp $}


class selector {

    proc selector {this args} switched {$args} {
        ::set selector::($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) $selector::($this,order)
            incr selector::($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 selector::($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 {$index==$selector::($this,lastSelected)} {
                    ::unset selector::($this,lastSelected)
                }
            } else {
                lappend select $index
                ::set ${this}selected($index) 1
                ::set selector::($this,lastSelected) $index
            }
            ::set ${this}order($index) $selector::($this,order)
            incr selector::($this,order)
        }
        update $this $select $deselect
    }

    virtual proc extend {this index} {}

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

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

    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]
    }

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

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

}

set rcsId {$Id: objselec.tcl,v 1.8 1999/10/02 20:53:05 jfontain Exp $}


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 1.85.1.2 2000/03/21 21:32:25 jfontain Exp $}

package provide tkpiechart 5.4

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

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

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

proc pie::options {this} {
    return [list\
        [list -background {} {}]\
        [list -colors $pie::(colors) $pie::(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]\
    ]
}

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 pie::($this,thickness) [winfo fpixels $pie::($this,canvas) $value]
}

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

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

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

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

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

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

    set slice [new slice\
        $canvas [expr {$pie::($this,initialWidth)/2}] [expr {$pie::($this,initialHeight)/2}] -startandextent "$start 0"\
        -height $pie::($this,thickness) -topcolor $color -bottomcolor [tkDarken $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 pie::($this,slices) $slice

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

    update $this

    if {$switched::($this,-selectable)} {
        if {![info exists pie::($this,selector)]} {
            set pie::($this,selector) [new objectSelector -selectcommand "pie::setLabelsState $this"]
        }
        set selector $pie::($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 $pie::($this,slices) $slice]
    if {$index<0} {
        error "invalid slice $slice for pie $this"
    }
    set pie::($this,slices) [lreplace $pie::($this,slices) $index $index]
    set extent $slice::($slice,extent)
    delete $slice
    foreach following [lrange $pie::($this,slices) $index end] {
        slice::rotate $following $extent
    }
    pieLabeler::delete $pie::($this,labeler) $pie::($this,sliceLabel,$slice)
    if {$switched::($this,-selectable)} {
        selector::remove $pie::($this,selector) $pie::($this,sliceLabel,$slice)
    }
    unset pie::($this,sliceLabel,$slice)
    update $this
}

proc pie::sizeSlice {this slice unitShare {valueToDisplay {}}} {
    set index [lsearch -exact $pie::($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 $pie::($this,labeler) $pie::($this,sliceLabel,$slice) $valueToDisplay
    } else {
        pieLabeler::set $pie::($this,labeler) $pie::($this,sliceLabel,$slice) $unitShare
    }

    set value [expr {-1*$growth}]
    foreach slice [lrange $pie::($this,slices) [incr index] end] {
        slice::rotate $slice $value
    }
}

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

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

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

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

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

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

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

