diff options
Diffstat (limited to 'library/demos/arrow.tcl')
| -rw-r--r-- | library/demos/arrow.tcl | 145 |
1 files changed, 82 insertions, 63 deletions
diff --git a/library/demos/arrow.tcl b/library/demos/arrow.tcl index 3d0b406..5674be9 100644 --- a/library/demos/arrow.tcl +++ b/library/demos/arrow.tcl @@ -9,6 +9,16 @@ if {![info exists widgetDemo]} { package require Tk +# scl -- +# Scales an integer according to the display's current scaling percentage. +# +# Arguments: +# num - An integer. + +proc scl num { + return [expr {round($num*$tk::scalingPct/100.0)}] +} + # arrowSetup -- # This procedure regenerates all the text and graphics in the canvas # window. It's called when the canvas is initially created, and also @@ -33,74 +43,78 @@ proc arrowSetup c { # Create the arrow and outline. $c delete all - eval {$c create line $v(x1) $v(y) $v(x2) $v(y) -arrow last \ + $c create line $v(x1) $v(y) $v(x2) $v(y) -arrow last \ -width [expr {10*$v(width)}] -arrowshape [list \ - [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]]} \ - $v(bigLineStyle) + [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]] \ + {*}$v(bigLineStyle) set xtip [expr {$v(x2)-10*$v(b)}] set deltaY [expr {10*$v(c)+5*$v(width)}] $c create line $v(x2) $v(y) $xtip [expr {$v(y)+$deltaY}] \ [expr {$v(x2)-10*$v(a)}] $v(y) $xtip [expr {$v(y)-$deltaY}] \ - $v(x2) $v(y) -width 2 -capstyle round -joinstyle round + $v(x2) $v(y) -width 1.5p -capstyle round -joinstyle round # Create the boxes for reshaping the line and arrowhead. - eval {$c create rect [expr {$v(x2)-10*$v(a)-5}] [expr {$v(y)-5}] \ - [expr {$v(x2)-10*$v(a)+5}] [expr {$v(y)+5}] \ - -tags {box1 box}} $v(boxStyle) - eval {$c create rect [expr {$xtip-5}] [expr {$v(y)-$deltaY-5}] \ - [expr {$xtip+5}] [expr {$v(y)-$deltaY+5}] \ - -tags {box2 box}} $v(boxStyle) - eval {$c create rect [expr {$v(x1)-5}] [expr {$v(y)-5*$v(width)-5}] \ - [expr {$v(x1)+5}] [expr {$v(y)-5*$v(width)+5}] \ - -tags {box3 box}} $v(boxStyle) + set _5 [scl 5] + $c create rect [expr {$v(x2)-10*$v(a)-$_5}] [expr {$v(y)-$_5}] \ + [expr {$v(x2)-10*$v(a)+$_5}] [expr {$v(y)+$_5}] \ + -tags {box1 box} {*}$v(boxStyle) + $c create rect [expr {$xtip-$_5}] [expr {$v(y)-$deltaY-$_5}] \ + [expr {$xtip+$_5}] [expr {$v(y)-$deltaY+$_5}] \ + -tags {box2 box} {*}$v(boxStyle) + $c create rect [expr {$v(x1)-$_5}] [expr {$v(y)-5*$v(width)-$_5}] \ + [expr {$v(x1)+$_5}] [expr {$v(y)-5*$v(width)+$_5}] \ + -tags {box3 box} {*}$v(boxStyle) if {$cur != ""} { - eval $c itemconfigure $cur $v(activeStyle) + $c itemconfigure $cur {*}$v(activeStyle) } - # Create three arrows in actual size with the same parameters - - $c create line [expr {$v(x2)+50}] 0 [expr {$v(x2)+50}] 1000 \ - -width 2 - set tmp [expr {$v(x2)+100}] - $c create line $tmp [expr {$v(y)-125}] $tmp [expr {$v(y)-75}] \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr {$tmp-25}] $v(y) [expr {$tmp+25}] $v(y) \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr {$tmp-25}] [expr {$v(y)+75}] [expr {$tmp+25}] \ - [expr {$v(y)+125}] -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" + # Create three arrows in actual size with the same parameters. + + set _10 [scl 10] + set _15 [scl 15] + set _25 [scl 25] + set _50 [scl 50] + set _75 [scl 75] + set _125 [scl 125] + $c create line [expr {$v(x2)+$_50}] 0 [expr {$v(x2)+$_50}] 750p -width 1.5p + set tmp [expr {$v(x2)+[scl 100]}] + $c create line $tmp [expr {$v(y)-$_125}] $tmp [expr {$v(y)-$_75}] \ + -width $v(width) -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr {$tmp-$_25}] $v(y) [expr {$tmp+$_25}] $v(y) \ + -width $v(width) -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr {$tmp-$_25}] [expr {$v(y)+$_75}] \ + [expr {$tmp+$_25}] [expr {$v(y)+$_125}] \ + -width $v(width) -arrow both -arrowshape "$v(a) $v(b) $v(c)" # Create a bunch of other arrows and text items showing the # current dimensions. - set tmp [expr {$v(x2)+10}] + set tmp [expr {$v(x2)+$_10}] $c create line $tmp [expr {$v(y)-5*$v(width)}] \ $tmp [expr {$v(y)-$deltaY}] \ -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)+15}] [expr {$v(y)-$deltaY+5*$v(c)}] \ + $c create text [expr {$v(x2)+$_15}] [expr {$v(y)-$deltaY+5*$v(c)}] \ -text $v(c) -anchor w - set tmp [expr {$v(x1)-10}] + set tmp [expr {$v(x1)-$_10}] $c create line $tmp [expr {$v(y)-5*$v(width)}] \ $tmp [expr {$v(y)+5*$v(width)}] \ -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x1)-15}] $v(y) -text $v(width) -anchor e - set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+10}] + $c create text [expr {$v(x1)-$_15}] $v(y) -text $v(width) -anchor e + set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+$_10}] $c create line [expr {$v(x2)-10*$v(a)}] $tmp $v(x2) $tmp \ -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+5}] \ + $c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+$_5}] \ -text $v(a) -anchor n - set tmp [expr {$tmp+25}] + set tmp [expr {$tmp+$_25}] $c create line [expr {$v(x2)-10*$v(b)}] $tmp $v(x2) $tmp \ -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+5}] \ + $c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+$_5}] \ -text $v(b) -anchor n - $c create text $v(x1) 310 -text "-width $v(width)" \ + $c create text $v(x1) 232.5p -text "-width $v(width)" \ -anchor w -font {Helvetica 18} - $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ + $c create text $v(x1) 247.5p -text "-arrowshape {$v(a) $v(b) $v(c)}" \ -anchor w -font {Helvetica 18} incr v(count) @@ -121,18 +135,18 @@ pack $w.msg -side top set btns [addSeeDismiss $w.buttons $w] pack $btns -side bottom -fill x -canvas $c -width 500 -height 350 -relief sunken -borderwidth 2 +canvas $c -width 375p -height 262.5p -relief sunken -borderwidth 2 pack $c -expand yes -fill both -set demo_arrowInfo(a) 8 -set demo_arrowInfo(b) 10 -set demo_arrowInfo(c) 3 -set demo_arrowInfo(width) 2 +set demo_arrowInfo(a) [scl 8] +set demo_arrowInfo(b) [scl 10] +set demo_arrowInfo(c) [scl 3] +set demo_arrowInfo(width) [scl 2] set demo_arrowInfo(motionProc) arrowMoveNull -set demo_arrowInfo(x1) 40 -set demo_arrowInfo(x2) 350 -set demo_arrowInfo(y) 150 -set demo_arrowInfo(smallTips) {5 5 2} +set demo_arrowInfo(x1) [scl 40] +set demo_arrowInfo(x2) [scl 350] +set demo_arrowInfo(y) [scl 150] +set demo_arrowInfo(smallTips) {3.75p 3.75p 1.5p} set demo_arrowInfo(count) 0 if {[winfo depth $c] > 1} { if {[tk windowingsystem] eq "aqua"} { @@ -140,14 +154,14 @@ if {[winfo depth $c] > 1} { } else { set demo_arrowInfo(bigLineStyle) "-fill LightSeaGreen" } - set demo_arrowInfo(boxStyle) "-fill {} -width 1" - set demo_arrowInfo(activeStyle) "-fill red -width 1" + set demo_arrowInfo(boxStyle) "-fill {} -width 0.75p" + set demo_arrowInfo(activeStyle) "-fill red -width 0.75p" } else { # Main widget program sets variable tk_demoDirectory set demo_arrowInfo(bigLineStyle) "-fill black \ -stipple @[file join $tk_demoDirectory images grey.25]" - set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" - set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1" + set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 0.75p" + set demo_arrowInfo(activeStyle) "-fill black -outline black -width 0.75p" } arrowSetup $c $c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)" @@ -171,12 +185,13 @@ bind $c <ButtonRelease-1> "arrowSetup $c" proc arrowMove1 {c x y} { upvar #0 demo_arrowInfo v - set newA [expr {($v(x2)+5-round([$c canvasx $x]))/10}] + set newA [expr {($v(x2)+[scl 5]-round([$c canvasx $x]))/10}] if {$newA < 0} { set newA 0 } - if {$newA > 25} { - set newA 25 + set _25 [scl 25] + if {$newA > $_25} { + set newA $_25 } if {$newA != $v(a)} { $c move box1 [expr {10*($v(a)-$newA)}] 0 @@ -195,19 +210,22 @@ proc arrowMove1 {c x y} { proc arrowMove2 {c x y} { upvar #0 demo_arrowInfo v - set newB [expr {($v(x2)+5-round([$c canvasx $x]))/10}] + set _5 [scl 5] + set newB [expr {($v(x2)+$_5-round([$c canvasx $x]))/10}] if {$newB < 0} { set newB 0 } - if {$newB > 25} { - set newB 25 + set _25 [scl 25] + if {$newB > $_25} { + set newB $_25 } - set newC [expr {($v(y)+5-round([$c canvasy $y])-5*$v(width))/10}] + set newC [expr {($v(y)+$_5-round([$c canvasy $y])-5*$v(width))/10}] if {$newC < 0} { set newC 0 } - if {$newC > 20} { - set newC 20 + set _20 [scl 20] + if {$newC > $_20} { + set newC $_20 } if {($newB != $v(b)) || ($newC != $v(c))} { $c move box2 [expr {10*($v(b)-$newB)}] [expr {10*($v(c)-$newC)}] @@ -227,12 +245,13 @@ proc arrowMove2 {c x y} { proc arrowMove3 {c x y} { upvar #0 demo_arrowInfo v - set newWidth [expr {($v(y)+2-round([$c canvasy $y]))/5}] + set newWidth [expr {($v(y)+[scl 2]-round([$c canvasy $y]))/5}] if {$newWidth < 0} { set newWidth 0 } - if {$newWidth > 20} { - set newWidth 20 + set _20 [scl 20] + if {$newWidth > $_20} { + set newWidth $_20 } if {$newWidth != $v(width)} { $c move box3 0 [expr {5*($v(width)-$newWidth)}] |