Version 3 of L-system 2D

Updated 2012-05-27 20:18:26 by RLE

GS (20100606) L-system is a mathematical formalism proposed by the hungarian biologist Aristid Lindenmayer in 1968 to describe the growth patterns of plants [L1 ]. It is used in computer graphics for realistic modelling of plants and to draw fractals.

http://gersoo.free.fr/wiki/f1808/lsystem2d.jpg

L-systems is a syntactic sets of rules and symbols (a language) that models growth processes. It uses a turtle graphics as the Logo programming language does it. A complex structure is defined recursively by a text susbtitution scheme with a geometric interpretation.

Turtle interpretation:

 F : Move forward a step and draw a line
 f : Move forward a step without drawing a line
 + : Rotate counterclockwise by an angle
 - : Rotate clockwise by an angle
 [ : Push data into stack
 ] : Pop data outside stack

-

 # 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 "$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

See also: