# 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 {} {
    variable 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 {
    variables stack top
    set stack($top) $e
    incr top
}

proc Pop {} {
    variables 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 {} {
    variables 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 {} {
    variables angle a0
    set a0 [expr {$a0 + $angle}]
}

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

# f : move forward a step without drawing a line
proc MoveForward {} {
    variables 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 {} {
    variables x0 y0 step angle a0
    Push $x0
    Push $y0
    Push $step
    Push $a0
    Push $angle
}

# ] : pop data outside stack
proc PopData {} {
    variables 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} {
    variables grammar trules lcoord
    variables 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 {
            set axiom [string map [list $v $p] $axiom[set 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 {} {
    variables x0 y0 step angle a0 name lcoord W H w
    variables iterations lsys stack top
    variables 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 } {
    variables 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} {
    variable designs
    variables x0 y0 step angle a0 name
    variables iterations axiom rules trules

    $w.c delete all
    Init
    set name $s

    lassign [dict get $designs $s] vars axiom rules
    lassign $vars[set vars {}] iterations step angle a0 x0 y0

    $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 {} {
    variable designs
    variables x0 y0 step angle a0 W H w
    variables 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 [dict keys $designs]
    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
}

proc variables args {
    set script {}
    foreach arg $args {
        append script [list variable $arg]\n
    }
    uplevel $script
}

variable designs {
    {Koch snowflake} {
        {3 400 60 60 0 -235}
        F++F++F
        {F {F-F++F-F}}
    }

    {Koch quadratic} {
        {3 3 90 0 0 0}
        F-F-F-F
        {F {FF-F-F-F-F-F+F}}
    }

    {Koch star} {
        {3 1 60 0 0 0}
        F++F++F
        {F {F+F--F+F}}
    }

    {Koch curve 3} {
        {3 1 90 0 0 0}
        F-F-F-F
        {F {FF-F+F-F-FF}}
    }

    Shrub {
        {6 230 90 0 0 -230}
        X
        {
            F {FF}
            X {F[+X]F[+X]-X}
        }
    }

    Bush {
        {3 1 16 0 0 0}
        ++++F
        {F {FF-[-F+F+F]+[+F-F-F]}}
    }

    Island {
        {2 1 90 90 0 0}
        F+F+F+F
        {
           F {F+f-FF+F+FF+Ff+FF-f+FF-F-FF-Ff-FFF}
           f {ffffff}
        }
    }

    Arrowhead {
        {4 1 60 0 0 0}
        YF
        {
            X {YF+XF+Y}
            Y {XF-YF-X}
        }
    }

    {Sierpinski gasket} {
        {5 1 60 0 0 0}
        X
        {
            F {FF}
            X {--FXF++FXF++FXF--}
        }
    }

    {Sierpinski gasket 1} {
        {5 1 60 0 0 0}
        F--F--F
        {
            F {F--F--F--ff}
            f {ff}
        }
    }

    {Sierpinski square} {
        {4 1 90 0 0 0}
        F-F-F-F
        {
            F {FF[-F-F-F]F}
        }
    }

    Pentigree {
        {3 1 72 0 0 0}
        F-F-F-F-F
        {
            F {F-F++F+F-F-F}
        }
    }

    Hiwaymed {
        {3 1 8 0 0 0}
        -X
        {
            X {X+F+Y}
           Y {X-F-Y}
        }
    }

    Hilbert {
        {4 1 90 0 0 0}
        X
        {
            X {+YF-XFX-FY+}
            Y {-XF+YFY+FX-}
        }
    }

    Segment32 {
        {2 1 90 0 0 0}
        F
        {
            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} {
        {5 1 90 0 0 0}
        X
        {
            X {XF-F+F-XF+F+XF-F+F-X}
        }
    }

    {Heighway dragon} {
        {8 1 90 45 0 0}
        FX
        {
            X {X+YF}
            Y {FX-Y}
        }
    }

    {Levy C curve} {
        {11 1 45 0 0 0}
        F
        {
            F {+F--F+}
        }
    }

    {Plant 1} {
        {5 1 25 90 0 0}
        X
        {
            X {F-[[X]+X]+F[+FX]-X}
            F {FF}
        }
    }

    {Plant 2} {
        {6 1 20 70 256 0}
        X
        {
            X {F[+X]F[-X]+X}
            F {FF}
        }
    }

    Carpet {
        {4 1 90 0 256 512}
        F-F-F-F
        {
            F {F[F]-F+F[--F]+F-F}
        }
    }

    {Penrose snowflake} {
        {3 1 18 0 0 0}
        F----F----F----F----F
        {
            F {F----F----F----------F++F----F}
        }
    }

}

DefineGrammar
Init
Main