summaryrefslogtreecommitdiffstats
path: root/library/demos/ruler.tcl
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-04-01 09:51:44 (GMT)
committerrjohnson <rjohnson>1998-04-01 09:51:44 (GMT)
commit066ea7fd88d49cb456f74da71dbe875e4fc0aabb (patch)
tree8fb30cb152c4dc191be47fa043d2e6f5ea38c7ba /library/demos/ruler.tcl
parent13242623d2ff3ea02ab6a62bfb48a7dbb5c27e22 (diff)
downloadtk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.zip
tk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.tar.gz
tk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.tar.bz2
Initial revision
Diffstat (limited to 'library/demos/ruler.tcl')
-rw-r--r--library/demos/ruler.tcl173
1 files changed, 173 insertions, 0 deletions
diff --git a/library/demos/ruler.tcl b/library/demos/ruler.tcl
new file mode 100644
index 0000000..3c77c72
--- /dev/null
+++ b/library/demos/ruler.tcl
@@ -0,0 +1,173 @@
+# ruler.tcl --
+#
+# This demonstration script creates a canvas widget that displays a ruler
+# with tab stops that can be set, moved, and deleted.
+#
+# SCCS: @(#) ruler.tcl 1.9 97/03/02 16:17:33
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+# rulerMkTab --
+# This procedure creates a new triangular polygon in a canvas to
+# represent a tab stop.
+#
+# Arguments:
+# c - The canvas window.
+# x, y - Coordinates at which to create the tab stop.
+
+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)]
+}
+
+set w .ruler
+global tk_library
+catch {destroy $w}
+toplevel $w
+wm title $w "Ruler Demonstration"
+wm iconname $w "ruler"
+positionWindow $w
+set c $w.c
+
+label $w.msg -font $font -wraplength 5i -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 turns dim, it will be deleted when you release the mouse button."
+pack $w.msg -side top
+
+frame $w.buttons
+pack $w.buttons -side bottom -fill x -pady 2m
+button $w.buttons.dismiss -text Dismiss -command "destroy $w"
+button $w.buttons.code -text "See Code" -command "showCode $w"
+pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
+
+canvas $c -width 14.8c -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 \
+ -stipple @[file join $tk_library demos images gray25.bmp]]
+} else {
+ set demo_rulerInfo(activeStyle) "-fill black -stipple {}"
+ set demo_rulerInfo(deleteStyle) [list -fill black \
+ -stipple @[file join $tk_library demos images gray25.bmp]]
+}
+
+$c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1
+for {set i 0} {$i < 12} {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 13.2c 1c 13.8c 0.5c \
+ -outline black -fill [lindex [$c config -bg] 4]]
+$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.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"
+
+# rulerNewTab --
+# Does all the work of creating a tab stop, including creating the
+# triangle object and adding tags to it to give it tab behavior.
+#
+# Arguments:
+# c - The canvas window.
+# x, y - The coordinates of the tab stop.
+
+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
+}
+
+# rulerSelectTab --
+# This procedure is invoked when mouse button 1 is pressed over
+# a tab. It remembers information about the tab so that it can
+# be dragged interactively.
+#
+# Arguments:
+# c - The canvas widget.
+# x, y - The coordinates of the mouse (identifies the point by
+# which the tab was picked up for dragging).
+
+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
+}
+
+# rulerMoveTab --
+# This procedure is invoked during mouse motion events to drag a tab.
+# It adjusts the position of the tab, and changes its appearance if
+# it is about to be dragged out of the ruler.
+#
+# Arguments:
+# c - The canvas widget.
+# x, y - The coordinates of the mouse.
+
+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
+}
+
+# rulerReleaseTab --
+# This procedure is invoked during button release events that end
+# a tab drag operation. It deselects the tab and deletes the tab if
+# it was dragged out of the ruler.
+#
+# Arguments:
+# c - The canvas widget.
+# x, y - The coordinates of the mouse.
+
+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
+ }
+}