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
        # use an empty image as an origin marker with only 2 coordinates
        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} {                                                                    ;# force font for proper initialization
        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} {                                   ;# value is a list of ratios of the horizontal and vertical axis
        update $this                                                           ;# refresh display which takes new scale into account
    }

    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)] {                 ;# adopt all label tags so moving along works
                        $canvas addtag $tag withtag $reliefTag
                    }
                }
                set background $switched::($this,-textbackground)
                if {[string length $background]==0} {
                    set background [$canvas cget -background]                                      ;# emulate transparent 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 {}

        # position rectangle and text as if anchor was center (the default)
        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)                                     ;# now move rectangle and text according to 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)                                 ;# finally apply scale
    }

}
