Pythagoras Tree

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.


https://wiki.tcl-lang.org/_repo/wiki_images/pythagorasTree.png

Jeff Smith 2019-04-21: Below is an online demo using CloudTk



uniquename 2013aug17 - Compared to other displays of the Pythagoras tree that I have seen, it looks like there may be something amiss here. The (white) triangle surrounded by 3 squares looks like it starts off right --- a right angle opposite the largest square. But many of the other 'white' triangles do not look right --- the angle that should be a right angle is sometimes greater than 90 and sometimes less than 90. Is this some kind of variation on the Pythagoras tree that one typically sees?? (I see the 'Right triangles' checkbox is checked --- so it looks like you allow for variation. But should this be happening when that checkbox is checked?)

kpv 2017-10-06 : fixed


##+##########################################################################
#
# 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

proc DoDisplay {} {
    global S
    pack [::ttk::frame .f] -side left -fill both -expand 1 ;# For ttk styling

    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 -in .f

    ::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 -in .f
    pack .about -side right -padx 10 -in .f

    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 tree}} {
    global S
    .c delete $clean
    DrawRoot

    for {set lvl 1} {$lvl <= $S(treeSize)} {incr lvl} {
        set previousLevel [expr {$lvl - 1}]
        foreach parent [.c find withtag lvl,$previousLevel] {
            _Draw2NewSquares $lvl $parent
        }
    }
    .c raise arc
    .c raise dot
}
proc DrawRoot {} {
    global S

    if {[.c find withtag root] ne ""} return

    # 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
    }
    DrawDot 0 $yy0

    .c create text 0 -$y3 -tag title -text "Pythagoras Tree" -anchor n \
        -font {Times 36 bold}
}

##+##########################################################################
#
# _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
    # top is vector halfway along "top" edge
    lassign [.c coords $parent] x0 y0 x1 y1
    set top [VScale [VSub [list $x1 $y1] [list $x0 $y0]] .5]
    set topRot [VRotate $top $S(dot,angle)]
    set topMiddle [VAdd [list $x0 $y0] $top]
    set newDot [VAdd $topMiddle $topRot]

    _DrawSquareFromBottom $lvl $newDot [list $x0 $y0]
    _DrawSquareFromBottom $lvl [list $x1 $y1] $newDot
}
##+##########################################################################
#
# _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 S(dot,xy) [list $x $y]
    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]
    ReDraw
}
proc About {} {
    set msg "Pythagoras Tree\nby Keith Vetter\nJune 2010\n\n"
    append msg "The Pythagoras Tree is a plane fractal constructed "
    append msg "from squares. It is named after Pythagoras because "
    append msg "each triple of touching squares encloses a right "
    append msg "triangle, in a configuration traditionally used to "
    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