#! /bin/env tclsh

# growingtree.tcl
# Author:      Gerard Sookahet
# Date:        08 Jan 2010
# Description: Draw an interactive tree with controls

package require Tk

bind all <Escape> {exit}

proc About {} {
    set w .about
    catch {destroy $w}
    toplevel $w
    wm title $w {About growingtree}
    message $w.msg -justify center -aspect 250 -relief sunken -bg blue \
        -fg white -text "growingtree\n\nGerard Sookahet\n\nJanuary 2010"
    button $w.bquit -text { OK } -command {destroy .about}
    pack {*}[winfo children $w]
}

proc Init w {
    global lcolor
    global rdepth bendangle0 branchangle0 trunkratio branchratio
    global bendangle branchangle 
    global height H

    set rdepth 5
    set bendangle0 9
    set branchangle0 60
    set trunkratio .2
    set branchratio .4
    set height 2.6
    set lcolor {}
   
    set bendangle $bendangle0
    set branchangle $branchangle0
   
    set lcolor {#00ff00 #00e500 #00cc00 #00b200 #009900 #007f00 #006600 #004c00 #003300 #001900}
   
    DrawTree $w 200 400 $branchangle0 [expr {($H-200)*$height}] $rdepth
}

proc Main N {
    global lcolor
    global rdepth bendangle0 branchangle0 trunkratio branchratio
    global height H 

    set w .itree
    catch {destroy $w}
    toplevel $w
    wm withdraw .
    wm title $w "Growing tree"
    wm geometry $w +10+10
    $w config -bg darkblue
   
    set f0 [frame $w.f0]
    pack [canvas $w.c -width $N -height $N -bg white] $f0 -side left
   
    set H $N
    Init $w
   
    set f1 [frame $f0.f1 -relief sunken -bd 1]
    pack $f1 -fill x
    scale $f1.sc1 -from 1 -to 10 -length 360 -resolution 1 -label "branch level" \
                  -orient horiz -bd 1 -showvalue true -variable rdepth \
                  -command "RedrawTree $w"
    scale $f1.sc2 -from -60 -to 60 -length 360 -resolution 1 -label "bend angle" \
                  -orient horiz -bd 1 -showvalue true -variable bendangle0  \
                  -command "RedrawTree $w"
    scale $f1.sc3 -from 0 -to 180 -length 360 -resolution 1 -label "branch angle" \
                  -orient horiz -bd 1 -showvalue true -variable branchangle0 \
                  -command "RedrawTree $w"
    scale $f1.sc4 -from 0 -to 0.7 -length 360 -resolution 0.01 -label "trunk ratio" \
                  -orient horiz -bd 1 -showvalue true -variable trunkratio \
                  -command "RedrawTree $w"
    scale $f1.sc5 -from 0.1 -to 2.0 -length 360 -resolution 0.1 -label "branch ratio" \
                  -orient horiz -bd 1 -showvalue true -variable branchratio \
                  -command "RedrawTree $w"
    scale $f1.sc6 -from 0.1 -to 4.0 -length 360 -resolution 0.1 -label "tree height" \
                  -orient horiz -bd 1 -showvalue true -variable height \
                  -command "RedrawTree $w"
    eval pack [winfo children $f1] 
   
    set f3 [frame $f0.f3 -relief sunken -bd 1]
    pack $f3 -fill x
    button $f3.ba -text About -width 6 -bg blue -fg white -command About
    button $f3.bq -text Quit -width 5 -bg blue -fg white -command exit
    eval pack [winfo children $f3] -side left
}

proc DrawTree {w xo yo a r level} {
    global lcolor
    global bendangle branchangle trunkratio branchratio height 

    set rad 0.0174532925
    set arad [expr {$a*$rad}]
    set rtr  [expr {$r*$trunkratio}]
   
    set x [expr {$xo + cos($arad)*$rtr}]
    set y [expr {$yo - sin($arad)*$rtr}]
   
    $w.c create line $xo $yo $x $y -fill [lindex $lcolor $level] -width $level 
    if {$level > 0} then {
      incr level -1
      set a [expr {$a + $bendangle}]
      set rbr [expr {$r*$branchratio}]
      DrawTree $w $x $y [expr {$a - $branchangle}] $rbr $level
      DrawTree $w $x $y [expr {$a + $branchangle}] $rbr $level
      DrawTree $w $x $y $a [expr {(1 - $trunkratio)*$r}] $level
    }
}

proc RedrawTree {w v} {
    global lcolor
    global rdepth bendangle0 branchangle0 bendangle branchangle 
    global height H 

    $w.c delete all
   
    set rad 0.0174532925
    set bendangle   $bendangle0
    set branchangle $branchangle0
   
    DrawTree $w 200 400 90 [expr {($H-200)*$height}] $rdepth
}

Main 400