[37] | 1 | # ruler.tcl -- |
---|
| 2 | # |
---|
| 3 | # This demonstration script creates a canvas widget that displays a ruler |
---|
| 4 | # with tab stops that can be set, moved, and deleted. |
---|
| 5 | # |
---|
| 6 | # RCS: @(#) $Id: ruler.tcl,v 1.3 2001/06/14 10:56:58 dkf Exp $ |
---|
| 7 | |
---|
| 8 | if {![info exists widgetDemo]} { |
---|
| 9 | error "This script should be run from the \"widget\" demo." |
---|
| 10 | } |
---|
| 11 | |
---|
| 12 | # rulerMkTab -- |
---|
| 13 | # This procedure creates a new triangular polygon in a canvas to |
---|
| 14 | # represent a tab stop. |
---|
| 15 | # |
---|
| 16 | # Arguments: |
---|
| 17 | # c - The canvas window. |
---|
| 18 | # x, y - Coordinates at which to create the tab stop. |
---|
| 19 | |
---|
| 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)}] |
---|
| 24 | } |
---|
| 25 | |
---|
| 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 |
---|
| 34 | |
---|
| 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 |
---|
| 37 | |
---|
| 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 |
---|
| 43 | |
---|
| 44 | canvas $c -width 14.8c -height 2.5c |
---|
| 45 | pack $w.c -side top -fill x |
---|
| 46 | |
---|
| 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]] |
---|
| 62 | } |
---|
| 63 | |
---|
| 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 |
---|
| 72 | } |
---|
| 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]] |
---|
| 77 | |
---|
| 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" |
---|
| 82 | |
---|
| 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. |
---|
| 86 | # |
---|
| 87 | # Arguments: |
---|
| 88 | # c - The canvas window. |
---|
| 89 | # x, y - The coordinates of the tab stop. |
---|
| 90 | |
---|
| 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 |
---|
| 98 | } |
---|
| 99 | |
---|
| 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. |
---|
| 104 | # |
---|
| 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). |
---|
| 109 | |
---|
| 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 |
---|
| 117 | } |
---|
| 118 | |
---|
| 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. |
---|
| 123 | # |
---|
| 124 | # Arguments: |
---|
| 125 | # c - The canvas widget. |
---|
| 126 | # x, y - The coordinates of the mouse. |
---|
| 127 | |
---|
| 128 | proc rulerMoveTab {c x y} { |
---|
| 129 | upvar #0 demo_rulerInfo v |
---|
| 130 | if {[$c find withtag active] == ""} { |
---|
| 131 | return |
---|
| 132 | } |
---|
| 133 | set cx [$c canvasx $x $v(grid)] |
---|
| 134 | set cy [$c canvasy $y] |
---|
| 135 | if {$cx < $v(left)} { |
---|
| 136 | set cx $v(left) |
---|
| 137 | } |
---|
| 138 | if {$cx > $v(right)} { |
---|
| 139 | set cx $v(right) |
---|
| 140 | } |
---|
| 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)" |
---|
| 147 | } |
---|
| 148 | $c move active [expr {$cx-$v(x)}] [expr {$cy-$v(y)}] |
---|
| 149 | set v(x) $cx |
---|
| 150 | set v(y) $cy |
---|
| 151 | } |
---|
| 152 | |
---|
| 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. |
---|
| 157 | # |
---|
| 158 | # Arguments: |
---|
| 159 | # c - The canvas widget. |
---|
| 160 | # x, y - The coordinates of the mouse. |
---|
| 161 | |
---|
| 162 | proc rulerReleaseTab c { |
---|
| 163 | upvar #0 demo_rulerInfo v |
---|
| 164 | if {[$c find withtag active] == {}} { |
---|
| 165 | return |
---|
| 166 | } |
---|
| 167 | if {$v(y) != $v(top)+2} { |
---|
| 168 | $c delete active |
---|
| 169 | } else { |
---|
| 170 | eval "$c itemconf active $v(normalStyle)" |
---|
| 171 | $c dtag active |
---|
| 172 | } |
---|
| 173 | } |
---|