# lsystem2d.tcl
# Author:      Gerard Sookahet
# Date:        06 Jun 2010
# Description: 2D Lindemeyer system (L-system) to draw factal curves 
#              from a formal grammar 

package require Tk 8.5
package require tile

bind all <Escape> {exit}

# -------------------------------------------------
# Define grammar
proc DefineGrammar {} {
    global grammar

    set alphabet {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890+-[]}
    for {set i 0} {$i < [string length $alphabet]} {incr i} {
        set grammar([string index $alphabet $i]) {}
    }

    set grammar(F)  DrawObject
    set grammar(+)  RotateLeft
    set grammar(-)  RotateRight
    set grammar(\[) PushData
    set grammar(\]) PopData
    set grammar(f)  MoveForward
}

# -------------------------------------------------
# Stack procedures
proc Push { e } {
    global stack top
    set stack($top) $e
    incr top
}

proc Pop {} {
    global stack top
    if {$top == 0} return {}
    incr top -1
    set e $stack($top)
    unset stack($top)
    return $e
}

# -------------------------------------------------
# F : move forward a step and draw a line
proc DrawObject {} {
    global x0 y0 step a0 lcoord

    set a [expr {.01745329 * $a0}]
    set x1 [expr {$x0 + $step * cos($a)}]
    set y1 [expr {$y0 - $step * sin($a)}]
    lappend lcoord $x0 $y0 $x1 $y1
    set x0 $x1
    set y0 $y1
}

# + : rotate counterclockwise by an angle
proc RotateLeft {} {
    global angle a0
    set a0 [expr {$a0 + $angle}]
}

# - : rotate clockwise by an angle
proc RotateRight {} {
    global angle a0
    set a0 [expr {$a0 - $angle}]
}

# f : move forward a step without drawing a line
proc MoveForward {} {
    global x0 y0 step a0
    set a [expr {.01745329 * $a0}]
    set x1 [expr {$x0 + $step * cos($a)}]
    set y1 [expr {$y0 - $step * sin($a)}]
    set x0 $x1
    set y0 $y1
}

# [ : push data into stack
proc PushData {} {
    global x0 y0 step angle a0
    Push $x0
    Push $y0
    Push $step
    Push $a0
    Push $angle
}

# ] : pop data outside stack
proc PopData {} {
    global x0 y0 step angle a0
    set angle [Pop]
    set a0    [Pop]
    set step  [Pop]
    set y0    [Pop]
    set x0    [Pop]
}

# -------------------------------------------------
# Perform iteration over the rules
# Parse the result
proc Production {w iterations axiom} {
    global grammar trules lcoord
    global x0 y0 a0 name
    
    $w.c delete all
 
    set x $x0
    set y $y0
    set a $a0
    set rules {}
    set lcoord {}
 
    for {set i 1} {$i <= 3} {incr i} {
        lappend rules $trules(v,$i) $trules(p,$i)}
 
    for {set i 0} {$i < $iterations} {incr i} {
        foreach {v p} $rules { regsub -all $v $axiom $p axiom }
    }
    for {set i 0} {$i < [string length $axiom]} {incr i} {
        eval $grammar([string index $axiom $i])
    }
 
    Draw $lcoord
    set x0 $x
    set y0 $y
    set a0 $a
}

# -------------------------------------------------
# Init parameters
proc Init {} {
    global x0 y0 step angle a0 name lcoord W H w
    global iterations lsys stack top
    global axiom rules trules

    catch {unset stack}
    set lcoord {}

    set W 512
    set H 512
   
    for {set i 1} {$i <= 3} {incr i} {
        set trules(v,$i) {}
        set trules(p,$i) {}
    }
    set name {}
    set angle 60
    set step 400
    set x0 0
    set y0 -235
    set a0 60
   
    set iterations 3
    set axiom F++F++F
    set rules {F {F-F++F-F}}
    set i 0
   
    foreach {v p} $rules {
        incr i
        set trules(v,$i) $v
        set trules(p,$i) $p
    }
   
    set top 0
    array set stack {}
    set stack($top) 0
}

# -------------------------------------------------
# Define optimal view and draw lsystem
proc Draw { l } {
    global W H

    set lx {}
    set ly {}
   
    foreach {x0 y0 x1 y1} $l {
        lappend lx $x0 $x1
        lappend ly $y0 $y1
    }
    set lx [lsort -real $lx]
    set ly [lsort -real $ly]
    set maxx [lindex $lx end]
    set minx [lindex $lx 0]
    set maxy [lindex $ly end]
    set miny [lindex $ly 0]
   
    set Dx [expr {$maxx - $minx}]
    set Dy [expr {$maxy - $miny}]
   
    set w [expr {$W / $Dx}]
    set h [expr {$H / $Dy}]
   
    foreach {x0 y0 x1 y1} $l {
        set xx0 [expr {$w * ($x0 - $minx)}]
        set yy0 [expr {$h * ($y0 - $miny)}]
        set xx1 [expr {$w * ($x1 - $minx)}]
        set yy1 [expr {$h * ($y1 - $miny)}]
        .lsys.c create line $xx0 $yy0 $xx1 $yy1 -width 1 -fill darkgreen
    }
}

# -------------------------------------------------
# Examples
proc ReadData {w s} {
    global x0 y0 step angle a0 name
    global iterations axiom rules trules

    $w.c delete all
    Init
    set name $s
   
    switch -exact $s {
   
        {Koch snowflake} {
            lassign {3 400 60 60 0 -235} iterations step angle a0 x0 y0 
            set axiom F++F++F
            set rules {F {F-F++F-F}}
        }
       
        {Koch quadratic} {
            lassign {3 3 90 0 0 0} iterations step angle a0 x0 y0 
            set axiom F-F-F-F
            set rules {F {FF-F-F-F-F-F+F}}
        }
       
        {Koch star} {
            lassign {3 1 60 0 0 0} iterations step angle a0 x0 y0 
            set axiom F++F++F
            set rules {F {F+F--F+F}}
        }
       
        {Koch curve 3} {
            lassign {3 1 90 0 0 0} iterations step angle a0 x0 y0 
            set axiom F-F-F-F
            set rules {F {FF-F+F-F-FF}}
        }
       
        Shrub {
            lassign {6 230 90 0 0 -230} iterations step angle a0 x0 y0 
            set axiom X
            set rules {F {FF} \
                X {F[+X]F[+X]-X}}
        }
       
        Bush {
            lassign {3 1 16 0 0 0} iterations step angle a0 x0 y0 
            set axiom ++++F
            set rules {F {FF-[-F+F+F]+[+F-F-F]}}
        }
       
        Island {
            lassign {2 1 90 90 0 0} iterations step angle a0 x0 y0 
            set axiom F+F+F+F
            set rules {F {F+f-FF+F+FF+Ff+FF-f+FF-F-FF-Ff-FFF} \
                       f {ffffff}}
        }
        
        Arrowhead {
            lassign {4 1 60 0 0 0} iterations step angle a0 x0 y0 
            set axiom YF
            set rules {X {YF+XF+Y} \
                       Y {XF-YF-X}}
        }
       
        {Sierpinski gasket} {
            lassign {5 1 60 0 0 0} iterations step angle a0 x0 y0 
            set axiom X
            set rules {
                F {FF}
                X {--FXF++FXF++FXF--}
            }
        }
       
        {Sierpinski gasket 1} {
            lassign {5 1 60 0 0 0} iterations step angle a0 x0 y0 
            set axiom F--F--F
            set rules {
                F {F--F--F--ff}
                f {ff}
            }
        }
       
        {Sierpinski square} {
            lassign {4 1 90 0 0 0} iterations step angle a0 x0 y0 
            set axiom F-F-F-F
            set rules {
                F {FF[-F-F-F]F}
            }
        }
       
        Pentigree {
            lassign {3 1 72 0 0 0} iterations step angle a0 x0 y0 
            set axiom F-F-F-F-F
            set rules {
                F {F-F++F+F-F-F}
            }
        }
       
        Hiwaymed {
            lassign {3 1 8 0 0 0} iterations step angle a0 x0 y0 
            set axiom -X
            set rules {
                X {X+F+Y}
               Y {X-F-Y}
            }
        }
       
        Hilbert {
            lassign {4 1 90 0 0 0} iterations step angle a0 x0 y0 
            set axiom X
            set rules {
                X {+YF-XFX-FY+}
                Y {-XF+YFY+FX-}
            }
        }
       
        Segment32 {
            lassign {2 1 90 0 0 0} iterations step angle a0 x0 y0 
            set axiom F
            set rules {
                F {-F+F-F-F+F+FF-F+F+FF+F-F-FF+FF-FF+F+F-FF-F-F+FF-F-F+F+F-F+}
            }
        }
       
        {Square curve} {
            lassign {5 1 90 0 0 0} iterations step angle a0 x0 y0 
            set axiom X
            set rules {
                X {XF-F+F-XF+F+XF-F+F-X}
            }
        }
       
        {Heighway dragon} {
            lassign {8 1 90 45 0 0} iterations step angle a0 x0 y0 
            set axiom FX
            set rules {
                X {X+YF}
                Y {FX-Y}
            }
        }
       
        {Levy C curve} {
            lassign {11 1 45 0 0 0} iterations step angle a0 x0 y0 
            set axiom F
            set rules {
                F {+F--F+}
            }
        }
       
        {Plant 1} {
            lassign {5 1 25 90 0 0} iterations step angle a0 x0 y0 
            set axiom X
            set rules {
                X {F-[[X]+X]+F[+FX]-X}
                F {FF}
            }
        }
       
        {Plant 2} {
            lassign {6 1 20 70 256 0} iterations step angle a0 x0 y0 
            set axiom X
            set rules {
                X {F[+X]F[-X]+X}
                F {FF}
            }
        }
            
        Carpet {
            lassign {4 1 90 0 256 512} iterations step angle a0 x0 y0 
            set axiom F-F-F-F
            set rules {
                F {F[F]-F+F[--F]+F-F}
            }
        }
       
        {Penrose snowflake} {
            lassign {3 1 18 0 0 0} iterations step angle a0 x0 y0 
            set axiom F----F----F----F----F
            set rules {
                F {F----F----F----------F++F----F}
            }
        }
       
    }
    $w.c create text 10 10 -anchor w -text $name
    set i 0
    foreach {v p} $rules {
        incr i
        set trules(v,$i) $v
        set trules(p,$i) $p
    }
}

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

proc Main { } {
    global x0 y0 step angle a0 W H w
    global iterations axiom lsys rules trules

    set w .lsys
    catch {destroy $w}
    toplevel $w
    wm withdraw .
    wm title $w {Lsystem 2D} 
    wm geometry $w +100+10
   
    pack [canvas $w.c -width $W -height $H -bg white]
   
    set f1 [frame $w.f1 -relief ridge -borderwidth 2]
    pack $f1 -fill x
    label $f1.l1 -text X0
    entry $f1.e1 -width 7 -textvariable x0
    label $f1.l2 -text { Y0}
    entry $f1.e2 -width 7 -textvariable y0
    label $f1.l3 -text { Step}
    entry $f1.e3 -width 4 -textvariable step
    label $f1.l4 -text { Angle}
    entry $f1.e4 -width 4 -textvariable angle
    label $f1.l5 -text { A0}
    entry $f1.e5 -width 4 -textvariable a0
    label $f1.l6 -text { iterations}
    entry $f1.e6 -width 4 -textvariable iterations
    eval pack [winfo children $f1] -side left
   
    set f2 [frame $w.f2 -relief ridge -borderwidth 2]
    pack $f2 -fill x
    set f21 [frame $f2.f21 -borderwidth 2]
    label $f21.l1 -text Axiom
    entry $f21.e1 -width 14 -textvariable axiom
    label $f21.l2 -text { }
    set l {
        {Koch snowflake}
        {Koch quadratic}
        {Koch star}
        {Koch curve 3}
        Shrub
        Bush
        Island
        Arrowhead
        {Sierpinski gasket}
        {Sierpinski gasket 1}
        {Sierpinski square}
        Hilbert
        Pentigree
        Segment32
        {Heighway dragon}
        {Levy C curve}
        {Square curve}
        {Plant 1}
        {Plant 2}
        Carpet
        {Penrose snowflake}
    }
    ttk::combobox $f21.sp -values $l -textvariable lsys
    $f21.sp set {Koch snowflake}
    bind $f21.sp <<ComboboxSelected>> {ReadData $w $lsys}

    grid $f21.l1 -column 0 -row 1
    grid $f21.e1 -column 1 -row 1
    grid $f21.l2 -column 0 -row 2
    grid $f21.sp -columnspan 2 -row 3
    set f22 [frame $f2.f22 -borderwidth 2]
    label $f22.l1 -text rules_1
    entry $f22.ev1 -width 6  -textvariable trules(v,1)
    entry $f22.ep1 -width 44 -textvariable trules(p,1)
    label $f22.l2  -text rules_2
    entry $f22.ev2 -width 6  -textvariable trules(v,2)
    entry $f22.ep2 -width 44 -textvariable trules(p,2)
    label $f22.l3 -text rules_3
    entry $f22.ev3 -width 6  -textvariable trules(v,3)
    entry $f22.ep3 -width 44 -textvariable trules(p,3)
    grid $f22.l1  -column 0 -row 1
    grid $f22.ev1 -column 1 -row 1
    grid $f22.ep1 -column 2 -row 1
    grid $f22.l2  -column 0 -row 2
    grid $f22.ev2 -column 1 -row 2
    grid $f22.ep2 -column 2 -row 2
    grid $f22.l3  -column 0 -row 3
    grid $f22.ev3 -column 1 -row 3
    grid $f22.ep3 -column 2 -row 3
    eval pack [winfo children $f2] -side left

    set f4 [frame $w.f4 -relief sunken -borderwidth 2]
    pack $f4 -fill x
    button $f4.bu -text Run -width 6 -bg blue -fg white \
        -command {Production $w $iterations $axiom}
    button $f4.bc -text Clear -width 6 -bg blue -fg white \
        -command [list $w.c delete all]
    button $f4.ba -text About -width 6 -bg blue -fg white -command About
    button $f4.bq -text Quit -width 5 -bg blue -fg white -command exit
    eval pack [winfo children $f4] -side left
}

DefineGrammar
Init
Main