]> cvs.zerfleddert.de Git - micropolis/blame - src/tk/library/demos/mkRuler.tcl
Import Micropolis from http://www.donhopkins.com/home/micropolis/
[micropolis] / src / tk / library / demos / mkRuler.tcl
CommitLineData
6a5fa4e0
MG
1# mkRuler w
2#
3# Create a canvas demonstration consisting of a ruler.
4#
5# Arguments:
6# w - Name to use for new top-level window.
7# This file implements a canvas widget that displays a ruler with tab stops
8# that can be set individually. The only procedure that should be invoked
9# from outside the file is the first one, which creates the canvas.
10
11proc mkRuler {{w .ruler}} {
12 global tk_library
13 upvar #0 demo_rulerInfo v
14 catch {destroy $w}
15 toplevel $w
16 dpos $w
17 wm title $w "Ruler Demonstration"
18 wm iconname $w "Ruler"
19 set c $w.c
20
21 frame $w.frame1 -relief raised -bd 2
22 canvas $c -width 14.8c -height 2.5c -relief raised
23 button $w.ok -text "OK" -command "destroy $w"
24 pack append $w $w.frame1 {top fill} $w.ok {bottom pady 10 frame center} \
25 $c {expand fill}
26 message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
27 -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."
28 pack append $w.frame1 $w.frame1.m {frame center}
29
30 set v(grid) .25c
31 set v(left) [winfo fpixels $c 1c]
32 set v(right) [winfo fpixels $c 13c]
33 set v(top) [winfo fpixels $c 1c]
34 set v(bottom) [winfo fpixels $c 1.5c]
35 set v(size) [winfo fpixels $c .2c]
36 set v(normalStyle) "-fill black"
37 if {[winfo screendepth $c] > 4} {
38 set v(activeStyle) "-fill red -stipple {}"
39 set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \
40 -fill red"
41 } else {
42 set v(activeStyle) "-fill black -stipple {}"
43 set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \
44 -fill black"
45 }
46
47 $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1
48 for {set i 0} {$i < 12} {incr i} {
49 set x [expr $i+1]
50 $c create line ${x}c 1c ${x}c 0.6c -width 1
51 $c create line $x.25c 1c $x.25c 0.8c -width 1
52 $c create line $x.5c 1c $x.5c 0.7c -width 1
53 $c create line $x.75c 1c $x.75c 0.8c -width 1
54 $c create text $x.15c .75c -text $i -anchor sw
55 }
56 $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \
57 -outline black -fill [lindex [$c config -bg] 4]]
58 $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
59 [winfo pixels $c .65c]]
60
61 $c bind well <1> "rulerNewTab $c %x %y"
62 $c bind tab <1> "demo_selectTab $c %x %y"
63 bind $c <B1-Motion> "rulerMoveTab $c %x %y"
64 bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
65}
66
67proc rulerMkTab {c x y} {
68 upvar #0 demo_rulerInfo v
69 $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \
70 [expr $x-$v(size)] [expr $y+$v(size)]
71}
72
73proc rulerNewTab {c x y} {
74 upvar #0 demo_rulerInfo v
75 $c addtag active withtag [rulerMkTab $c $x $y]
76 $c addtag tab withtag active
77 set v(x) $x
78 set v(y) $y
79 rulerMoveTab $c $x $y
80}
81
82proc rulerMoveTab {c x y} {
83 upvar #0 demo_rulerInfo v
84 if {[$c find withtag active] == ""} {
85 return
86 }
87 set cx [$c canvasx $x $v(grid)]
88 set cy [$c canvasy $y]
89 if {$cx < $v(left)} {
90 set cx $v(left)
91 }
92 if {$cx > $v(right)} {
93 set cx $v(right)
94 }
95 if {($cy >= $v(top)) && ($cy <= $v(bottom))} {
96 set cy [expr $v(top)+2]
97 eval "$c itemconf active $v(activeStyle)"
98 } else {
99 set cy [expr $cy-$v(size)-2]
100 eval "$c itemconf active $v(deleteStyle)"
101 }
102 $c move active [expr $cx-$v(x)] [expr $cy-$v(y)]
103 set v(x) $cx
104 set v(y) $cy
105}
106
107proc demo_selectTab {c x y} {
108 upvar #0 demo_rulerInfo v
109 set v(x) [$c canvasx $x $v(grid)]
110 set v(y) [expr $v(top)+2]
111 $c addtag active withtag current
112 eval "$c itemconf active $v(activeStyle)"
113 $c raise active
114}
115
116proc rulerReleaseTab c {
117 upvar #0 demo_rulerInfo v
118 if {$v(y) != [expr $v(top)+2]} {
119 $c delete active
120 } else {
121 eval "$c itemconf active $v(normalStyle)"
122 $c dtag active
123 }
124}
Impressum, Datenschutz