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

___

[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'.

[gradientSpheres_two_ulis_wiki9847_297x193.jpg]

------


'''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 'spheres' Tk script of 'ulis'.

[gradientSphere_oneOnColorBkgd_ulis_wiki9847_298x238.jpg]


<<categories>> Example | Graphics | Image processing