git.zerfleddert.de Git - micropolis/blob - src/tk/library/demos/mkRuler.tcl

   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 }