Version 4 of Spheres

Updated 2004-06-05 10:36:56

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

---

Category Example

Category Graphics

Category Image processing