[Arjen Markus] (28 january 2005) Besides [drawing geometrical objects], drawing simple diagrams can be an exercise in positioning and repositioning. [Volker Hetzer] drew my attention to "PIC", a program by Brian Kernighan that allows you to draw diagrams in a simple language, entirely but not quite unlike Tcl :).

So, I tried to reinvent that particular wheel with the script below. Note that it is far from completed, and I claim no actual useability for the current version. Still, if you look at the example, you can almost see something useful appear.

----
 # draw_diagram.tcl
 #    A toy derived from "PIC" by B. Kernighan to draw diagrams
 #

 package require Tk

 namespace eval ::Diagrams {
     variable state
     variable anchors

     namespace export box arrow currentpos getpos direction \
                      drawin saveps

     array set state {
         attach         {0 0}
         canvas         ""
         colour         "black"
         default_dir    "east"
         dir            "init"
         font           "Helvetica 12"
         justify        center
         default_width  "fitting"
         default_height 20
         xdir           1
         ydir           0
         xshift         0
         yshift         0
         xcurr          10
         ycurr          10
         xgap           10
         ygap           10
         scale          {1.0}
         xprev          10
         yprev          10
         lastitem       {}
         usegap         1
     }
     set anchors(X) {south xns north xns west x1 east x2
                     S     xns N     xns W    x1 E    x2
                     southeast x2 northeast x2
                     SE        x2 NE        x2
                     southwest x1 northwest x1
                     SW        x1 NW        x1
                     centre xns   center xns C xns}
     set anchors(Y) {south y2  north y1 west yew east yew
                     S     y2  N     y1 W    yew E    yew
                     southeast y2 northeast y1
                     SE        y2 NE        y1
                     southwest y2 northwest y1
                     SW        y2 NW        y1
                     centre yew   center yew C yew}
 }

 # drawin --
 #    Set the canvas widget in which to draw
 # Arguments:
 #    widget    Name of the canvas widget to use
 # Result:
 #    None
 #
 proc ::Diagrams::drawin {widget} {
     variable state
     set state(canvas) $widget
 }

 # saveps --
 #    Save the drawing in a PostScript file
 # Arguments:
 #    filename   Name of the file to write
 # Result:
 #    None
 #
 proc ::Diagrams::saveps {filename} {
     variable state
     $state(canvas) postscript -out $filename
 }

 # direction --
 #    Set the direction for moving the current position
 # Arguments:
 #    newdir    Direction (down, left, up, right)
 # Result:
 #    None
 #
 proc ::Diagrams::direction {newdir} {
     variable state

     switch -- $newdir {
     "south" -
     "down"  { set dir    "south"
               set xdir   0
               set ydir   1
               set xshift 0.5
               set yshift -1
             }
     "north" -
     "up"    { set dir   "north"
               set xdir  0
               set ydir -1
             }
     "west"  -
     "left"  { set dir   "west"
               set xdir -1
               set ydir  0
             }
     "east"  -
     "right" { set dir   "east"
               set xdir  1
               set ydir  0
             }
     "SE"        -
     "southeast" { set dir   "southeast"
                   set xdir  1
                   set ydir  1
                 }
     "SW"        -
     "southwest" { set dir   "southwest"
                   set xdir -1
                   set ydir  1
                 }
     "NW"        -
     "northwest" { set dir   "northwest"
                   set xdir -1
                   set ydir -1
                 }
     "NE"        -
     "northeast" { set dir   "northeast"
                   set xdir  1
                   set ydir -1
                 }
     default { # Nothing
               return
             }
     }
     set state(dir)  $dir
     set state(xdir) $xdir
     set state(ydir) $ydir
     if { $state(lastitem) != {} } {
         currentpos [getpos $dir $state(lastitem)]
     }
 }

 # currentpos
 #    Set the current position explicitly
 # Arguments:
 #    pos       Position "object" (optional)
 # Result:
 #    Current position as an "object"
 # Side effect:
 #    Current position set
 #
 proc ::Diagrams::currentpos { {pos {}} } {
     variable state

     if { [lindex $pos 0] == "POSITION" } {
         set state(xprev) $state(xcurr)
         set state(yprev) $state(ycurr)
         set state(xcurr) [lindex $pos 1]
         set state(ycurr) [lindex $pos 2]
     }

     return [list POSITION $state(xcurr) $state(ycurr)]
 }

 # CoordName
 #    Return the name of the variable for a particular "anchor" point
 # Arguments:
 #    coord     Which coordinate to return
 #    anchor    Which anchor point
 # Result:
 #    Name of the variable
 #
 proc ::Diagrams::CoordName {coord anchor} {
     variable anchors

     if { $anchor == "init" } {
         direction "east"
         set anchor "east"
     }

     set idx [lsearch $anchors($coord) $anchor]
     if { $idx >= 0 } {
         return [lindex $anchors($coord) [incr idx]]
     } else {
         return -code error "Unknown anchor: $anchor"
     }
 }

 # getpos
 #    Get the position of a particular "anchor" point of an object
 # Arguments:
 #    anchor    Which point to return
 #    obj       Drawable "object"
 # Result:
 #    Position of the requested point
 #
 proc ::Diagrams::getpos {anchor obj} {
     variable state

     if { [lindex $obj 0] == "BOX" } {
         foreach {x1 y1 x2 y2} [lrange $obj 1 end] {break}
         set yew [expr {($y1+$y2)/2}]
         set xns [expr {($x1+$x2)/2}]
     }
     if { [lindex $obj 0] == "ARROW" } {
         foreach {x1 y1 x2 y2} [lrange $obj 1 end] {break}
         set yew [expr {($y1+$y2)/2}]
         set xns [expr {($x1+$x2)/2}]
     }

     set xp [set [CoordName X $anchor]]
     set yp [set [CoordName Y $anchor]]

     return [list POSITION $xp $yp]
 }

 # position
 #    Create a position "object"
 # Arguments:
 #    xcoord    X-coordinate
 #    ycoord    Y-coordinate
 # Result:
 #    List representing the object
 #
 proc ::Diagrams::position {xcoord ycoord} {

     return [list "POSITION" $xcoord $ycoord]
 }

 # box --
 #    Draw a box from the current position
 # Arguments:
 #    text      Text to be fitted in the box
 #    width     (Optional) width in pixels or "fitting"
 #    height    (Optional) height in pixels
 # Result:
 #    ID of the box
 # Side effect:
 #    Box drawn with text inside, current position set
 #
 proc ::Diagrams::box {text {width {}} {height {}}} {
     variable state

     if { $width == {} } {
         set width $state(default_width)
     }

     if { $height == {} } {
         set height $state(default_height)
     }

     set item [$state(canvas) create text 0 0 -text $text \
                  -font    $state(font) \
                  -justify $state(justify)]

     if { $width == "fitting" } {
         foreach {x1 y1 x2 y2} [$state(canvas) bbox $item] {break}

         set width  [expr {$x2-$x1+10}]
         set height [expr {$y2-$y1+10}]
     }

     #
     # Compute the coordinates of the box:
     # xcurr and ycurr are the coordinates for the upper-left corner ...
     #
     set x1 [expr {$state(xcurr)+$state(xgap)*$state(xdir)*$state(usegap)}]
     set x2 [expr {$x1+$width}]
     set y1 [expr {$state(ycurr)+$state(ygap)*$state(ydir)*$state(usegap)}]
     set y2 [expr {$y1+$height}]

     set xt [expr {($x1+$x2)/2}]
     set yt [expr {($y1+$y2)/2}]

     $state(canvas) create rectangle $x1 $y1 $x2 $y2
     $state(canvas) move $item $xt $yt

     set item [list BOX $x1 $y1 $x2 $y2]

     puts [currentpos [getpos $state(dir) $item]]

     set state(lastitem) $item
     set state(usegap)   1
     return $item
 }

 # arrow --
 #    Draw an arrow from the current position to the next
 # Arguments:
 #    text      (Optional) text to written above the arrow
 #    length    (Optional) length in pixels
 # Result:
 #    ID of the arrow
 # Side effect:
 #    Arrow drawn
 #
 proc ::Diagrams::arrow { {text {}} {length {}}} {
     variable state

     if { $length != {} } {
         set factor  [expr {hypot($state(xdir),$state(ydir))}]
         set dxarrow [expr {$length*$state(xdir)/$factor}]
         set dyarrow [expr {$length*$state(ydir)/$factor}]
     } else {
         set dxarrow [expr {$state(xdir)*$state(xgap)}]
         set dyarrow [expr {$state(ydir)*$state(ygap)}]
     }

     set x1      $state(xcurr)
     set y1      $state(ycurr)
     set x2      [expr {$state(xcurr)+$dxarrow}]
     set y2      [expr {$state(ycurr)+$dyarrow}]

     set item [$state(canvas) create line $x1 $y1 $x2 $y2 \
                  -fill    $state(colour) \
                  -arrow   last]

     set xt [expr {5+($x1+$x2)/2}]
     set yt [expr {($y1+$y2)/2}]

     set item [$state(canvas) create text $xt $yt -text $text \
                  -font    $state(font) \
                  -justify $state(justify)]

     set item [list ARROW $x1 $y1 $x2 $y2]

     #
     # Ignore the direction of motion - we need the end point
     #
     currentpos [position $x2 $y2]
     puts "Arrow: $item"

     set state(lastitem) $item
     set state(usegap)   0
     return $item
 }

 #
 # A small demonstration ...
 #

 pack [canvas .c -width 500 -height 500 -bg white]

 namespace import ::Diagrams::*

 drawin .c

 box "There is\nstill a lot to\ndo!"
 arrow "" 30
 box "But it looks nice"
 direction south
 box "Or does it?"
 direction southwest
 arrow "" 100
 set B1 [box "Yes, it sure does!"]

 foreach {text dir} {A southwest B south C southeast} {
     direction $dir
     currentpos [getpos $dir $B1]
     arrow "" 100
     box $text
 }

----
[[
[Category Graphics]
| [Category Application]
]]