[ulis], 2003-09-10

[http://perso.wanadoo.fr/maurice.ulis/tcl/spheres.gif]

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
======

'''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
======

<<categories>> Example | Graphics | Image processing