Portage depuis perl

1 files changed, 118 insertions, 0 deletions

diff --git a/demos/clipping.tcl b/demos/clipping.tcl
new file mode 100644
index 0000000..53a357e
--- /dev/null
+++ b/demos/clipping.tcl
@@ -0,0 +1,118 @@
+# these simple samples have been developped by C. Mertz mertz@cena.fr in perl
+# tcl version by Jean-Paul Imbert imbert@cena.fr
+
+if {![info exists zincDemo]} {
+    error "This script should be run from the zinc-widget demo."
+}
+
+set w .clipping
+catch {destroy $w}
+toplevel $w
+wm title $w "Zinc Clipping Demonstration"
+wm iconname $w "Clipping"
+
+set  defaultfont  "-adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-*"
+
+frame $w.buttons
+pack $w.buttons -side bottom -fill x -pady 2m
+button $w.buttons.dismiss -text Dismiss -command "destroy $w"
+button $w.buttons.code -text "See Code" -command "showCode $w"
+pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
+
+
+zinc $w.zinc -width 700 -height 600 -font 10x20 -borderwidth 3 -relief sunken
+pack $w.zinc
+
+set display_clipping_item_background   0
+set clip   1
+
+$w.zinc add text 1 -font $defaultfont -text "You can drag and drop the objects.\nThere are two groups of objects a tan group and a blue group\nTry to move them and discover the clipping area which is a curve.\nwith two contours" -anchor nw -position {10 10}
+
+
+set clipped_group [$w.zinc add group 1 -visible 1]
+
+set clipping_item  [$w.zinc add curve $clipped_group {10 100 690 100 690 590 520 350 350 590 180 350 10 590} -closed 1 -priority 1 -fillcolor tan2 -linewidth 0 -filled $display_clipping_item_background]
+$w.zinc contour $clipping_item add +1 {200 200 500 200 500 250 200 250}
+
+############### creating the tan_group objects ################
+# the tan_group is atomic  that is is makes all children as a single object
+# and sensitive to tan_group callbacks
+set tan_group [$w.zinc add group $clipped_group -visible 1 -atomic 1 -sensitive 1]
+			   
+
+$w.zinc add arc $tan_group {200 220 280 300} -filled 1 -linewidth 1 -startangle 45 -extent 270 -pieslice 1 -closed 1 -fillcolor tan
+	   
+
+$w.zinc add curve $tan_group {400 400 440 450 400 500 500 500 460 450 500 400} -filled 1 -fillcolor tan -linecolor tan
+	   
+
+############### creating the blue_group objects ################
+# the blue_group is atomic too  that is is makes all children as a single object
+# and sensitive to blue_group callbacks
+set blue_group   [$w.zinc add group $clipped_group -visible 1 -atomic 1 -sensitive 1]
+
+$w.zinc add rectangle $blue_group {570 180   470 280} -filled 1 -linewidth 1 -fillcolor blue2
+
+$w.zinc add curve $blue_group {200 400 200 500 300 500 300 400 300 300} -filled 1 -fillcolor blue -linewidth 0
+
+
+$w.zinc itemconfigure $clipped_group -clip  $clipping_item
+
+
+###################### drag and drop callbacks ############
+# for both tan_group and blue_group
+
+$w.zinc bind $tan_group <1> "itemStartDrag $tan_group %x %y" 
+$w.zinc bind $tan_group <B1-Motion> "itemDrag $tan_group %x %y"
+$w.zinc bind $blue_group <1> "itemStartDrag $blue_group %x %y" 
+$w.zinc bind $blue_group <B1-Motion> "itemDrag $blue_group %x %y"
+
+
+
+# callback for starting a drag
+set x_orig ""
+set y_orig ""
+
+proc itemStartDrag {item x y} {
+    global x_orig y_orig
+    set x_orig $x
+    set y_orig $y
+}
+
+# Callback for moving an item
+proc itemDrag {item x y} {
+    global x_orig y_orig
+    global w
+    $w.zinc translate $item  [expr $x-$x_orig] [expr $y-$y_orig];
+    set x_orig  $x;
+    set y_orig  $y;
+}
+
+
+
+###################### toggle buttons at the bottom #######
+frame $w.row
+pack $w.row
+checkbutton $w.row.show -text "Show clipping item" -variable display_clipping_item_background -command "display_clipping_area"
+checkbutton $w.row.clip -text Clip -variable clip -command "clipcommand "
+pack $w.row.show $w.row.clip
+
+proc display_clipping_area {} {
+    global clipping_item
+    global w
+    global display_clipping_item_background
+    $w.zinc itemconfigure $clipping_item -filled  $display_clipping_item_background
+}
+
+proc clipcommand {} {
+    global clip
+    global clipped_group
+    global clipping_item
+    global w
+
+    if {$clip} {
+	$w.zinc itemconfigure $clipped_group -clip  $clipping_item
+    } else {
+	$w.zinc itemconfigure $clipped_group -clip ""
+    }
+}