Updated 2012-06-20 09:28:10 by RLE

Another weekend fun project by Richard Suchenwirth 2000-12 -- I dug out my old LOGO book from 1986 (DR Logo on CP/M) and finally made an old wish come true: to reimplement their turtle graphics - in Tcl of course.

LOGO (Seymour Papert, MIT 1967 [1]) is still somehow popular as an educational programming language. My impression was "a stripped-down Lisp with much less parens" - that's one reason why I liked it then. In contrast to most other languages (except Forth), statements are not strictly separated but can be strung together on one line, e.g. to draw a circle (the most intuitive way I've ever seen):
 repeat 360 [rt 1 fd 1]

where repeat, rt and fd are commands that take up as many arguments to their right as they need. This feature could easily be approximated in Tcl: each exported proc takes an additional args and evals that in the end. This functionality is wrapped into the to command which differs in syntax from Logo's but likewise gives an impression how simple The turtle commands are mostly two-letter abbreviations:
 bk   - move back (n pixels)
 cs   - clear screen
 fd   - move forward (n pixels, drawing a line if pen is down)
 home - move turtle to (0,0)
 ht   - hide turtle (a triangular cursor indicating drawing direction)
 lt   - left turn (in degrees)
 pd   - pen down
 pu   - pen up
 rt   - right turn (in degrees)
 st   - show turtle

I first tried to draw the turtle as a triangle myself, but soon found that Tcl's arrowhead on a line item does that faster and easier. The color and palette treatment was simplified - just use setpc/setbg with a color name for foreground/background. (In old Logo, you could use up to 4 palettes - one color each - with RGB values between 0 and 2...)

The story continues at Turtleshell...
 namespace eval Turtle {
        variable data
        proc Init canvas {
                variable data
                array set data {x 0.0 y 0.0 h 0.0 pen down fg blue show 1}
                set data(c) $canvas
                uplevel 1 namespace import -force ::Turtle::*
        proc Show? {} {
                variable data
                update idletasks
                $data(c) delete withtag turtle
                if !$data(show) return
                set h1 [expr {atan(1.)*8*$data(h)/360.}]
                set x1 [expr {$data(x)+10*sin($h1)}]
                set y1 [expr {$data(y)-10*cos($h1)}]
                $data(c) create line $data(x) $data(y) $x1 $y1 -arrow last \
                        -arrowshape {10 10 3} -tag turtle -fill $data(fg)        
        proc to {name argl body} {
                set body "variable data; $body; Show?; eval \$args"
                proc $name [lappend argl args] $body
        namespace export -clear bk clean cs fd home ht lt pd pu rt \
                setbg seth setpc setpos setx sety st to
        to bk     n {fd -$n}
        to clean  {} {$data(c) delete all}
        to cs     {} {clean; home; pd}
        to fd     n {
                set h1 [expr {atan(1.)*8*$data(h)/360.}]
                set x1 [expr {$data(x)+$n*sin($h1)}]
                set y1 [expr {$data(y)-$n*cos($h1)}]
                if {$data(pen)=="down"} {
                   $data(c) create line $data(x) $data(y) $x1 $y1 -fill $data(fg)
                set data(x) $x1
                set data(y) $y1
        to home   {} {array set data {x 0.0 y 0.0 h 0.0}}
        to ht     {} {set data(show) 0}
        to lt     d  {rt -$d}
        to pd     {} {set data(pen) down}
        to pu     {} {set data(pen) up}
        to rt     d  {set data(h) [expr {$data(h)+$d}]}
        to setbg  col {$data(c) config -bg $col}
        to setpc  col {set data(fg) $col}
        to setpos {X Y} {set data(x) $X; set data(y) $Y}
        to seth   val {set data(h) $val}
        to setx   val {set data(x) $val}
        to sety   val {set data(y) $val}
        to st     {} {set data(show) 1}
        to rtree s {
            if $s<5 return
            fd $s 
            lt 30 rtree [expr $s*([random 5]+5)/10]
            rt 60 rtree [expr $s*([random 5]+5)/10]
            lt 30 bk $s
     ##---------------- add working and nice-looking demo code here!
     variable demos {
             setpc yellow; repeat 90 {fd 100 bk 100 rt 4} 
             setpc blue; repeat 90 {fd 30 bk 30 rt 4}
         {setpc yellow web 30 setpc orange web 50 setpc red web 75}
         {repeat 360 {
             setpc [random:select [colors]] fd 100 bk 100 lt 1}
             seth [random 360]; set n [expr [random 100]+100]; 
             repeat $n {fd $n; rt 90; incr n -1}
         {pu bk 100 pd rtree [expr [random 50]+25]}
         {set n 100; repeat 100 {fd [incr n -2] rt 89}}
 } ;#-------------------------- end namespace Turtle
 proc colors {} {
     list red orange yellow green1 green3 blue purple black white
 proc random n {expr {round($n*rand())}}
 proc random:select {list} {
     lindex $list [expr int(rand()*[llength $list])]
 proc repeat {n body} {while {$n} {incr n -1; uplevel $body}}

Note how Tcl's and Logo's simplicities merge in the following demo code (not needed for Turtleshell), enhanced by a random tree ...
 proc turtletest {} {
     pack [canvas .c] -fill both -expand 1
        Turtle::Init .c
        repeat 4 {rt 90 fd 50}
        seth 90 setx 100
        foreach i {red green black blue orange} {
                setpc $i pu fd 10 pd repeat 180 {fd 1 rt 2}
        pu seth 180 fd 160 pd
        to square s {repeat 4 {fd $s rt 90}}
        to web s {repeat 36 {square $s rt 10}}
        to facet {x y z} {web $x web $y web $z}
        ht setbg black facet 30 40 70
        setpos 300 250 seth 0 setpc red rtree 60

For a more elaborate demo (in fact, a usable interactive program) see Turtleshell.

RM: Here is a different implementation of repeat
 to repeat {n body} {while {$n} {uplevel 1 $body; incr n -1}}

It allows LOGO code to be placed behind a repeat statement.
 repeat 4 {fd 100 repeat 6 {fd 50 rt 60} bk 100 rt 90}

RS: Good suggestion - the freedom introduced by the to commands is of course not backpropagated to all Tcl commands. My idea was, since a numbered repeat is useful in other situations as well, to keep it independent from turtle updates etc. A compromise would be
 proc repeat {n body args} {
        while {$n} {incr n -1; uplevel 1 $body}
        uplevel 1 $args


This version of to allows custom commands that can be called without qualifying them with Turtle::
 namespace eval Turtle {
    proc to {name argl body} {
        set body "variable data; $body; Show?; eval \$args"
        proc $name [lappend argl args] $body
        namespace export $name
        catch {uplevel 1 namespace import [namespace current]::$name}
    namespace export -clear to

RS: Great, thank you! I've also got something new, Logo's label command:
     to label  s {
         $data(c) create text $data(x) $data(y) \
                 -text $s -anchor nw -fill $data(fg)

Only in Logo the writing direction is determined by turtle heading - I don't see a way to do that on a Tcl canvas at present...

See also Geometrical constructions