Tcl Rules!

[Sun Home | Tcl Plugin | Demos]

Below is a ruler for measuring things in your page. You can add tab-stops by dragging the little triangles. This ruler tclet is 130 lines of code. It demonstrates how Tcl displays in true dimensions. The ruler stops are really exactly quarters of a centimeter, irrespective of what display the tclet is being displayed on.

Source

Here's the source for the ruler above:

set font -*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*
set w \
    [frame .ruler -width $embed_args(width) -height $embed_args(height)]
pack $w
set c $w.c
label $w.msg -font $font -wraplength 12c -justify left \
	-text "This canvas widget shows a mock-up of a ruler.\
You can create tab stops by dragging them out of the well to the right of \
the ruler.  You can also drag existing tab stops.  If you drag a tab stop \
far enough up or down so that it disappears, it will be deleted when you \
release the mouse button."
pack $w.msg -side top
canvas $c -width 12c -height 2.5c
pack $w.c -side top -fill x
set demo_rulerInfo(grid) .25c
set demo_rulerInfo(left) [winfo fpixels $c 1c]
set demo_rulerInfo(right) [winfo fpixels $c 13c]
set demo_rulerInfo(top) [winfo fpixels $c 1c]
set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c]
set demo_rulerInfo(size) [winfo fpixels $c .2c]
set demo_rulerInfo(normalStyle) "-fill black"
if {[winfo depth $c] > 1} {
    set demo_rulerInfo(activeStyle) "-fill red -stipple {}"
    set demo_rulerInfo(deleteStyle) [list -fill red]
} else {
    set demo_rulerInfo(activeStyle) "-fill black -stipple {}"
    set demo_rulerInfo(deleteStyle) [list -fill black]
}
$c create line 1c 0.5c 1c 1c 11c 1c 11c 0.5c -width 1
for {set i 0} {$i < 10} {incr i} {
    set x [expr $i+1]
    $c create line ${x}c 1c ${x}c 0.6c -width 1
    $c create line $x.25c 1c $x.25c 0.8c -width 1
    $c create line $x.5c 1c $x.5c 0.7c -width 1
    $c create line $x.75c 1c $x.75c 0.8c -width 1
    $c create text $x.15c .75c -text $i -anchor sw
}
$c addtag well withtag [$c create rect 11.2c 1c 11.8c 0.5c \
	-outline black -fill [lindex [$c config -bg] 4]]
$c addtag well withtag [rulerMkTab $c [winfo pixels $c 11.5c] \
	[winfo pixels $c .65c]]
$c bind well <1> "rulerNewTab $c %x %y"
$c bind tab <1> "rulerSelectTab $c %x %y"
bind $c <B1-Motion> "rulerMoveTab $c %x %y"
bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
proc rulerMkTab {c x y} {
    upvar #0 demo_rulerInfo v
    $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \
	    [expr $x-$v(size)] [expr $y+$v(size)]
}
proc rulerNewTab {c x y} {
    upvar #0 demo_rulerInfo v
    $c addtag active withtag [rulerMkTab $c $x $y]
    $c addtag tab withtag active
    set v(x) $x
    set v(y) $y
    rulerMoveTab $c $x $y
}
proc rulerSelectTab {c x y} {
    upvar #0 demo_rulerInfo v
    set v(x) [$c canvasx $x $v(grid)]
    set v(y) [expr $v(top)+2]
    $c addtag active withtag current
    eval "$c itemconf active $v(activeStyle)"
    $c raise active
}
proc rulerMoveTab {c x y} {
    upvar #0 demo_rulerInfo v
    if {[$c find withtag active] == ""} {
	return
    }
    set cx [$c canvasx $x $v(grid)]
    set cy [$c canvasy $y]
    if {$cx < $v(left)} {
	set cx $v(left)
    }
    if {$cx > $v(right)} {
	set cx $v(right)
    }
    if {($cy >= $v(top)) && ($cy <= $v(bottom))} {
	set cy [expr $v(top)+2]
	eval "$c itemconf active $v(activeStyle)"
    } else {
	set cy [expr $cy-$v(size)-2]
	eval "$c itemconf active $v(deleteStyle)"
    }
    $c move active [expr $cx-$v(x)] [expr $cy-$v(y)]
    set v(x) $cx
    set v(y) $cy
}
proc rulerReleaseTab c {
    upvar #0 demo_rulerInfo v
    if {[$c find withtag active] == {}} {
	return
    }
    if {$v(y) != [expr $v(top)+2]} {
	$c delete active
    } else {
	eval "$c itemconf active $v(normalStyle)"
	$c dtag active
    }
}