Version 10 of Spheres

Updated 2004-06-05 22:40:54

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

---

RLH: Thanks for the code. However, all the \'s to enforce a non-Tcl coding style makes it really ugly to look at.

ulis I let you the responsability to say that it's 'a non-Tcl coding style'. I think the contrary and that coding style is a matter of taste.

TV I'd say real ugly is an ugly exageration. Maybe a simple search and replace few-liner?

RLH: The I would say "ugly" and not "real ugly" but this is only a small snippet of code. Imagine it being 1000 times bigger.

ulis To know that you can look at my packages that are almost all bigger than 1000 lines.

---

Category Example

Category Graphics

Category Image processing