Initial bulk commit for "Git on MSys"
[msysgit/historical-msysgit.git] / mingw / lib / tk8.4 / demos / ruler.tcl
blob86f18dcee687d5ac3e68a2504045499446cdb390
1 # ruler.tcl --
3 # This demonstration script creates a canvas widget that displays a ruler
4 # with tab stops that can be set, moved, and deleted.
6 # RCS: @(#) $Id: ruler.tcl,v 1.3 2001/06/14 10:56:58 dkf Exp $
8 if {![info exists widgetDemo]} {
9 error "This script should be run from the \"widget\" demo."
12 # rulerMkTab --
13 # This procedure creates a new triangular polygon in a canvas to
14 # represent a tab stop.
16 # Arguments:
17 # c - The canvas window.
18 # x, y - Coordinates at which to create the tab stop.
20 proc rulerMkTab {c x y} {
21 upvar #0 demo_rulerInfo v
22 $c create polygon $x $y [expr {$x+$v(size)}] [expr {$y+$v(size)}] \
23 [expr {$x-$v(size)}] [expr {$y+$v(size)}]
26 set w .ruler
27 global tk_library
28 catch {destroy $w}
29 toplevel $w
30 wm title $w "Ruler Demonstration"
31 wm iconname $w "ruler"
32 positionWindow $w
33 set c $w.c
35 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."
36 pack $w.msg -side top
38 frame $w.buttons
39 pack $w.buttons -side bottom -fill x -pady 2m
40 button $w.buttons.dismiss -text Dismiss -command "destroy $w"
41 button $w.buttons.code -text "See Code" -command "showCode $w"
42 pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
44 canvas $c -width 14.8c -height 2.5c
45 pack $w.c -side top -fill x
47 set demo_rulerInfo(grid) .25c
48 set demo_rulerInfo(left) [winfo fpixels $c 1c]
49 set demo_rulerInfo(right) [winfo fpixels $c 13c]
50 set demo_rulerInfo(top) [winfo fpixels $c 1c]
51 set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c]
52 set demo_rulerInfo(size) [winfo fpixels $c .2c]
53 set demo_rulerInfo(normalStyle) "-fill black"
54 if {[winfo depth $c] > 1} {
55 set demo_rulerInfo(activeStyle) "-fill red -stipple {}"
56 set demo_rulerInfo(deleteStyle) [list -fill red \
57 -stipple @[file join $tk_library demos images gray25.bmp]]
58 } else {
59 set demo_rulerInfo(activeStyle) "-fill black -stipple {}"
60 set demo_rulerInfo(deleteStyle) [list -fill black \
61 -stipple @[file join $tk_library demos images gray25.bmp]]
64 $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1
65 for {set i 0} {$i < 12} {incr i} {
66 set x [expr {$i+1}]
67 $c create line ${x}c 1c ${x}c 0.6c -width 1
68 $c create line $x.25c 1c $x.25c 0.8c -width 1
69 $c create line $x.5c 1c $x.5c 0.7c -width 1
70 $c create line $x.75c 1c $x.75c 0.8c -width 1
71 $c create text $x.15c .75c -text $i -anchor sw
73 $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \
74 -outline black -fill [lindex [$c config -bg] 4]]
75 $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
76 [winfo pixels $c .65c]]
78 $c bind well <1> "rulerNewTab $c %x %y"
79 $c bind tab <1> "rulerSelectTab $c %x %y"
80 bind $c <B1-Motion> "rulerMoveTab $c %x %y"
81 bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
83 # rulerNewTab --
84 # Does all the work of creating a tab stop, including creating the
85 # triangle object and adding tags to it to give it tab behavior.
87 # Arguments:
88 # c - The canvas window.
89 # x, y - The coordinates of the tab stop.
91 proc rulerNewTab {c x y} {
92 upvar #0 demo_rulerInfo v
93 $c addtag active withtag [rulerMkTab $c $x $y]
94 $c addtag tab withtag active
95 set v(x) $x
96 set v(y) $y
97 rulerMoveTab $c $x $y
100 # rulerSelectTab --
101 # This procedure is invoked when mouse button 1 is pressed over
102 # a tab. It remembers information about the tab so that it can
103 # be dragged interactively.
105 # Arguments:
106 # c - The canvas widget.
107 # x, y - The coordinates of the mouse (identifies the point by
108 # which the tab was picked up for dragging).
110 proc rulerSelectTab {c x y} {
111 upvar #0 demo_rulerInfo v
112 set v(x) [$c canvasx $x $v(grid)]
113 set v(y) [expr {$v(top)+2}]
114 $c addtag active withtag current
115 eval "$c itemconf active $v(activeStyle)"
116 $c raise active
119 # rulerMoveTab --
120 # This procedure is invoked during mouse motion events to drag a tab.
121 # It adjusts the position of the tab, and changes its appearance if
122 # it is about to be dragged out of the ruler.
124 # Arguments:
125 # c - The canvas widget.
126 # x, y - The coordinates of the mouse.
128 proc rulerMoveTab {c x y} {
129 upvar #0 demo_rulerInfo v
130 if {[$c find withtag active] == ""} {
131 return
133 set cx [$c canvasx $x $v(grid)]
134 set cy [$c canvasy $y]
135 if {$cx < $v(left)} {
136 set cx $v(left)
138 if {$cx > $v(right)} {
139 set cx $v(right)
141 if {($cy >= $v(top)) && ($cy <= $v(bottom))} {
142 set cy [expr {$v(top)+2}]
143 eval "$c itemconf active $v(activeStyle)"
144 } else {
145 set cy [expr {$cy-$v(size)-2}]
146 eval "$c itemconf active $v(deleteStyle)"
148 $c move active [expr {$cx-$v(x)}] [expr {$cy-$v(y)}]
149 set v(x) $cx
150 set v(y) $cy
153 # rulerReleaseTab --
154 # This procedure is invoked during button release events that end
155 # a tab drag operation. It deselects the tab and deletes the tab if
156 # it was dragged out of the ruler.
158 # Arguments:
159 # c - The canvas widget.
160 # x, y - The coordinates of the mouse.
162 proc rulerReleaseTab c {
163 upvar #0 demo_rulerInfo v
164 if {[$c find withtag active] == {}} {
165 return
167 if {$v(y) != $v(top)+2} {
168 $c delete active
169 } else {
170 eval "$c itemconf active $v(normalStyle)"
171 $c dtag active