Inspired from Marco Maggi's page: Experimenting with graphics algorithms.The proc
proc gradient {image relief light source} \
{
set sunken [string match sun* $relief]
set light [expr {$light * 96 + 32}]
set source [expr {0.5 + $source / 2.0}]
set D [image width $image]
set R [expr {$D / 2}]
set R2 [expr {$R * $R}]
for {set y 0} {$y < $D} {incr y} \
{
set Dy2 [expr {($y - $R) * ($y - $R)}]
set dy [expr {($y * $source - $R)}]
set dy2 [expr {$dy * $dy}]
for {set x 0} {$x < $D} {incr x} \
{
set Dx2 [expr {($x - $R) * ($x - $R)}]
set Dxy [expr {$Dx2 + $Dy2}]
if {$Dxy <= $R2} \
{
set dx [expr {($x * $source - $R)}]
set dx2 [expr {$dx * $dx}]
set dxy [expr {$dx2 + $dy2}]
set color [expr {int(127 + $light * (1.0 - ($dxy / $R2 / 1.5)))}]
if {$sunken} { set color [expr {int(127 + $light * 2 - $color)}] }
set color [format "#%02x%02x%02x" $color $color $color]
$image put $color -to [expr {$D - $x}] [expr {$D - $y}]
}
}
}
}The demo
proc demo {args} \
{
# args
set size 128
set light 1.0
set source 0.0
foreach {key value} $args \
{
switch -glob -- $key \
{
-li* \
{
if {$value < 0.0 ||$value > 1.0} \
{ error "light should be between 0.0 and 1.0" }
set light $value
}
-si* { set size $value }
-so* \
{
if {$value < 0.0 ||$value > 1.0} \
{ error "source should be between 0.0 and 1.0" }
set source $value
}
default { error "unknown option \"$key\"" }
}
}
# title
wm title . "spheres"
# canvas
set ww $size; incr ww $size; incr ww
set hh $size; incr hh
canvas .c -width $ww -height $hh -relief groove -bd 1
grid .c -padx 50 -pady 10
# raised image
image create photo raised -width $size -height $size
set x 3; set y 3
.c create image $x $y -image raised -anchor nw
gradient raised raised $light $source
# sunken image
incr x $size
image create photo sunken -width $size -height $size
.c create image $x $y -image sunken -anchor nw
gradient sunken sunken $light $source
# button
button .b -text Quit -width 6 -command exit -bd 1
grid .b -pady 10
bind .b <Return> { %W invoke }
bind . <Escape> { exit }
}
package require Tk 8.4
demo -size 96 -light 0.9 -source 0.1RLH: Thanks for the code. However, all the \'s to enforce a non-Tcl coding style makes it really ugly to look at.ulis I let you the responsability to say that it's 'a non-Tcl coding style'. I think the contrary and that coding style is a matter of taste.TV I'd say real ugly is an ugly exageration. Maybe a simple search and replace few-liner?RLH: The I would say "ugly" and not "real ugly" but this is only a small snippet of code. Imagine it being 1000 times bigger.ulis To know that you can look at my packages that are almost all bigger than 1000 lines.
Modified to use a dot-product for a simple (but accurate) lighting model
proc draw_sphere {image } {
set D [image width $image]
set R [expr {$D / 2}]
set invR [expr {1.0/$R}]
set R2 [expr {$R * $R}]
# direction to light source (normal vector)
set lightX 0.4472
set lightY 0.5366
set lightZ 0.7155
# iterate top to bottom
for {set sy 0} {$sy < $D} {incr sy} {
set y [expr {($sy - $R)}]
set xmax [expr {$R2-$y*$y}]
if { $xmax < 0 } {continue}
set xmax [expr {int(sqrt($xmax))}]
set xmin [expr {$R-$xmax}]
set xmax [expr {$R+$xmax}]
set vY [expr {$y * $invR}]
# iterate left to right, but only within the circle
for {set sx $xmin} {$sx <= $xmax} {incr sx} {
set vX [expr {($sx-$R) * $invR}]
set vZ [expr {1.0 - $vY*$vY - $vX*$vX}]
if { $vZ < 0 } { set vZ 0 }
set vZ [expr {sqrt($vZ)}]
# dot product of light vector with surface normal vector
set color [expr {$lightX*$vX+$lightY*$vY+$lightZ*$vZ}]
if { $color < 0.0 } { set color 0.0 }
if { $color > 1 } { set color 1 }
set red [expr {int(255 * $color)}]
set color [format "#%02x%02x%02x" $red $red $red ]
$image put $color -to [expr {$D - $sx}] [expr {$D - $sy}]
}
}
}
proc demo2 {} {
wm title . "sphere"
set size 97
set ww [expr 2*$size]
set hh [expr 2*$size]
canvas .c -width $ww -height $hh -bg #6060ff
grid .c -padx 50 -pady 10
.c create rectangle 0 [expr $hh/3] $ww $hh -fill #00aa00 -outline {}
# raised image
image create photo sphere_img -width $size -height $size
set x [expr $ww/2]
set y [expr $hh*2.0/3]
.c create image $x $y -image sphere_img -anchor c
draw_sphere sphere_img
}
demo2