##+##########################################################################
#
# 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) 1uniquename 2013aug18For readers who do not have the time/facilities/whatever to setup the code and execute it, here is an image to show what the code above does.
AM (13 august 2009) Here is another example of this technique - just for fun. As at each step a complete picture is drawn, the number of pictures is much smaller than the number of points in the Fern Fractal. I experimented with this to see if it would make a good design for a "flyer".
# fractal_picture.tcl --
# Experiment with a fractal picture
#
# drawPicture --
# Draw the new scaled and dislocated picture
#
# Arguments:
# xc X-coordinate to use (centre)
# yc Y-coordinate to use (centre)
# scale Scale of the picture
#
proc drawPicture {xc yc scale} {
set coords {}
foreach {xp yp} {-50 -50 -50 50 50 50 50 -50} {
lappend coords [expr {$xc + $scale * $xp}] \
[expr {$yc + $scale * $yp}]
}
.cnv lower [.cnv create polygon $coords -fill green -outline black]
}
# nextGeneration --
# Produce the next generation of pictures
#
# Arguments:
# previous Triples describing the previous generation
#
# Returns:
# Flattened list of triples for the new generation
#
proc nextGeneration {previous} {
set next {}
set factor 0.5
foreach {xc yc scale} $previous {
set scale [expr {$factor * $scale}]
foreach {xa ya} {0 0 500 0 500 500 0 500} {
set xn [expr {$xa + $factor * ($xc-$xa)}]
set yn [expr {$ya + $factor * ($yc-$ya)}]
drawPicture $xn $yn $scale
lappend next $xn $yn $scale
}
}
return $next
}
# main --
# Draw the thing
#
pack [canvas .cnv -width 500 -height 500]
set pictureParameters {250 250 1.0}
drawPicture 250 250 1.0
foreach generation {0 1 2 3 4 5} {
set pictureParameters [nextGeneration $pictureParameters]
}