interfaces/xmaxima/Tkmaxima/colors.tcl

   1 #  $Id: colors.tcl,v 1.1 2009-11-15 22:55:35 villate Exp $
   2 #
   3 # Copyright (c) 2009, Jaime E. Villate <villate@fe.up.pt>
   4 #
   5 # Procedures to work with colors
   6 # (the license information can be found in COPYING.tcl)
   7
   8 # transform a (hue, saturation, value) set into a (red, green, blue) set
   9
  10 proc hsv2rgb {hue sat val} {
  11     if { $sat < 0 } { set sat [expr 1 -  $sat] }
  12     if { $val < 0 } { set val [expr 1 -  $val] }
  13     if { $val > 1 } { set val [expr $val - int($val)] }
  14     if { $sat > 1 } { set sat [expr $sat - int($sat)] }
  15     set v  [expr round($val*255)]
  16     if {$sat == 0} {
  17         return [format "\#%02x%02x%02x" $v $v $v]
  18     } else {
  19         set h [expr {round($hue)%360/60.0}]
  20         set i [expr {round($hue)%360/60}]
  21         set f [expr {$h-$i}]
  22         set u [expr {round($v)}]
  23         set p [expr {round($v*(1-$sat))}]
  24         set q [expr {round($v*(1-$sat*$f))}]
  25         set t [expr {round($v*(1-$sat*(1-$f)))}]
  26         switch $i {
  27             0 {set r $u; set g $t; set b $p}
  28             1 {set r $q; set g $u; set b $p}
  29             2 {set r $p; set g $u; set b $t}
  30             3 {set r $p; set g $q; set b $u}
  31             4 {set r $t; set g $p; set b $u}
  32             5 {set r $u; set g $p; set b $q}}
  33         return [format "\#%02x%02x%02x" $r $g $b]
  34     }
  35 }
  36
  37 proc rgb2list {rgb} {
  38     set num "0x"
  39     set r [append num [string range $rgb 1 2]]
  40     set num "0x"
  41     set g [append num [string range $rgb 3 4]]
  42     set num "0x"
  43     set b [append num [string range $rgb 5 6]]
  44     return [format "%d %d %d" $r $g $b]
  45 }
  46
  47 proc list2rgb {c} {
  48     return [format "\#%02x%02x%02x" [lindex $c 0] [lindex $c 1] [lindex $c 2]]}
  49
  50 proc interpolatecolor {rgb1 rgb2 f} {
  51     set c1 [rgb2list $rgb1]
  52     set c2 [rgb2list $rgb2]
  53     set r1 [lindex $c1 0]
  54     set g1 [lindex $c1 1]
  55     set b1 [lindex $c1 2]
  56     set r2 [lindex $c2 0]
  57     set g2 [lindex $c2 1]
  58     set b2 [lindex $c2 2]
  59     return [list2rgb [list [expr {round($r1+$f*($r2-$r1))}] [expr {round($g1+$f*($g2-$g1))}] [expr {round($b1+$f*($b2-$b1))}]]]
  60 }
  61