From 24df859cbc6bb1661abfa7bbe52cfc3dd1b14120 Mon Sep 17 00:00:00 2001
From: lecoanet
Date: Wed, 12 Jan 2000 13:56:36 +0000
Subject: *** empty log message ***

---
 sandbox/testpoly.tcl | 149 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 149 insertions(+)
 create mode 100644 sandbox/testpoly.tcl

(limited to 'sandbox/testpoly.tcl')

diff --git a/sandbox/testpoly.tcl b/sandbox/testpoly.tcl
new file mode 100644
index 0000000..0341bf9
--- /dev/null
+++ b/sandbox/testpoly.tcl
@@ -0,0 +1,149 @@
+#!/usr/bin/wish -f
+
+load tkradar3.1.so
+package require Img
+
+set top 1
+set lw 8
+set marker AtcSymbol9
+set arrow "8 10 6"
+
+
+#
+#  Cap        Join   Filled Border Relief Title
+#
+set show {\
+  {round      round  f      t      flat   JoinRound}\
+  {round      bevel  f      t      flat   JoinBevel}\
+  {round      miter  f      t      flat   JoinMiter}\
+  {butt       round  f      t      flat   CapButt}\
+  {projecting round  f      t      flat   CapProjecting}\
+  {round      round  f      t      sunken Sunken}\
+  {round      round  f      t      raised Raised}\
+  {round      round  f      t      groove Groove}\
+  {round      round  f      t      ridge  Ridge}\
+  {round      round  t      t      sunken FilledSunken}\
+  {round      round  t      t      raised FilledRaised}\
+  {round      round  t      t      groove FilledGroove}\
+  {round      round  t      t      ridge  FilledRidge}\
+  {round      round  f      f      flat   Marker}\
+  {round      round  t      f      flat   Fill}\
+  {round      round  t      t      flat   FillBorder}}
+
+image create photo logo -file /usr/share/toccata/images/logo.gif
+#image create photo papier -file /usr/share/toccata/images/dgtexture-dragstrip.xpm
+
+set r [radar .r -backcolor gray -relief sunken]
+pack .r -expand t -fill both
+.r configure -width 1024 -height 800
+.r scale $top 1 -1
+#.r configure -drawbboxes t
+set view [.r add group $top -tags controls]
+
+#
+# Create the model
+#
+set model [.r add group $view]
+set mp [.r add curve $model "50 -150 100 -50 270 -130 220 -200 200 -180 180 -300 140 -160 70 -300" \
+	    -linecolor yellow -fillcolor tan -fillpattern AlphaStipple8 \
+	    -markercolor red -tags "poly" -linewidth $lw]
+set bbox [.r transform $model [.r bbox $mp]]
+set x [expr ([lindex $bbox 2] + [lindex $bbox 0]) / 2]
+set y [expr [lindex $bbox 1] + 5]
+.r add text $model -text "CapRound" -color blue -alignment center -anchor s -tags "title" \
+    -position "$x $y"
+
+#
+# Now clone for each variation on the polygon
+#
+set col 0
+set row 0
+foreach current $show {
+    foreach {cap join filled border relief title} $current {
+	set grp [.r clone $model]
+	.r translate $grp [expr $col * 240] [expr $row * (-290 - (2 * $lw))]
+	.r itemconfigure [.r find withtag "poly" $grp] \
+	    -capstyle $cap -joinstyle $join -filled $filled \
+	    -linewidth [expr $border ? $lw : 0] -relief $relief
+	.r itemconfigure [.r find withtag "title" $grp] -text $title
+	incr col
+	if {$col >= 4} {
+	    set col 0
+	    incr row
+	}
+    }
+}
+
+#
+# Suppress the model
+#
+.r remove $model
+
+
+#
+# Some optional graphic features
+set closed 0
+set marks 0
+set smooth 0
+set arrows none
+
+proc toggle_arrows { } {
+    global arrows arrow
+    if {$arrows == "none"} {
+	set arrows first
+	set f $arrow
+	set l ""
+    } elseif {$arrows == "first"} {
+	set arrows last
+	set f ""
+	set l $arrow
+    } elseif {$arrows == "last"} {
+	set arrows both
+	set f $arrow
+	set l $arrow
+    } elseif {$arrows == "both"} {
+	set arrows none
+	set f ""
+	set l ""
+    }
+    .r itemconfigure poly -firstend $f -lastend $l
+}
+
+proc toggle_marks { } {
+    global marks marker
+    set marks [expr ! $marks]
+    if {$marks} {
+	.r itemconfigure poly -marker $marker
+    } {
+	.r itemconfigure poly -marker ""
+    }
+}
+
+proc toggle_smooth { } {
+    global smooth
+    set smooth [expr ! $smooth]
+    .r itemconfigure poly -smoothed $smooth
+}
+
+proc toggle_closed { } {
+    global closed
+    set closed [expr ! $closed]
+    foreach curve [.r find withtag "poly"] {
+	if {$closed} {
+	    .r coords $curve add [.r coords $curve 0]
+	} {
+	    .r coords $curve remove -1
+	}
+    }
+	
+}
+
+focus .r
+
+bind .r "<a>" toggle_arrows
+bind .r "<c>" toggle_closed
+bind .r "<m>" toggle_marks
+bind .r "<s>" toggle_smooth
+
+
+source "controls.tcl"
-- 
cgit v1.1