if 0 {Another weekend fun project by [Richard Suchenwirth] -- 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 [http://el.www.media.mit.edu/groups/logo-foundation/logo/index.html]) 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 programming can be - mostly those one-liners I love best ... 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...) } 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 cs 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 update 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 } turtletest 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 } ---- RM: 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... ---- [Arts and crafts of Tcl-Tk programming]