← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to gcl-tk/demos/mkRuler.tcl

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
gcl-tk/demos/mkRuler.tcl
 
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
 
 
11
proc 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
    message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 13c \
 
22
            -relief raised -bd 2 -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."
 
23
    canvas $c -width 14.8c -height 2.5c -relief raised
 
24
    button $w.ok -text "OK" -command "destroy $w"
 
25
    pack $w.msg $w.c -side top -fill x
 
26
    pack $w.ok -side bottom -pady 5
 
27
 
 
28
    set v(grid) .25c
 
29
    set v(left) [winfo fpixels $c 1c]
 
30
    set v(right) [winfo fpixels $c 13c]
 
31
    set v(top) [winfo fpixels $c 1c]
 
32
    set v(bottom) [winfo fpixels $c 1.5c]
 
33
    set v(size) [winfo fpixels $c .2c]
 
34
    set v(normalStyle) "-fill black"
 
35
    if {[tk colormodel $c] == "color"} {
 
36
        set v(activeStyle) "-fill red -stipple {}"
 
37
        set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \
 
38
                -fill red"
 
39
    } else {
 
40
        set v(activeStyle) "-fill black -stipple {}"
 
41
        set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \
 
42
                -fill black"
 
43
    }
 
44
 
 
45
    $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1
 
46
    for {set i 0} {$i < 12} {incr i} {
 
47
        set x [expr $i+1]
 
48
        $c create line ${x}c 1c ${x}c 0.6c -width 1
 
49
        $c create line $x.25c 1c $x.25c 0.8c -width 1
 
50
        $c create line $x.5c 1c $x.5c 0.7c -width 1
 
51
        $c create line $x.75c 1c $x.75c 0.8c -width 1
 
52
        $c create text $x.15c .75c -text $i -anchor sw
 
53
    }
 
54
    $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \
 
55
            -outline black -fill [lindex [$c config -bg] 4]]
 
56
    $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
 
57
            [winfo pixels $c .65c]]
 
58
 
 
59
    $c bind well <1> "rulerNewTab $c %x %y"
 
60
    $c bind tab <1> "demo_selectTab $c %x %y"
 
61
    bind $c <B1-Motion> "rulerMoveTab $c %x %y"
 
62
    bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
 
63
}
 
64
 
 
65
proc rulerMkTab {c x y} {
 
66
    upvar #0 demo_rulerInfo v
 
67
    $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \
 
68
            [expr $x-$v(size)] [expr $y+$v(size)]
 
69
}
 
70
 
 
71
proc rulerNewTab {c x y} {
 
72
    upvar #0 demo_rulerInfo v
 
73
    $c addtag active withtag [rulerMkTab $c $x $y]
 
74
    $c addtag tab withtag active
 
75
    set v(x) $x
 
76
    set v(y) $y
 
77
    rulerMoveTab $c $x $y
 
78
}
 
79
 
 
80
proc rulerMoveTab {c x y} {
 
81
    upvar #0 demo_rulerInfo v
 
82
    if {[$c find withtag active] == ""} {
 
83
        return
 
84
    }
 
85
    set cx [$c canvasx $x $v(grid)]
 
86
    set cy [$c canvasy $y]
 
87
    if {$cx < $v(left)} {
 
88
        set cx $v(left)
 
89
    }
 
90
    if {$cx > $v(right)} {
 
91
        set cx $v(right)
 
92
    }
 
93
    if {($cy >= $v(top)) && ($cy <= $v(bottom))} {
 
94
        set cy [expr $v(top)+2]
 
95
        eval "$c itemconf active $v(activeStyle)"
 
96
    } else {
 
97
        set cy [expr $cy-$v(size)-2]
 
98
        eval "$c itemconf active $v(deleteStyle)"
 
99
    }
 
100
    $c move active [expr $cx-$v(x)] [expr $cy-$v(y)]
 
101
    set v(x) $cx
 
102
    set v(y) $cy
 
103
}
 
104
 
 
105
proc demo_selectTab {c x y} {
 
106
    upvar #0 demo_rulerInfo v
 
107
    set v(x) [$c canvasx $x $v(grid)]
 
108
    set v(y) [expr $v(top)+2]
 
109
    $c addtag active withtag current
 
110
    eval "$c itemconf active $v(activeStyle)"
 
111
    $c raise active
 
112
}
 
113
 
 
114
proc rulerReleaseTab c {
 
115
    upvar #0 demo_rulerInfo v
 
116
    if {[$c find withtag active] == {}} {
 
117
        return
 
118
    }
 
119
    if {$v(y) != [expr $v(top)+2]} {
 
120
        $c delete active
 
121
    } else {
 
122
        eval "$c itemconf active $v(normalStyle)"
 
123
        $c dtag active
 
124
    }
 
125
}