Keith Vetter 2010-06-02 : The Pythagoras Tree is a plane fractal constructed from squares. It is named after Pythagoras because each triple of touching squares encloses a right triangle, in a configuration traditionally used to depict the Pythagorean theorem.
##+########################################################################## # # Pythagoras Tree # by Keith Vetter, June 2010 # package require Tk set S(color,0) green4 set S(right) 1 set S(treeSize) 1 set S(newSize) 1 set S(sq) 100 set S(sq2) [expr {$S(sq)/2.0}] set S(dotSize) 5 set S(margin) 10 set S(dot,angle) 90 set S(dot,length) $S(sq2) proc DoDisplay {} { global S wm title . "Pythagoras Tree" canvas .c -width 600 -height 500 -bd 2 -relief ridge \ -highlightthickness 0 -bg beige bind .c <Configure> {ResizeWindow %h %w} pack .c -side top -fill both -expand 1 ::ttk::scale .s -from 1 -to 10 -variable S(newSize) -orient horizontal \ -command Grow ::ttk::checkbutton .circle -variable ::S(right) -text "Right triangles" ::ttk::button .about -text About -command About pack .s .circle -side left -padx 10 pack .about -side right -padx 10 for {set i 0} {$i < 10} {incr i} { set i2 [expr {$i+1}] set S(color,$i2) [::tk::Darken $S(color,$i) 120] } bind all <F2> {console show} } ##+########################################################################## # # ResizeWindow -- Keeps 0,0 in center of canvas # proc ResizeWindow {h w} { set h [expr {$h / 2.0}] set w [expr {$w / 2.0}] .c config -scrollregion [list -$w -$h $w $h] ReDraw all } ##+########################################################################## # # Grow -- Changes depth of tree # proc Grow {val} { global S set new [expr {round($S(newSize))}] if {$new == $S(treeSize)} return if {$new > $S(treeSize)} { for {set lvl $S(treeSize)} {$lvl < $new} {incr lvl 1} { set nextLevel [expr {$lvl + 1}] foreach parent [.c find withtag lvl,$lvl] { _Draw2NewSquares $nextLevel $parent } } set S(treeSize) $new } elseif {$new < $S(treeSize)} { for {set lvl $S(treeSize)} {$lvl > $new} {incr lvl -1} { .c delete lvl,$lvl } set S(treeSize) $new } .c raise arc .c raise dot } ##+########################################################################## # # ReDraw -- Draws the initial fractal # proc ReDraw {{clean 0}} { global S .c delete tree if {$clean eq "all"} { .c delete all } if {[.c find withtag root] eq ""} { # Every square is poly with clockwise vertices starting at top left set x3 [expr {- $S(sq2)}] set y3 [expr {[winfo height .c]/2.0 - $S(margin)}] set x0 $x3 set y0 [expr {$y3 - $S(sq)}] set x1 $S(sq2) set y1 $y0 set x2 $x1 set y2 $y3 set S(oxy) [list 0 $y0] set S(oy) $y0 .c create poly $x0 $y0 $x1 $y1 $x2 $y2 $x3 $y3 -tag {root box lvl,0} \ -fill $S(color,0) -outline black set yy0 [expr {$y0 - $S(sq2)}] set yy2 [expr {$y0 + $S(sq2)}] set xy [list $x0 $yy0 $x2 $yy2] .c create arc $xy -extent 180 -tag arc -outline magenta -style arc after idle { set xy [.c coords arc] .c delete arc .c create arc $xy -extent 180 -tag arc -outline magenta -style arc .c raise dot } set S(ax) 0 set S(ay) $yy0 DrawDot $S(ax) $S(ay) .c create text 0 -$y3 -tag title -text "Pythagoras Tree" -anchor n \ -font {Times 36 bold} } for {set lvl 0} {$lvl < $S(treeSize)} {incr lvl} { set nextLevel [expr {$lvl + 1}] foreach parent [.c find withtag lvl,$lvl] { _Draw2NewSquares $nextLevel $parent } } .c raise arc .c raise dot } ##+########################################################################## # # _Draw2NewSquares -- Draws the 2 children squares off of a parent square # proc _Draw2NewSquares {lvl parent} { global S # Calculate new vertex offset from top of parent square lassign [.c coords $parent] x0 y0 x1 y1 set newScale [expr {$S(dot,length) * pow(sqrt(2.0)/2, $lvl-1)}] set z [VScale [VSub [list $x1 $y1] [list $x0 $y0]] .5] set z2 [VResize $z $newScale] set z3 [VRotate $z2 $S(dot,angle)] set p [VAdd [VAdd [list $x0 $y0] $z] $z3] _DrawSquareFromBottom $lvl $p [list $x0 $y0] _DrawSquareFromBottom $lvl [list $x1 $y1] $p } ##+########################################################################## # # _DrawSquareFromBottom -- Draws square given bottom two points # proc _DrawSquareFromBottom {lvl p2 p3} { set V [VSub $p2 $p3] _DrawSquareFromBottomV $lvl $p3 $V } ##+########################################################################## # # _DrawSquareFromBottomV -- Draws square given bottom left point # and bottom vector # proc _DrawSquareFromBottomV {lvl p3 V} { set N [VNormalLeft $V] set p0 [VAdd $p3 $N] set p1 [VAdd $p0 $V] set p2 [VAdd $p3 $V] set xy [concat $p0 $p1 $p2 $p3] .c create poly $xy -tag [list tree box lvl,$lvl] -fill $::S(color,$lvl) \ -outline black } ##+########################################################################## # # DrawDot -- Draws or moves the dot used to twist the fractal # proc DrawDot {x y} { global S set xy [list [expr {$x-$::S(dotSize)}] [expr {$y-$::S(dotSize)}] \ [expr {$x+$::S(dotSize)}] [expr {$y+$::S(dotSize)}]] if {[.c find withtag dot] eq ""} { .c create oval $xy -tag dot -fill magenta -outline magenta .c bind dot <1> [list DotMove %x %y] .c bind dot <B1-Motion> [list DotMove %x %y] } else { .c coords dot $xy } } ##+########################################################################## # # DotMove -- Handles mouse moving the dot # proc DotMove {x y} { global S set x [.c canvasx $x] set y [.c canvasy $y] if {$y > $S(oy)} { set y $S(oy)} if {$::S(right)} { set V [VSub [list $x $y] $S(oxy)] set V2 [VResize $V $S(sq2)] set P [VAdd $S(oxy) $V2] lassign $P x y } DrawDot $x $y set V1 [VSub [list $x $y] $S(oxy)] set V2 [list 1 0] set S(dot,angle) [VAngle $V1 $V2] set S(dot,length) [VLength $V1] ReDraw } proc About {} { set msg "Pythagoras Tree\nby Keith Vetter\nJune 2010\n\n" append msg "The Pythagoras Tree is a plane fractal constructed\n" append msg "from squares. It is named after Pythagoras because\n" append msg "each triple of touching squares encloses a right\n" append msg "triangle, in a configuration traditionally used to\n" append msg "depict the Pythagorean theorem." tk_messageBox -icon info -message $msg } # Vector routines # VAdd -- adds two vectors w/ scaling of 2nd vector # VSub -- subtract two vectors # VScale -- multiplies vector size # VResize -- sets vector size to a given length # VNormalLeft -- returns normal vector to a given vector # VRotate -- rotates vector anti-clockwise # VAngle -- determines angle between two vectors # VDot -- computes dot product of two vectors # VLength -- returns length of a vector proc VAdd {v1 v2 {scaling 1}} { foreach {x1 y1} $v1 {x2 y2} $v2 break return [list [expr {$x1 + $scaling*$x2}] [expr {$y1 + $scaling*$y2}]] } proc VSub {v1 v2} { return [VAdd $v1 $v2 -1] } proc VScale {v scaling} { lassign $v x y return [list [expr {$x * $scaling}] [expr {$y * $scaling}]] } proc VResize {v newSize} { set ::v $v; set ::newSize $newSize lassign $v x y set len [expr {hypot($x,$y)}] if {$len == 0} { return {0 0}} return [list [expr {$x * $newSize / $len}] [expr {$y * $newSize / $len}]] } proc VNormalLeft {vv} { foreach {x y} $vv break return [list $y [expr {-$x}]] set len [expr {hypot($x,$y)}] set xx [expr {-$y * $length / $len}] set yy [expr {$x * $length / $len}] return [list $xx $yy] } proc VRotate {v degree} { set rad [expr {-$degree * acos(-1)/180}] set cos [expr {cos($rad)}] set sin [expr {sin($rad)}] lassign $v x0 y0 set x [expr {$x0*$cos - $y0*$sin}] set y [expr {$x0*$sin + $y0*$cos}] return [list $x $y] } proc VAngle {V1 V2} { set v1 [VResize $V1 1] set v2 [VResize $V2 1] set dot [VDot $v1 $v2] set angle [expr {acos($dot) * 180 / acos(-1)}] return $angle } proc VDot {v1 v2} { foreach {x1 y1} $v1 {x2 y2} $v2 break return [expr {$x1*$x2 + $y1*$y2}] } proc VLength {v} { lassign $v x y return [expr {hypot($x,$y)}] } ################################################################ DoDisplay update ;# causes Redraw to be called return