Version 14 of Spheres
Updated 2012-12-01 21:04:32 by pooryorickulis, 2003-09-10
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
package require Tk
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