Keith Vetter 2002-11-19 - This draws the Mandelbrot Fractal. You can highlight a portion and zoom in to it, or zoom back out.
I'm not totally happy with the coloring scheme. I originally tried varying the brightness of the base color (using code from
Making color gradients) and you can choose that option. But I found I preferred just choosing colors at random.
One curiousity: drawing pixel by pixel into a canvas was too slow. Instead, I placed a blank image on the canvas and am drawing the fractal into it (and following the advice of
Tk image Dos and Don'ts I'm painting by rows).
I could probably get better numeric precision if I used the
mpexpr package but I'll leave that as a future improvement.
For a short version, see also
Mandelbrot and Julia sets
##+################################################################
#
# TkMandelbrot -- draws the mandelbrot fractal
# based on http://www.students.tut.fi/~warp/Mandelbrot/
# by Keith Vetter
#
# Revisions:
# KPV Nov 13, 2002 - initial revision
#
##+################################################################
###################################################################
set tcl_precision 17
set Cwidth 500 ;# Canvas size
set Cheight 500
set Rmin -2.0 ;# Left side
set Rmax 1.0 ;# Right side
set Imin -1.5 ;# Bottom
set Imax [expr {$Imin + ($Rmax - $Rmin) * $Cheight /$Cwidth}]
set Rscale [expr {($Rmax - $Rmin) / $Cwidth}]
set Iscale [expr {($Imax - $Imin) / $Cheight}]
set maxIters 50
set S(draw) 0
set S(color) red
set S(title) "Tk Mandelbrot"
set S(version) 1.0
lappend S(stack) [list $Rmin $Imax $Rmax $Imin]
expr srand([clock clicks])
##+################################################################
#
# DoDisplay -- sets up our gui
#
proc DoDisplay {} {
global Cwidth Cheight
wm title . $::S(title)
frame .bottom -bd 2 -relief ridge
button .redraw -text "Redraw" -command Redraw
set font "[font actual [.redraw cget -font]] -weight bold"
.redraw configure -font $font
catch {image create photo ::img::blank -width 1 -height 1}
button .clear -text Clear -font $font -command Clear
button .zoomin -text "Zoom In" -font $font -command ZoomIn
button .zoomout -text "Zoom Out" -font $font -command ZoomOut
button .color -text "Select Color" -font $font -command {ChangeColor 0}
button .random -text "Random Colors" -font $font -command {ChangeColor 1}
button .about -image ::img::blank -command About -highlightthickness 0
frame .flbl
label .lbl -bd 2 -relief ridge -textvariable S(msg)
canvas .c -width $Cwidth -height $Cheight -bd 2 -relief ridge -bg gray50 \
-highlightthickness 0
.c xview moveto 0 ; .c yview moveto 0
image create photo ::img::myImage -width $Cwidth -height $Cheight
.c create image 0 0 -image ::img::myImage -anchor nw -tag image
ToggleButtons 0
pack .bottom -side right -fill y -ipadx 10 -ipady 5
set row -1
grid rowconfigure .bottom [incr row] -minsize 5
grid .zoomin -in .bottom -sticky ew -pady 2 -row [incr row]
grid .zoomout -in .bottom -sticky ew -pady 2 -row [incr row]
grid rowconfigure .bottom [incr row] -minsize 20
grid .redraw -in .bottom -sticky ew -pady 2 -row [incr row]
grid .clear -in .bottom -sticky ew -pady 2 -row [incr row]
grid rowconfigure .bottom [incr row] -minsize 20
grid rowconfigure .bottom [incr row] -weight 1
grid .color -in .bottom -sticky ew -pady 2 -row [incr row]
grid .random -in .bottom -sticky ew -pady 2 -row [incr row]
grid rowconfigure .bottom [incr row] -minsize 5
pack .flbl -side bottom -fill x
pack .lbl -in .flbl -side bottom -fill x
pack .c -fill both -expand 1
bind .c <Button-1> [list DoBox 0 %x %y]
bind .c <B1-Motion> [list DoBox 1 %x %y]
bind all <Alt-c> {console show}
update
pack propagate .flbl 0 ;# Don't let it grow
place .about -in .bottom -relx 1 -rely 1 -anchor se
}
##+################################################################
#
# ToggleButtons -- changes button state if we're drawing
#
proc ToggleButtons {drawing} {
global S
array set state {0 disabled 1 normal}
if {$drawing} {
foreach w {.zoomin .zoomout .clear .color .random} {
$w config -state disabled
}
.redraw config -text "Stop Drawing"
return
}
foreach w {.clear .color .random} {
$w config -state normal
}
.zoomout config -state $state([expr {[llength $S(stack)] > 1}])
.zoomin config -state $state([expr {[llength [.c find withtag box]] > 1}])
.redraw config -text "Redraw"
}
##+################################################################
#
# Render -- Renders the mandelbrot set
#
proc Render {} {
global Cwidth Cheight Rmin Rmax Imin Imax maxIters Rscale Iscale
global S
set sTime [clock click -milliseconds]
ToggleButtons 1
set S(draw) 1
if {[winfo ismapped .c]} { ;# Recompute scaling factors
set Cheight [winfo height .c]
set Cwidth [winfo width .c]
set Rscale [expr {($Rmax - $Rmin) / $Cwidth}]
set Iscale [expr {($Imax - $Imin) / $Cheight}]
}
Clear
::img::myImage config -width $Cwidth -height $Cheight
set step 4 ;# Do interlaced drawing
for {set start 0} {$start < $step} {incr start} {
for {set x $start} {$x < $Cwidth} {incr x $step} {
set c_re [expr {$Rmin + $x * $Rscale}]
set data ""
for {set y 0} {$y < $Cheight} {incr y} {
set c_im [expr {$Imax - $y * $Iscale}]
set z_re $c_re
set z_im $c_im
for {set n 0} {$n < $maxIters} {incr n} {
set z_re2 [expr {$z_re * $z_re}] ;# Have we escaped yet???
set z_im2 [expr {$z_im * $z_im}]
if {($z_re2 + $z_im2) > 4} {
break
}
set z_im [expr {2 * $z_re * $z_im + $c_im}]
set z_re [expr {$z_re2 - $z_im2 + $c_re}]
}
lappend data $::colors($n)
}
::img::myImage put $data -to $x 0
update
if {$S(draw) == 0} break
}
if {$S(draw) == 0} break
}
set S(draw) 0
ToggleButtons 0
set sTime [expr {([clock click -milliseconds] - $sTime) / 1000}]
INFO "Time: [Duration $sTime]"
}
##+################################################################
#
# gradient -- adjusts a color to be "closer" to either white or black
# see http://wiki.tcl.tk/2847
#
proc gradient {rgb factor} {
foreach {r g b} [winfo rgb . $rgb] {break}
# Figure out color depth and number of bytes to use in the final result.
set max 255; set len 2
if {($r > 255) || ($g > 255) || ($b > 255)} {set max 65535; set len 4}
# Compute new red value by incrementing the existing value by a
# value that gets it closer to either 0 (black) or $max (white)
set range [expr {$factor >= 0.0 ? $max - $r : $r}]
set increment [expr {int($range * $factor)}]
incr r $increment
# Compute a new green value in a similar fashion
set range [expr {$factor >= 0.0 ? $max - $g : $g}]
set increment [expr {int($range * $factor)}]
incr g $increment
# Compute a new blue value in a similar fashion
set range [expr {$factor >= 0.0 ? $max - $b : $b}]
set increment [expr {int($range * $factor)}]
incr b $increment
### Format the new rgb string
set rgb [format "#%.${len}X%.${len}X%.${len}X" \
[expr {($r>$max)?$max:(($r<0)?0:$r)}] \
[expr {($g>$max)?$max:(($g<0)?0:$g)}] \
[expr {($b>$max)?$max:(($b<0)?0:$b)}]]
return $rgb
}
##+################################################################
#
# GradientColors
#
# Get maxIters number of colors in a gradient from black to white of
# color RGB.
#
proc GradientColors {{rgb red} {min -.5} {max .75}} {
global S colors maxIters
set S(color) $rgb
for {set i 0} {$i <= $maxIters} {incr i} {
set grad [expr {$min + 1.0* $i * ($max - $min) / $maxIters}]
set colors($i) [gradient $rgb $grad]
}
set colors($maxIters) black
}
##+################################################################
#
# RandomColors -- picks colors randomly
#
proc RandomColors {} {
global colors maxIters
for {set i 0} {$i <= $maxIters} {incr i} {
set colors($i) [format "\#%04X%04X%04X" [expr {int(rand() * 0xFFFF)}] \
[expr {int(rand() * 0xFFFF)}] [expr {int(rand() * 0xFFFF)}]]
}
set colors($maxIters) black
}
##+################################################################
#
# ChangeColor -- puts in a new color scheme
#
proc ChangeColor {random} {
global S maxIters
if {$random} {
RandomColors
INFO "Selecting new colors randomly -- press Redraw to see"
} else {
set color [tk_chooseColor -initialcolor $S(color) -parent . \
-title "Tk Mandelbrot Color"]
if {$color == ""} return
INFO "Setting new color $color -- press Redraw to see"
GradientColors $color
}
}
##+################################################################
#
# Canvas2Z -- converts from canvas to mandelbrot coordinates
#
proc Canvas2Z {x y} {
global Rmin Imax Rscale Iscale
set re [expr {$Rmin + $Rscale * $x}]
#set im [expr {$Imin + $Iscale * $y}]
set im [expr {$Imax - $Iscale * $y}]
return [list $re $im]
}
##+################################################################
#
# DoBox -- handles mousing to create the zoom box
#
proc DoBox {what x y} {
global B
.c delete box
if {$what == 0} { ;# Button down
.zoomin config -state disabled ;# No box, no button
set B(x0) [.c canvasx $x]
set B(y0) [.c canvasx $y]
} else { ;# Button motion
set B(x1) [.c canvasx $x]
set B(y1) [.c canvasx $y]
.c create rect $B(x0) $B(y0) $B(x1) $B(y1) -outline white -tag box \
-dash 1
.zoomin config -state normal ;# Have box, have button
}
}
##+################################################################
#
# Redraw -- starts or stops drawing of the fractal
#
proc Redraw {} {
global S
if {$S(draw)} {
INFO "stopping"
set S(draw) 0
return
}
INFO "redrawing..."
Render
}
##+################################################################
#
# ZoomIn -- zooms in the display to the box on the screen
#
proc ZoomIn {} {
global S Rmin Rmax Imin Imax
INFO "zooming in..."
if {[.c find withtag box] != ""} {
foreach {x0 y0 x1 y1} [.c bbox box] break
.c delete box
foreach {Rmin2 Imax2} [Canvas2Z $x0 $y0] break
foreach {Rmax2 Imin2} [Canvas2Z $x1 $y1] break
foreach {Rmin Rmax Imin Imax} \
[list $Rmin2 $Rmax2 $Imin2 $Imax2] break
}
lappend S(stack) [list $Rmin $Imax $Rmax $Imin]
after 1 Render
}
##+################################################################
#
# ZoomOut -- pops coordinates off stack and renders them
#
proc ZoomOut {} {
global S Rmin Rmax Imin Imax
if {[llength $S(stack)] < 2} return
INFO "zooming out..."
set a [lindex $S(stack) end-1]
set S(stack) [lrange $S(stack) 0 end-1] ;# Leave current at the end
foreach {Rmin Imax Rmax Imin} $a break
after 1 Render
}
proc INFO {msg} {
set ::S(msg) $msg
}
proc About {} {
tk_messageBox -icon info -parent . -title "About $::S(title)" \
-message "$::S(title)\n\nby Keith Vetter\nNovember, 2002"
}
##+################################################################
#
# Duration - Prints out seconds in a nice format
# http://wiki.tcl.tk/789
#
proc Duration { int_time } {
if {$int_time == 0} {return "0 secs"}
set timeList [list]
foreach div {86400 3600 60 1} mod {0 24 60 60} name {day hr min sec} {
set n [expr {$int_time / $div}]
if {$mod > 0} {set n [expr {$n % $mod}]}
if {$n > 1} {
lappend timeList "$n ${name}s"
} elseif {$n == 1} {
lappend timeList "$n $name"
}
}
return [join $timeList]
}
proc Clear {} {
.c delete box
::img::myImage blank
}
################################################################
################################################################
################################################################
DoDisplay
RandomColors
INFO "Welcome to Tk Mandelbrot"
Render
Kris 2007-08-05 - I tweaked the interlaced rendering a little:
in proc Render
replace
set step 4 ;# Do interlaced drawing
for {set start 0} {$start < $step} {incr start} {with
foreach {start wid step} {0 8 8 4 4 8 2 2 4 1 1 1} {and
::img::myImage put $data -to $x 0
with
for {set xx $x} {$xx < $x+$wid} {incr xx} {
::img::myImage put $data -to $xx 0
}This may slow down the rendering but I think the "first results" are better than with the thin stripes.
RVB This is a great script! I added another color scheme (HSV variation)
##+################################################################
#
# RvbColors -- picks colors
#
proc RvbColors {} {
global colors maxIters
set s 0.8
set v 0.9
set scale_colors {}
set nc $maxIters
for {set i 0} {$i <= $maxIters} {incr i} {
set h [expr (360.0*$i)/$nc]
set k [expr int($h/60.0) % 6]
set f [expr $h/60.0 - $k]
set p [expr $v*(1-$s)]
set q [expr $v*(1-$f*$s)]
set t [expr $v*(1-(1-$f)*$s)]
switch -- $k {
0 {set r $v; set g $t; set b $p}
1 {set r $q; set g $v; set b $p}
2 {set r $p; set g $v; set b $t}
3 {set r $p; set g $q; set b $v}
4 {set r $t; set g $p; set b $v}
5 {set r $v; set g $p; set b $q}
}
set r [expr {int($r*0xFFFF)}]
set g [expr {int($g*0XFFFF)}]
set b [expr {int($b*0XFFFF)}]
set colors($i) [format "\#%04X%04X%04X" $r $g $b]
}
set colors($maxIters) black
}
