"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/tk8.6/demos/ruler.tcl" (17 Mar 2020, 5323 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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 if {![info exists widgetDemo]} {
    7     error "This script should be run from the \"widget\" demo."
    8 }
    9 
   10 package require Tk
   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     set newTab [$c create polygon $x $y \
   23         [expr {$x+$v(size)}] [expr {$y+$v(size)}] \
   24         [expr {$x-$v(size)}] [expr {$y+$v(size)}]]
   25     set fill [$c itemcget $newTab -outline]
   26     $c itemconfigure $newTab -fill $fill -outline {}
   27     set v(normalStyle) "-fill $fill"
   28     return $newTab
   29 }
   30 
   31 set w .ruler
   32 catch {destroy $w}
   33 toplevel $w
   34 wm title $w "Ruler Demonstration"
   35 wm iconname $w "ruler"
   36 positionWindow $w
   37 set c $w.c
   38 
   39 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."
   40 pack $w.msg -side top
   41 
   42 ## See Code / Dismiss buttons
   43 set btns [addSeeDismiss $w.buttons $w]
   44 pack $btns -side bottom -fill x
   45 
   46 canvas $c -width 14.8c -height 2.5c
   47 pack $w.c -side top -fill x
   48 
   49 set demo_rulerInfo(grid) .25c
   50 set demo_rulerInfo(left) [winfo fpixels $c 1c]
   51 set demo_rulerInfo(right) [winfo fpixels $c 13c]
   52 set demo_rulerInfo(top) [winfo fpixels $c 1c]
   53 set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c]
   54 set demo_rulerInfo(size) [winfo fpixels $c .2c]
   55 # Main widget program sets variable tk_demoDirectory
   56 if {[winfo depth $c] > 1} {
   57     set demo_rulerInfo(activeStyle) "-fill red -stipple {}"
   58     set demo_rulerInfo(deleteStyle) [list -fill red \
   59         -stipple @[file join $tk_demoDirectory images gray25.xbm]]
   60 } else {
   61     set demo_rulerInfo(activeStyle) "-fill black -stipple {}"
   62     set demo_rulerInfo(deleteStyle) [list -fill black \
   63         -stipple @[file join $tk_demoDirectory images gray25.xbm]]
   64 }
   65 
   66 $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1
   67 for {set i 0} {$i < 12} {incr i} {
   68     set x [expr {$i+1}]
   69     $c create line ${x}c 1c ${x}c 0.6c -width 1
   70     $c create line $x.25c 1c $x.25c 0.8c -width 1
   71     $c create line $x.5c 1c $x.5c 0.7c -width 1
   72     $c create line $x.75c 1c $x.75c 0.8c -width 1
   73     $c create text $x.15c .75c -text $i -anchor sw
   74 }
   75 $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \
   76     -fill [lindex [$c config -bg] 4]]
   77 $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
   78     [winfo pixels $c .65c]]
   79 
   80 $c bind well <1> "rulerNewTab $c %x %y"
   81 $c bind tab <1> "rulerSelectTab $c %x %y"
   82 bind $c <B1-Motion> "rulerMoveTab $c %x %y"
   83 bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
   84 
   85 # rulerNewTab --
   86 # Does all the work of creating a tab stop, including creating the
   87 # triangle object and adding tags to it to give it tab behavior.
   88 #
   89 # Arguments:
   90 # c -       The canvas window.
   91 # x, y -    The coordinates of the tab stop.
   92 
   93 proc rulerNewTab {c x y} {
   94     upvar #0 demo_rulerInfo v
   95     $c addtag active withtag [rulerMkTab $c $x $y]
   96     $c addtag tab withtag active
   97     set v(x) $x
   98     set v(y) $y
   99     rulerMoveTab $c $x $y
  100 }
  101 
  102 # rulerSelectTab --
  103 # This procedure is invoked when mouse button 1 is pressed over
  104 # a tab.  It remembers information about the tab so that it can
  105 # be dragged interactively.
  106 #
  107 # Arguments:
  108 # c -       The canvas widget.
  109 # x, y -    The coordinates of the mouse (identifies the point by
  110 #       which the tab was picked up for dragging).
  111 
  112 proc rulerSelectTab {c x y} {
  113     upvar #0 demo_rulerInfo v
  114     set v(x) [$c canvasx $x $v(grid)]
  115     set v(y) [expr {$v(top)+2}]
  116     $c addtag active withtag current
  117     eval "$c itemconf active $v(activeStyle)"
  118     $c raise active
  119 }
  120 
  121 # rulerMoveTab --
  122 # This procedure is invoked during mouse motion events to drag a tab.
  123 # It adjusts the position of the tab, and changes its appearance if
  124 # it is about to be dragged out of the ruler.
  125 #
  126 # Arguments:
  127 # c -       The canvas widget.
  128 # x, y -    The coordinates of the mouse.
  129 
  130 proc rulerMoveTab {c x y} {
  131     upvar #0 demo_rulerInfo v
  132     if {[$c find withtag active] == ""} {
  133     return
  134     }
  135     set cx [$c canvasx $x $v(grid)]
  136     set cy [$c canvasy $y]
  137     if {$cx < $v(left)} {
  138     set cx $v(left)
  139     }
  140     if {$cx > $v(right)} {
  141     set cx $v(right)
  142     }
  143     if {($cy >= $v(top)) && ($cy <= $v(bottom))} {
  144     set cy [expr {$v(top)+2}]
  145     eval "$c itemconf active $v(activeStyle)"
  146     } else {
  147     set cy [expr {$cy-$v(size)-2}]
  148     eval "$c itemconf active $v(deleteStyle)"
  149     }
  150     $c move active [expr {$cx-$v(x)}] [expr {$cy-$v(y)}]
  151     set v(x) $cx
  152     set v(y) $cy
  153 }
  154 
  155 # rulerReleaseTab --
  156 # This procedure is invoked during button release events that end
  157 # a tab drag operation.  It deselects the tab and deletes the tab if
  158 # it was dragged out of the ruler.
  159 #
  160 # Arguments:
  161 # c -       The canvas widget.
  162 # x, y -    The coordinates of the mouse.
  163 
  164 proc rulerReleaseTab c {
  165     upvar #0 demo_rulerInfo v
  166     if {[$c find withtag active] == {}} {
  167     return
  168     }
  169     if {$v(y) != $v(top)+2} {
  170     $c delete active
  171     } else {
  172     eval "$c itemconf active $v(normalStyle)"
  173     $c dtag active
  174     }
  175 }