GS (090807) L'ensemble de Mandelbrot est certainement l'une des courbes Fractales les plus connues. Voici un petit programme qui se contente de la dessiner dans un canvas. Le plus-produit étant simplement une variété de gradients bicolores.
package require Tk
bind all <Escape> {exit}
set xmin -2.2; set xmax 0.8; set ymin -1.1; set ymax 1.1
set width 400; set height $width
set itermax 32
set lclr [list red orange yellow green lightgreen darkblue blue lightblue white black]
set N [llength $lclr]
set stop 1
set l {defaut bleu_noir bleu_vert bleu_rouge bleu_jaune bleu_orange bleu_blanc \
vert_noir vert_rouge vert_jaune vert_orange vert_blanc \
rouge_noir rouge_vert rouge_jaune rouge_orange rouge_blanc}
canvas .c -width $width -height $height
spinbox .sb -values $l -command "ColorTable %s"
button .bfin -text Démarrer -width 8 -command {Mandelbrot [expr {$width/2}]}
button .bstop -text Stopper -width 8 -command {set stop 1}
button .bquit -text Quitter -width 8 -bg darkgrey -command exit
pack .c
pack .sb .bfin .bstop .bquit -side left -expand yes -fill x
# Références KPV - http://wiki.tcl.tk/16283
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 ColorTable {c} {
global lclr N
if {$c == "defaut"} then {
set lclr [list red orange yellow green lightgreen darkblue blue lightblue white black]
} else {
set tclr {bleu blue rouge red vert green jaune yellow orange orange noir black blanc white}
foreach {c1 c2} [split $c "_"] {set c1 [string map $tclr $c1]; set c2 [string map $tclr $c2]}
set lclr [Gradient $N $c1 $c2]
}
}
proc Mandelbrot {a} {
global stop lclr color N
global ymin xmin ymax xmax width height
global tag tag1 itermax
set dx [expr {($xmax-$xmin)/$a}]
set dy [expr {($ymax-$ymin)/$a}]
set bwidth [expr {$width/$a}]
set bheight [expr {$height/$a}]
set stop 0
.c delete all
for {set j 0} {$j < $a} {incr j} {
if $stop break
set y [expr {$ymin+$dy*$j}]
for {set i 0} {$i < $a} {incr i} {
set x [expr {$xmin+$dx*$i}]
set iter 0; set color 0
set zr 0; set zi 0
while {$zr*$zr+$zi*$zi < 4} {
if {[incr iter] > $itermax} {
set color [expr {$N-1}]
break
}
incr color
set old [expr {$zr*$zr-$zi*$zi+$x}]
set zi [expr {2*$zr*$zi+$y}]
set zr $old
}
.c create rect [expr {$i*$bwidth}] [expr {$j*$bwidth}] \
[expr {($i+1)*$bwidth}] [expr {($j+1)*$bheight}] \
-fill [lindex $lclr [expr {$color % $N}]] -outline ""
update
}
}
set stop 1
}Pour des explications, voir la page Fractales de David Cobac.