| # ruler.tcl -- |
| # |
| # This demonstration script creates a canvas widget that displays a ruler |
| # with tab stops that can be set, moved, and deleted. |
| # |
| # RCS: @(#) $Id: ruler.tcl,v 1.3 2001/06/14 10:56:58 dkf Exp $ |
| |
| if {![info exists widgetDemo]} { |
| error "This script should be run from the \"widget\" demo." |
| } |
| |
| # rulerMkTab -- |
| # This procedure creates a new triangular polygon in a canvas to |
| # represent a tab stop. |
| # |
| # Arguments: |
| # c - The canvas window. |
| # x, y - Coordinates at which to create the tab stop. |
| |
| proc rulerMkTab {c x y} { |
| upvar #0 demo_rulerInfo v |
| $c create polygon $x $y [expr {$x+$v(size)}] [expr {$y+$v(size)}] \ |
| [expr {$x-$v(size)}] [expr {$y+$v(size)}] |
| } |
| |
| set w .ruler |
| global tk_library |
| catch {destroy $w} |
| toplevel $w |
| wm title $w "Ruler Demonstration" |
| wm iconname $w "ruler" |
| positionWindow $w |
| set c $w.c |
| |
| 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." |
| pack $w.msg -side top |
| |
| frame $w.buttons |
| pack $w.buttons -side bottom -fill x -pady 2m |
| button $w.buttons.dismiss -text Dismiss -command "destroy $w" |
| button $w.buttons.code -text "See Code" -command "showCode $w" |
| pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 |
| |
| canvas $c -width 14.8c -height 2.5c |
| pack $w.c -side top -fill x |
| |
| set demo_rulerInfo(grid) .25c |
| set demo_rulerInfo(left) [winfo fpixels $c 1c] |
| set demo_rulerInfo(right) [winfo fpixels $c 13c] |
| set demo_rulerInfo(top) [winfo fpixels $c 1c] |
| set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c] |
| set demo_rulerInfo(size) [winfo fpixels $c .2c] |
| set demo_rulerInfo(normalStyle) "-fill black" |
| if {[winfo depth $c] > 1} { |
| set demo_rulerInfo(activeStyle) "-fill red -stipple {}" |
| set demo_rulerInfo(deleteStyle) [list -fill red \ |
| -stipple @[file join $tk_library demos images gray25.bmp]] |
| } else { |
| set demo_rulerInfo(activeStyle) "-fill black -stipple {}" |
| set demo_rulerInfo(deleteStyle) [list -fill black \ |
| -stipple @[file join $tk_library demos images gray25.bmp]] |
| } |
| |
| $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 |
| for {set i 0} {$i < 12} {incr i} { |
| set x [expr {$i+1}] |
| $c create line ${x}c 1c ${x}c 0.6c -width 1 |
| $c create line $x.25c 1c $x.25c 0.8c -width 1 |
| $c create line $x.5c 1c $x.5c 0.7c -width 1 |
| $c create line $x.75c 1c $x.75c 0.8c -width 1 |
| $c create text $x.15c .75c -text $i -anchor sw |
| } |
| $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ |
| -outline black -fill [lindex [$c config -bg] 4]] |
| $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ |
| [winfo pixels $c .65c]] |
| |
| $c bind well <1> "rulerNewTab $c %x %y" |
| $c bind tab <1> "rulerSelectTab $c %x %y" |
| bind $c <B1-Motion> "rulerMoveTab $c %x %y" |
| bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c" |
| |
| # rulerNewTab -- |
| # Does all the work of creating a tab stop, including creating the |
| # triangle object and adding tags to it to give it tab behavior. |
| # |
| # Arguments: |
| # c - The canvas window. |
| # x, y - The coordinates of the tab stop. |
| |
| proc rulerNewTab {c x y} { |
| upvar #0 demo_rulerInfo v |
| $c addtag active withtag [rulerMkTab $c $x $y] |
| $c addtag tab withtag active |
| set v(x) $x |
| set v(y) $y |
| rulerMoveTab $c $x $y |
| } |
| |
| # rulerSelectTab -- |
| # This procedure is invoked when mouse button 1 is pressed over |
| # a tab. It remembers information about the tab so that it can |
| # be dragged interactively. |
| # |
| # Arguments: |
| # c - The canvas widget. |
| # x, y - The coordinates of the mouse (identifies the point by |
| # which the tab was picked up for dragging). |
| |
| proc rulerSelectTab {c x y} { |
| upvar #0 demo_rulerInfo v |
| set v(x) [$c canvasx $x $v(grid)] |
| set v(y) [expr {$v(top)+2}] |
| $c addtag active withtag current |
| eval "$c itemconf active $v(activeStyle)" |
| $c raise active |
| } |
| |
| # rulerMoveTab -- |
| # This procedure is invoked during mouse motion events to drag a tab. |
| # It adjusts the position of the tab, and changes its appearance if |
| # it is about to be dragged out of the ruler. |
| # |
| # Arguments: |
| # c - The canvas widget. |
| # x, y - The coordinates of the mouse. |
| |
| proc rulerMoveTab {c x y} { |
| upvar #0 demo_rulerInfo v |
| if {[$c find withtag active] == ""} { |
| return |
| } |
| set cx [$c canvasx $x $v(grid)] |
| set cy [$c canvasy $y] |
| if {$cx < $v(left)} { |
| set cx $v(left) |
| } |
| if {$cx > $v(right)} { |
| set cx $v(right) |
| } |
| if {($cy >= $v(top)) && ($cy <= $v(bottom))} { |
| set cy [expr {$v(top)+2}] |
| eval "$c itemconf active $v(activeStyle)" |
| } else { |
| set cy [expr {$cy-$v(size)-2}] |
| eval "$c itemconf active $v(deleteStyle)" |
| } |
| $c move active [expr {$cx-$v(x)}] [expr {$cy-$v(y)}] |
| set v(x) $cx |
| set v(y) $cy |
| } |
| |
| # rulerReleaseTab -- |
| # This procedure is invoked during button release events that end |
| # a tab drag operation. It deselects the tab and deletes the tab if |
| # it was dragged out of the ruler. |
| # |
| # Arguments: |
| # c - The canvas widget. |
| # x, y - The coordinates of the mouse. |
| |
| proc rulerReleaseTab c { |
| upvar #0 demo_rulerInfo v |
| if {[$c find withtag active] == {}} { |
| return |
| } |
| if {$v(y) != $v(top)+2} { |
| $c delete active |
| } else { |
| eval "$c itemconf active $v(normalStyle)" |
| $c dtag active |
| } |
| } |