Spheres
ulis, 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.1___
uniquename 2014jan27
For those who do not have the facilities or time to implement the code above, here is an image of the window that is produced by the 'spheres' Tk script of 'ulis'.
(This locally-stored image serves to replace a dead link, above, to an external-image-link.)
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___
uniquename 2014jan27
For those who do not have the facilities or time to implement the code above, here is an image of the window produced by the 'sphere' Tk script of 'ulis'.
