Gradient Spheres

Keith Vetter 2006-08-16 : For a game I'm writing, I needed sphere shaped playing pieces. I grabbed some images off the web but I had trouble when I made the background transparent--the edges just looked horrible.

So I decided to create my own. It draws a series of shrinking circles, each slightly offset from the previous and with colors from a gradient.

The result looks (sort of) like a sphere with an offset light source.

Stu 2008-11-11 Commented-out code that causes expected integer but got "bold" error on *nix systems.

uniquename 2013aug17

Here is an image to show what the following code creates. (This image was created on Linux --- Ubuntu 9.10 - the good old 2009 October version - 'Karmic Koala'. Those were the days. Ubuntu and Gnome have gone downhill since then ... IMHO.)

 ##+##########################################################################
 #
 # Gradient Spheres
 # by Keith Vetter, August 2006
 #
 package require Tk
 
 proc Gradient {n clr1 clr2} {
 
    foreach {r1 g1 b1} [winfo rgb . $clr1] {r2 g2 b2} [winfo rgb . $clr2] break
    
    set n [expr {$n <= 1 ? 1 : double($n - 1)}]
    set gradient {}
    for {set i 0} {$i <= $n} {incr i} {
        set r [expr {int(($r2 - $r1) * $i / $n + $r1) * 255 / 65535}]
        set g [expr {int(($g2 - $g1) * $i / $n + $g1) * 255 / 65535}]
        set b [expr {int(($b2 - $b1) * $i / $n + $b1) * 255 / 65535}]
        lappend gradient [format "#%.2x%.2x%.2x" $r $g $b]
    }
 
    return $gradient
 }
 
 proc GradientSphere {c Ox Oy radius Lx Ly color1 color2 {csteps {}}} {
    # c: canvas to use
    # Ox,Oy, radius: center and radius of sphere
    # Lx,Ly: where light source hits and is a position in a -1,-1 to 1,1 box
    #   which is mapped onto the bounding box of the sphere
    # color1, color2: outer and inner colors for the gradient
    # csteps: how many colors to use, defaults to radius
    
    if {$csteps eq {}} {set csteps $radius}
    set clrs [Gradient $csteps $color1 $color2]
    
    for {set i 0} {$i < $radius} {incr i} {
        set x [expr {$Ox + $i * $Lx}]           ;# Center of shrinking circle
        set y [expr {$Oy + $i * $Ly}]
        set x0 [expr {$x - ($radius - $i)}]     ;# BBox of shrinking circle
        set y0 [expr {$y - ($radius - $i)}]
        set x1 [expr {$x + ($radius - $i)}]
        set y1 [expr {$y + ($radius - $i)}]
        set idx [expr {round($csteps * $i / double($radius))}]
        set clr [lindex $clrs $idx]
 
        $c create oval $x0 $y0 $x1 $y1 -tag gradient -fill $clr -outline $clr
    }
 }
 
 # DEMO code
 proc Demo {{random 0}} {
    if {! [winfo exists .c]} {
        canvas .c -width 750 -height 500 -bg yellow
        button .go -text "Random Colors" -command {Demo 1}

        #causes 'expected integer but got "bold"' error on *nix systems.
        #.go config -font "[.go cget -font] bold"

        pack .go -side bottom -pady 10
        pack .c -fill both -side top
    }
 
    .c delete all
    set radius 100
    set row 0
    set col -1
    foreach clr {#000080 #008000 #800000 #808000 #800080 #008080} {
        if {[incr col] >= 3} { set col 0; incr row }
        set x0 [expr {(.5 + $col) * (2*$radius + 50)}]
        set y0 [expr {(.5 + $row) * (2*$radius + 50)}]
        if {$random} {
            set clr [format \#%06x [expr {int(rand() * 0xFFFFFF)}]]
        }
        GradientSphere .c $x0 $y0 $radius -.4 -.4 $clr white
    }
 }
 Demo
 return

Category Graphics