home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tk8.4 / demos / arrow.tcl next >
Text File  |  2001-06-14  |  8KB  |  240 lines
  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.3 2001/06/14 10:56:58 dkf 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)  -arrow last \
  37.         -width [expr {10*$v(width)}] -arrowshape [list \
  38.         [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]]} \
  39.         $v(bigLineStyle)
  40.     set xtip [expr {$v(x2)-10*$v(b)}]
  41.     set deltaY [expr {10*$v(c)+5*$v(width)}]
  42.     $c create line $v(x2) $v(y) $xtip [expr {$v(y)+$deltaY}] \
  43.         [expr {$v(x2)-10*$v(a)}] $v(y) $xtip [expr {$v(y)-$deltaY}] \
  44.         $v(x2) $v(y) -width 2 -capstyle round -joinstyle round
  45.  
  46.     # Create the boxes for reshaping the line and arrowhead.
  47.  
  48.     eval {$c create rect [expr {$v(x2)-10*$v(a)-5}] [expr {$v(y)-5}] \
  49.         [expr {$v(x2)-10*$v(a)+5}] [expr {$v(y)+5}] \
  50.         -tags {box1 box}} $v(boxStyle)
  51.     eval {$c create rect [expr {$xtip-5}] [expr {$v(y)-$deltaY-5}] \
  52.         [expr {$xtip+5}] [expr {$v(y)-$deltaY+5}] \
  53.         -tags {box2 box}} $v(boxStyle)
  54.     eval {$c create rect [expr {$v(x1)-5}] [expr {$v(y)-5*$v(width)-5}] \
  55.         [expr {$v(x1)+5}] [expr {$v(y)-5*$v(width)+5}] \
  56.         -tags {box3 box}} $v(boxStyle)
  57.     if {$cur != ""} {
  58.     eval $c itemconfigure $cur $v(activeStyle)
  59.     }
  60.  
  61.     # Create three arrows in actual size with the same parameters
  62.  
  63.     $c create line [expr {$v(x2)+50}] 0 [expr {$v(x2)+50}] 1000 \
  64.         -width 2
  65.     set tmp [expr {$v(x2)+100}]
  66.     $c create line $tmp [expr {$v(y)-125}] $tmp [expr {$v(y)-75}] \
  67.         -width $v(width) \
  68.         -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  69.     $c create line [expr {$tmp-25}] $v(y) [expr {$tmp+25}] $v(y) \
  70.         -width $v(width) \
  71.         -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  72.     $c create line [expr {$tmp-25}] [expr {$v(y)+75}] [expr {$tmp+25}] \
  73.         [expr {$v(y)+125}] -width $v(width) \
  74.         -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  75.  
  76.     # Create a bunch of other arrows and text items showing the
  77.     # current dimensions.
  78.  
  79.     set tmp [expr {$v(x2)+10}]
  80.     $c create line $tmp [expr {$v(y)-5*$v(width)}] \
  81.         $tmp [expr {$v(y)-$deltaY}] \
  82.         -arrow both -arrowshape $v(smallTips)
  83.     $c create text [expr {$v(x2)+15}] [expr {$v(y)-$deltaY+5*$v(c)}] \
  84.         -text $v(c) -anchor w
  85.     set tmp [expr {$v(x1)-10}]
  86.     $c create line $tmp [expr {$v(y)-5*$v(width)}] \
  87.         $tmp [expr {$v(y)+5*$v(width)}] \
  88.         -arrow both -arrowshape $v(smallTips)
  89.     $c create text [expr {$v(x1)-15}] $v(y) -text $v(width) -anchor e
  90.     set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+10}]
  91.     $c create line [expr {$v(x2)-10*$v(a)}] $tmp $v(x2) $tmp \
  92.         -arrow both -arrowshape $v(smallTips)
  93.     $c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+5}] \
  94.         -text $v(a) -anchor n
  95.     set tmp [expr {$tmp+25}]
  96.     $c create line [expr {$v(x2)-10*$v(b)}] $tmp $v(x2) $tmp \
  97.         -arrow both -arrowshape $v(smallTips)
  98.     $c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+5}] \
  99.         -text $v(b) -anchor n
  100.  
  101.     $c create text $v(x1) 310 -text "-width  $v(width)" \
  102.         -anchor w -font {Helvetica 18}
  103.     $c create text $v(x1) 330 -text "-arrowshape  {$v(a)  $v(b)  $v(c)}" \
  104.         -anchor w -font {Helvetica 18}
  105.  
  106.     incr v(count)
  107. }
  108.  
  109. set w .arrow
  110. global tk_library
  111. catch {destroy $w}
  112. toplevel $w
  113. wm title $w "Arrowhead Editor Demonstration"
  114. wm iconname $w "arrow"
  115. positionWindow $w
  116. set c $w.c
  117.  
  118. 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."
  119. pack $w.msg -side top
  120.  
  121. frame $w.buttons
  122. pack $w.buttons -side bottom -fill x -pady 2m
  123. button $w.buttons.dismiss -text Dismiss -command "destroy $w"
  124. button $w.buttons.code -text "See Code" -command "showCode $w"
  125. pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
  126.  
  127. canvas $c -width 500 -height 350 -relief sunken -borderwidth 2
  128. pack $c -expand yes -fill both
  129.  
  130. set demo_arrowInfo(a) 8
  131. set demo_arrowInfo(b) 10
  132. set demo_arrowInfo(c) 3
  133. set demo_arrowInfo(width) 2
  134. set demo_arrowInfo(motionProc) arrowMoveNull
  135. set demo_arrowInfo(x1) 40
  136. set demo_arrowInfo(x2) 350
  137. set demo_arrowInfo(y) 150
  138. set demo_arrowInfo(smallTips) {5 5 2}
  139. set demo_arrowInfo(count) 0
  140. if {[winfo depth $c] > 1} {
  141.     set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1"
  142.     set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
  143.     set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1"
  144. } else {
  145.     set demo_arrowInfo(bigLineStyle) "-fill black \
  146.     -stipple @[file join $tk_library demos images grey.25]"
  147.     set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
  148.     set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1"
  149. }
  150. arrowSetup $c
  151. $c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)"
  152. $c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
  153. $c bind box <B1-Enter> " "
  154. $c bind box <B1-Leave> " "
  155. $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1}
  156. $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2}
  157. $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3}
  158. $c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
  159. bind $c <Any-ButtonRelease-1> "arrowSetup $c"
  160.  
  161. # arrowMove1 --
  162. # This procedure is called for each mouse motion event on box1 (the
  163. # one at the vertex of the arrow).  It updates the controlling parameters
  164. # for the line and arrowhead.
  165. #
  166. # Arguments:
  167. # c -        The name of the canvas window.
  168. # x, y -    The coordinates of the mouse.
  169.  
  170. proc arrowMove1 {c x y} {
  171.     upvar #0 demo_arrowInfo v
  172.     set newA [expr {($v(x2)+5-round([$c canvasx $x]))/10}]
  173.     if {$newA < 0} {
  174.     set newA 0
  175.     }
  176.     if {$newA > 25} {
  177.     set newA 25
  178.     }
  179.     if {$newA != $v(a)} {
  180.     $c move box1 [expr {10*($v(a)-$newA)}] 0
  181.     set v(a) $newA
  182.     }
  183. }
  184.  
  185. # arrowMove2 --
  186. # This procedure is called for each mouse motion event on box2 (the
  187. # one at the trailing tip of the arrowhead).  It updates the controlling
  188. # parameters for the line and arrowhead.
  189. #
  190. # Arguments:
  191. # c -        The name of the canvas window.
  192. # x, y -    The coordinates of the mouse.
  193.  
  194. proc arrowMove2 {c x y} {
  195.     upvar #0 demo_arrowInfo v
  196.     set newB [expr {($v(x2)+5-round([$c canvasx $x]))/10}]
  197.     if {$newB < 0} {
  198.     set newB 0
  199.     }
  200.     if {$newB > 25} {
  201.     set newB 25
  202.     }
  203.     set newC [expr {($v(y)+5-round([$c canvasy $y])-5*$v(width))/10}]
  204.     if {$newC < 0} {
  205.     set newC 0
  206.     }
  207.     if {$newC > 20} {
  208.     set newC 20
  209.     }
  210.     if {($newB != $v(b)) || ($newC != $v(c))} {
  211.     $c move box2 [expr {10*($v(b)-$newB)}] [expr {10*($v(c)-$newC)}]
  212.     set v(b) $newB
  213.     set v(c) $newC
  214.     }
  215. }
  216.  
  217. # arrowMove3 --
  218. # This procedure is called for each mouse motion event on box3 (the
  219. # one that controls the thickness of the line).  It updates the
  220. # controlling parameters for the line and arrowhead.
  221. #
  222. # Arguments:
  223. # c -        The name of the canvas window.
  224. # x, y -    The coordinates of the mouse.
  225.  
  226. proc arrowMove3 {c x y} {
  227.     upvar #0 demo_arrowInfo v
  228.     set newWidth [expr {($v(y)+2-round([$c canvasy $y]))/5}]
  229.     if {$newWidth < 0} {
  230.     set newWidth 0
  231.     }
  232.     if {$newWidth > 20} {
  233.     set newWidth 20
  234.     }
  235.     if {$newWidth != $v(width)} {
  236.     $c move box3 0 [expr {5*($v(width)-$newWidth)}]
  237.     set v(width) $newWidth
  238.     }
  239. }
  240.