ALPHALINUX5/util/ALPHALINUX5/lib/tk8.3/demos/arrow.tcl

   1 # arrow.tcl --
   2 #
   3 # This demonstration script creates a canvas widget that displays a
   4 # large line with an arrowhead whose shape can be edited interactively.
   5 #
   6 # RCS: @(#) $Id: arrow.tcl,v 1.2 1998/09/14 18:23:26 stanton Exp $
   7
   8 if {![info exists widgetDemo]} {
   9     error "This script should be run from the \"widget\" demo."
  10 }
  11
  12 # arrowSetup --
  13 # This procedure regenerates all the text and graphics in the canvas
  14 # window.  It's called when the canvas is initially created, and also
  15 # whenever any of the parameters of the arrow head are changed
  16 # interactively.
  17 #
  18 # Arguments:
  19 # c -           Name of the canvas widget.
  20
  21 proc arrowSetup c {
  22     upvar #0 demo_arrowInfo v
  23
  24     # Remember the current box, if there is one.
  25
  26     set tags [$c gettags current]
  27     if {$tags != ""} {
  28         set cur [lindex $tags [lsearch -glob $tags box?]]
  29     } else {
  30         set cur ""
  31     }
  32
  33     # Create the arrow and outline.
  34
  35     $c delete all
  36     eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \
  37             -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \
  38             -arrow last $v(bigLineStyle)"
  39     set xtip [expr $v(x2)-10*$v(b)]
  40     set deltaY [expr 10*$v(c)+5*$v(width)]
  41     $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \
  42             [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \
  43             $v(x2) $v(y) -width 2 -capstyle round -joinstyle round
  44
  45     # Create the boxes for reshaping the line and arrowhead.
  46
  47     eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \
  48             [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \
  49             -tags {box1 box}"
  50     eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \
  51             [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \
  52             -tags {box2 box}"
  53     eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \
  54             [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \
  55             -tags {box3 box}"
  56     if {$cur != ""} {
  57         eval $c itemconfigure $cur $v(activeStyle)
  58     }
  59
  60     # Create three arrows in actual size with the same parameters
  61
  62     $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \
  63             -width 2
  64     set tmp [expr $v(x2)+100]
  65     $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \
  66             -width $v(width) \
  67             -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  68     $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \
  69             -width $v(width) \
  70             -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  71     $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \
  72             [expr $v(y)+125] -width $v(width) \
  73             -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  74
  75     # Create a bunch of other arrows and text items showing the
  76     # current dimensions.
  77
  78     set tmp [expr $v(x2)+10]
  79     $c create line $tmp [expr $v(y)-5*$v(width)] \
  80             $tmp [expr $v(y)-$deltaY] \
  81             -arrow both -arrowshape $v(smallTips)
  82     $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \
  83             -text $v(c) -anchor w
  84     set tmp [expr $v(x1)-10]
  85     $c create line $tmp [expr $v(y)-5*$v(width)] \
  86             $tmp [expr $v(y)+5*$v(width)] \
  87             -arrow both -arrowshape $v(smallTips)
  88     $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e
  89     set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10]
  90     $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \
  91             -arrow both -arrowshape $v(smallTips)
  92     $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \
  93             -text $v(a) -anchor n
  94     set tmp [expr $tmp+25]
  95     $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \
  96             -arrow both -arrowshape $v(smallTips)
  97     $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \
  98             -text $v(b) -anchor n
  99
 100     $c create text $v(x1) 310 -text "-width  $v(width)" \
 101             -anchor w -font {Helvetica 18}
 102     $c create text $v(x1) 330 -text "-arrowshape  {$v(a)  $v(b)  $v(c)}" \
 103             -anchor w -font {Helvetica 18}
 104
 105     incr v(count)
 106 }
 107
 108 set w .arrow
 109 global tk_library
 110 catch {destroy $w}
 111 toplevel $w
 112 wm title $w "Arrowhead Editor Demonstration"
 113 wm iconname $w "arrow"
 114 positionWindow $w
 115 set c $w.c
 116
 117 label $w.msg -font $font -wraplength 5i -justify left -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases.  To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow.  The arrows on the right give examples at normal scale.  The text at the bottom shows the configuration options as you'd enter them for a canvas line item."
 118 pack $w.msg -side top
 119
 120 frame $w.buttons
 121 pack $w.buttons -side bottom -fill x -pady 2m
 122 button $w.buttons.dismiss -text Dismiss -command "destroy $w"
 123 button $w.buttons.code -text "See Code" -command "showCode $w"
 124 pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
 125
 126 canvas $c -width 500 -height 350 -relief sunken -borderwidth 2
 127 pack $c -expand yes -fill both
 128
 129 set demo_arrowInfo(a) 8
 130 set demo_arrowInfo(b) 10
 131 set demo_arrowInfo(c) 3
 132 set demo_arrowInfo(width) 2
 133 set demo_arrowInfo(motionProc) arrowMoveNull
 134 set demo_arrowInfo(x1) 40
 135 set demo_arrowInfo(x2) 350
 136 set demo_arrowInfo(y) 150
 137 set demo_arrowInfo(smallTips) {5 5 2}
 138 set demo_arrowInfo(count) 0
 139 if {[winfo depth $c] > 1} {
 140     set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1"
 141     set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
 142     set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1"
 143 } else {
 144     set demo_arrowInfo(bigLineStyle) "-fill black \
 145         -stipple @[file join $tk_library demos images grey.25]"
 146     set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
 147     set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1"
 148 }
 149 arrowSetup $c
 150 $c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)"
 151 $c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
 152 $c bind box <B1-Enter> " "
 153 $c bind box <B1-Leave> " "
 154 $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1}
 155 $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2}
 156 $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3}
 157 $c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
 158 bind $c <Any-ButtonRelease-1> "arrowSetup $c"
 159
 160 # arrowMove1 --
 161 # This procedure is called for each mouse motion event on box1 (the
 162 # one at the vertex of the arrow).  It updates the controlling parameters
 163 # for the line and arrowhead.
 164 #
 165 # Arguments:
 166 # c -           The name of the canvas window.
 167 # x, y -        The coordinates of the mouse.
 168
 169 proc arrowMove1 {c x y} {
 170     upvar #0 demo_arrowInfo v
 171     set newA [expr ($v(x2)+5-round([$c canvasx $x]))/10]
 172     if {$newA < 0} {
 173         set newA 0
 174     }
 175     if {$newA > 25} {
 176         set newA 25
 177     }
 178     if {$newA != $v(a)} {
 179         $c move box1 [expr 10*($v(a)-$newA)] 0
 180         set v(a) $newA
 181     }
 182 }
 183
 184 # arrowMove2 --
 185 # This procedure is called for each mouse motion event on box2 (the
 186 # one at the trailing tip of the arrowhead).  It updates the controlling
 187 # parameters for the line and arrowhead.
 188 #
 189 # Arguments:
 190 # c -           The name of the canvas window.
 191 # x, y -        The coordinates of the mouse.
 192
 193 proc arrowMove2 {c x y} {
 194     upvar #0 demo_arrowInfo v
 195     set newB [expr ($v(x2)+5-round([$c canvasx $x]))/10]
 196     if {$newB < 0} {
 197         set newB 0
 198     }
 199     if {$newB > 25} {
 200         set newB 25
 201     }
 202     set newC [expr ($v(y)+5-round([$c canvasy $y])-5*$v(width))/10]
 203     if {$newC < 0} {
 204         set newC 0
 205     }
 206     if {$newC > 20} {
 207         set newC 20
 208     }
 209     if {($newB != $v(b)) || ($newC != $v(c))} {
 210         $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)]
 211         set v(b) $newB
 212         set v(c) $newC
 213     }
 214 }
 215
 216 # arrowMove3 --
 217 # This procedure is called for each mouse motion event on box3 (the
 218 # one that controls the thickness of the line).  It updates the
 219 # controlling parameters for the line and arrowhead.
 220 #
 221 # Arguments:
 222 # c -           The name of the canvas window.
 223 # x, y -        The coordinates of the mouse.
 224
 225 proc arrowMove3 {c x y} {
 226     upvar #0 demo_arrowInfo v
 227     set newWidth [expr ($v(y)+2-round([$c canvasy $y]))/5]
 228     if {$newWidth < 0} {
 229         set newWidth 0
 230     }
 231     if {$newWidth > 20} {
 232         set newWidth 20
 233     }
 234     if {$newWidth != $v(width)} {
 235         $c move box3 0 [expr 5*($v(width)-$newWidth)]
 236         set v(width) $newWidth
 237     }
 238 }