package require Tk
namespace eval transx {
proc rgbs {n c1 c2} {
# Color intensities are from 0 to 65535, 2 byte colors.
foreach {r1 g1 b1} [winfo rgb . $c1] break
foreach {r2 g2 b2} [winfo rgb . $c2] break
#puts "c1: $r1 $g1 $b1"
#puts "c2: $r2 $g2 $b2"
# Normalize intensities to 0 to 255, 1 byte colors.
foreach el {r1 g1 b1 r2 g2 b2} {
set $el [expr {[set $el] * 255 / 65535}].0
}
#puts "c1: $r1 $g1 $b1"
#puts "c2: $r2 $g2 $b2"
if {$n == 1} {
set r_step 0.0 ; set g_step 0.0 ; set b_step 0.0
} else {
set r_step [expr {($r2-$r1) / ($n-1)}]
set g_step [expr {($g2-$g1) / ($n-1)}]
set b_step [expr {($b2-$b1) / ($n-1)}]
}
#puts "$r_step $g_step $b_step"
set steps {}
for {set i 0} {$i < $n} {incr i} {
set r [expr {int($r_step * $i + $r1)}]
set g [expr {int($g_step * $i + $g1)}]
set b [expr {int($b_step * $i + $b1)}]
#puts "$r $g $b"
lappend steps [format "#%.2X%.2X%.2X" $r $g $b]
}
return $steps
}
proc demo1 {} {
set n 50
set steps [rgbs $n red royalblue]
for {set i 0} {$i < $n} {incr i} {
set fr .f$i
frame $fr -bg [lindex $steps $i] -height 1
pack $fr -fill x
}
}
proc demo2 {} {
set n 50
set steps [rgbs $n yellow red]
set c [canvas .c]
pack $c -fill both -expand 1
update
set width [winfo width $c]
set height [winfo height $c]
for {set i 0} {$i < $n} {incr i} {
$c create line 0 $i $width $i -tags gradient -fill [lindex $steps $i]
}
}
proc paint_canvas {c type c1 c2} {
$c delete gradient
set w [winfo width $c]
set h [winfo height $c]
if {[string equal $type "x"]} {
set n $w
set steps [rgbs $n $c1 $c2]
for {set i 0} {$i < $n} {incr i} {
$c create line $i 0 $i $h -tags gradient -fill [lindex $steps $i]
}
} else {
set n $h
set steps [rgbs $n $c1 $c2]
for {set i 0} {$i < $n} {incr i} {
$c create line 0 $i $w $i -tags gradient -fill [lindex $steps $i]
}
}
return
}
proc paint_canvas_demo {} {
canvas .c1
canvas .c2
bind .c1 <Configure> [list transx::paint_canvas %W x red royalblue]
bind .c2 <Configure> [list transx::paint_canvas %W y yellow red]
pack .c1 .c2 -fill both -expand 1
}
}Mick O'Donnell adds: (14 Jun 2003):Here is another demo for the above, this drawing a sphere with light-source from top-left.
proc demo3 {} {
set n 90
set steps [rgbs $n white blue]
set c [canvas .c -height 200 -width 200 -bg wheat]
pack $c -fill both -expand 1
update
set width [winfo width $c]
set height [winfo height $c]
set centre 100
for {set i $n} {$i > 0} {incr i -1} {
set centre [expr $centre - 0.55]
set x1 [expr $centre - $i]
set x2 [expr $centre + $i]
set color [lindex $steps $i]
$c create oval $x1 $x1 $x2 $x2 -tags gradient -fill $color -outline $color
}
}