mingw/lib/tk8.4/demos/ruler.tcl

   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 }