Return to mkRuler.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tk / library / demos

Annotation of micropolis/src/tk/library/demos/mkRuler.tcl, revision 1.1.1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.