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     ! 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.