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