Updated 2018-04-29 07:21:05 by dbohdan

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
 }