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
}Wow, that looks great !
]