Updated 2011-07-05 02:17:04 by RLE

Created on 2003-06-09 by Rohan Pall

This is a simple library for making color gradients, inspired by GPS's code for drawing gradients on a canvas.

The rgbs proc assumes that you have a good color display which uses 2 bytes for each color. It then normalizes the colors to 1 byte for each color, which saves on the number of intermediate colors used for making gradients. It returns the intermediate colors in a gradient. This procedure can be used by any code that needs to find the intermediate color steps in a gradient.

Run transx::demo1, transx::demo2, and transx::paint_canvas_demo. Run each one at a time, and resize the Tk window to see the pretty colors.
  package require Tk

  namespace eval transx {

    proc rgbs {n c1 c2} {

      # Color intensities are from 0 to 65535, 2 byte colors.
      foreach {r1 g1 b1} [winfo rgb . $c1] break
      foreach {r2 g2 b2} [winfo rgb . $c2] break

      #puts "c1: $r1 $g1 $b1"
      #puts "c2: $r2 $g2 $b2"

      # Normalize intensities to 0 to 255, 1 byte colors.
      foreach el {r1 g1 b1 r2 g2 b2} {
        set $el [expr {[set $el] * 255 / 65535}].0
      }

      #puts "c1: $r1 $g1 $b1"
      #puts "c2: $r2 $g2 $b2"

      if {$n == 1} {
        set r_step 0.0 ; set g_step 0.0 ; set b_step 0.0
      } else {
        set r_step [expr {($r2-$r1) / ($n-1)}]
        set g_step [expr {($g2-$g1) / ($n-1)}]
        set b_step [expr {($b2-$b1) / ($n-1)}]
      }

      #puts "$r_step $g_step $b_step"

      set steps {}
      for {set i 0} {$i < $n} {incr i} {
        set r [expr {int($r_step * $i + $r1)}]
        set g [expr {int($g_step * $i + $g1)}]
        set b [expr {int($b_step * $i + $b1)}]
        #puts "$r $g $b"
        lappend steps [format "#%.2X%.2X%.2X" $r $g $b]
      }

      return $steps
    }

    proc demo1 {} {
      set n 50
      set steps [rgbs $n red royalblue]
      for {set i 0} {$i < $n} {incr i} {
        set fr .f$i
        frame $fr -bg [lindex $steps $i] -height 1
        pack $fr -fill x
      }
    }

    proc demo2 {} {
      set n 50
      set steps [rgbs $n yellow red]
      set c [canvas .c]
      pack $c -fill both -expand 1
      update
      set width  [winfo width $c]
      set height [winfo height $c]
      for {set i 0} {$i < $n} {incr i} {
        $c create line 0 $i $width $i -tags gradient -fill [lindex $steps $i]
      }
    }
  
    proc paint_canvas {c type c1 c2} {
      $c delete gradient
      set w [winfo width $c]
      set h [winfo height $c]
      if {[string equal $type "x"]} {
        set n $w
        set steps [rgbs $n $c1 $c2]
        for {set i 0} {$i < $n} {incr i} {
          $c create line $i 0 $i $h -tags gradient -fill [lindex $steps $i]
        }
      } else {
        set n $h
        set steps [rgbs $n $c1 $c2]
        for {set i 0} {$i < $n} {incr i} {
          $c create line 0 $i $w $i -tags gradient -fill [lindex $steps $i]
        }
      }
      return
    }
  
    proc paint_canvas_demo {} {
      canvas .c1
      canvas .c2
      bind .c1 <Configure> [list transx::paint_canvas %W x red royalblue]
      bind .c2 <Configure> [list transx::paint_canvas %W y yellow red]
      pack .c1 .c2 -fill both -expand 1
    }
  
  }

Mick O'Donnell adds: (14 Jun 2003):

Here is another demo for the above, this drawing a sphere with light-source from top-left.
    proc demo3 {} {
        set n 90
        set steps [rgbs $n white blue]
        set c [canvas .c -height 200 -width 200 -bg wheat]
        pack $c -fill both -expand 1
        update
        set width  [winfo width $c]
        set height [winfo height $c]
        set centre 100
        for {set i $n} {$i > 0} {incr i -1} {
            set centre [expr $centre - 0.55]
            set x1 [expr $centre - $i]
            set x2 [expr $centre + $i]
            set color [lindex $steps $i]
            $c create oval  $x1 $x1  $x2 $x2 -tags gradient -fill $color -outline $color
        }
    }