/usr/share/tcltk/tklib0.6/tkpiechart/relirect.tcl is in tklib 0.6-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | # copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)
package require Tk 8.3
package require stooop
::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} {
# force background initialization for color calculations
return [list\
[list -background white]\
[list -coordinates {0 0 0 0} {0 0 0 0}]\
[list -relief flat flat]\
]
}
proc set-background {this value} { ;# algorithm stolen from tkUnix3d.c
set intensity 65535 ;# maximum intensity
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 ;# colors not yet calculated
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"
}
}
}
}
|