[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, so rather I'm drawing the fractal into
a blank image (and following the advice of 
[Tk image Dos and Don'ts] I'm painting by row).

I could probably get better numeric precision if I used
the [mpexpr] package but I'll leave that as a future
improvement.

----
 ##+################################################################
 #
 # 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://mini.net/tcl/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://mini.net/tcl/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


----
[Category Graphics] | [Category Mathematics]