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