##+##########################################################################
 #
 # Fern.tcl - description
 # by Keith Vetter -- November 30, 2003
 #
 # This image of a Black Spleenwort fern is often called the Barnsley's
 # Fern after Michael Barnsley. It is one of the best known of the
 # Iterated Function System (IFS) fractals (technically it's not a
 # fractal but everyone calls it one). An IFS takes a point and
 # performs an affine transformation--translation, rotation and
 # contraction--on it, then repeats. For the fern, there are four
 # affine transformation that are used with certain probabilities.
 
 # Define our affine transformations
 # (x,y) <== (rx(cos(A)) - sy(sin(B)) + h, rx(sin(A)) + sy(cos(B)) + k)
 # (x,y) <== (ax + by + h, cx + dy + k)
 array set TRANS {
    - {P       a     b     h          c     d     k}
    0 {0.02    0.0   0.0   0.5        0.0   0.27  0}
    1 {0.15    -.139 0.263 0.57       0.246 0.224 -.036}
    2 {0.13    0.17  -.215 0.408      0.222 0.176 0.0893}
    3 {0.70    0.781 0.034 0.1075     -.032 0.739 0.27}
 }
 array set S {title "Fern Fractal" W 500 H 500 color green}
 
 proc OnePixel {} {
    global S xx yy TRANS
 
    # Pick which transformation to use
    set rand [expr {rand()}]
    for {set i 0} {$i < 3} {incr i} {
        set p [lindex $TRANS($i) 0]
        if {$rand < $p} break
        set rand [expr {$rand - $p}]
    }
 
    # (x,y) <== (ax + by + h, cx + dy + k)
    foreach {p a b h c d k} $TRANS($i) break
    foreach xx [expr {$a*$xx + $b*$yy + $h}] \
            yy [expr {$c*$xx + $d*$yy + $k}] break
 
    set sx [expr {$S(W) * $xx}]                 ;# Map to screen coordinates
    set sy [expr {$S(H) - ($S(H) * $yy)}]       ;# Make fern grow upwards
    .c create rect $sx $sy $sx $sy -fill $S(color) -outline {}
    return
 }
 proc Run {} {
    foreach id [after info] {after cancel $id}  ;# Be safe
    if {$::S(go)} {
        OnePixel
        after 1 Run
    }
 }
 proc tracer {var1 var2 op} {
    if {$::S(go)} {
        .start config -state disabled
        .stop config -state normal
        Run
    } else {
        .start config -state normal
        .stop config -state disabled
    }
 }
 proc Resize {W h w} {
    foreach ::S(H) $h ::S(W) $w break
    Reset
 }
 proc Reset {} {
    .c delete all
    set ::xx [expr {rand()}]
    set ::yy [expr {rand()}]
 }
 proc DoDisplay {} {
    global S
 
    wm title . $S(title)
    pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \
        -side right -fill both -ipady 5
    pack [frame .top -relief ridge -bd 2] -side top -fill x
    pack [frame .screen -bd 2 -relief raised] -side top -fill both -expand 1
    canvas .c -relief raised -bd 2 -height $S(H) -width $S(W) -bg black 
    pack .c -side top -in .screen -fill both -expand 1
 
    set colors {red orange yellow green blue cyan purple violet white black}
    foreach color $colors {
        radiobutton .top.b$color -width 1 -padx 0 -pady 0 -bg $color \
            -variable S(color) -value $color
        bind .top.b$color <3> [list .c config -bg $color]
    }
    eval pack [winfo children .top] -side left -fill y
    DoCtrlFrame
    
    bind all <Key-F2> {console show}
    bind .c <Configure> {Resize %W %h %w}
    trace variable S(go) w tracer
    update
 }
 proc DoCtrlFrame {} {
    option add *Button.borderWidth 4
    button .start -text "Start" -command {set S(go) 1}
    .start configure -font "[font actual [.start cget -font]] -weight bold"
    option add *Button.font [.start cget -font]
    button .stop  -text "Stop" -command {set S(go) 0}
    button .reset -text "Reset" -command Reset
    button .about -text About -command [list tk_messageBox -title $::S(title) \
          -message "$::S(title)\nby Keith Vetter, November 2003"]
    grid .start -in .ctrl -row 1 -sticky ew
    grid .stop  -in .ctrl -row 2 -sticky ew
    grid .reset -in .ctrl -row 3 -sticky ew -pady 10
    grid rowconfigure .ctrl 50 -weight 1
    grid .about -in .ctrl -row 100 -sticky ew 
 }
 DoDisplay
 set S(go) 1