aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl218
-rw-r--r--Perl/demos/zinc-demos7
2 files changed, 222 insertions, 3 deletions
diff --git a/Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl b/Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl
new file mode 100644
index 0000000..e6fbb4b
--- /dev/null
+++ b/Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl
@@ -0,0 +1,218 @@
+#!/usr/bin/perl
+# $Id$
+# this simple sample has been developped by C. Mertz mertz@cena.fr
+
+use Tk;
+use Tk::Zinc;
+use Tk::Checkbutton;
+use Tk::Label;
+use strict;
+
+package atomic_groups;
+
+my $defaultfont = '-adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-*';
+my $mw = MainWindow->new();
+my $zinc = $mw->Zinc(-width => 500, -height => 350,
+ -font => "10x20", # usually fonts are sets in resources
+ # but for this example it is set in the code!
+ -borderwidth => 0,
+ )->pack;
+
+
+my $groups_group_atomicity = 0;
+my $red_group_atomicity = 0;
+my $green_group_atomicity = 0;
+
+my $display_clipping_item_background = 0;
+my $clip = 1;
+
+$zinc->add('text', 1,
+ -font => $defaultfont,
+ -text =>
+ "- There are 3 groups: a red group containing 2 redish objects,\n".
+ "a green group containing 2 greenish objects,\n".
+ "and groups_group containing both previous groups.\n".
+ "- You can make some groups atomic or not by depressing \n".
+ "the toggle buttons at the bottom of the window\n".
+ "- Try and then click on some items to observe that callbacks\n".
+ " are then different: they modify either the item, or 2 items of\n".
+ " a group or all items",
+ -anchor => 'nw',
+ -position => [10, 10]);
+
+
+############### creating the top group with its bindings ###############################
+my $groups_group = $zinc->add('group', 1, -visible => 1,
+ -atomic => $groups_group_atomicity,
+ -tags => [ 'groups_group' ]);
+
+# the following callbacks will be called only if 'groups_group' IS atomic
+$zinc->bind($groups_group, '<1>', \&modify_bitmap_bg);
+$zinc->bind($groups_group, '<ButtonRelease-1>', \&modify_bitmap_bg);
+
+############### creating the red_group, with its binding and its content ################
+# the red_group may be atomic, that is is makes all children as a single object
+# and sensitive to red_group callbacks
+my $red_group = $zinc->add('group', $groups_group,
+ -visible => 1,
+ -atomic => $red_group_atomicity,
+ -sensitive => 1,
+ -tags => ['red_group'],
+ );
+# the following callbacks will be called only if 'groups_group' IS NOT-atomic
+# and if 'red_group' IS atomic
+$zinc->bind($red_group, '<1>', sub { &modify_item_lines($red_group)} );
+$zinc->bind($red_group, '<ButtonRelease-1>', sub { &modify_item_lines($red_group)} );
+
+
+my $rc = $zinc->add('arc', $red_group,
+ [100, 200, 140, 240],
+ -filled => 1, -fillcolor => "red2",
+ -linewidth => 3, -linecolor => "white",
+ -tags => [ 'red_circle' ],
+ );
+
+my $rr = $zinc->add('rectangle', $red_group,
+ [300, 200, 400,250],
+ -filled => 1, -fillcolor => "red2",
+ -linewidth => 3, -linecolor => "white",
+ -tags => [ 'red_rectangle' ],
+ );
+# the following callbacks will be called only if 'groups_group' IS NOT atomic
+# and if 'red_group' IS NOT atomic
+$zinc->bind($rc, '<1>', \&toggle_color);
+$zinc->bind($rc, '<ButtonRelease-1>', \&toggle_color);
+$zinc->bind($rr, '<1>', \&toggle_color);
+$zinc->bind($rr, '<ButtonRelease-1>', \&toggle_color);
+
+############### creating the green_group, with its binding and its content ################
+# the green_group may be atomic, that is is makes all children as a single object
+# and sensitive to green_group callbacks
+my $green_group = $zinc->add('group', $groups_group,
+ -visible => 1,
+ -atomic => $green_group_atomicity,
+ -sensitive => 1,
+ -tags => ['green_group'],
+ );
+# the following callbacks will be called only if 'groups_group' IS NOT atomic
+# and if 'green_group' IS atomic
+$zinc->bind($green_group, '<1>', sub { &modify_item_lines($green_group) } );
+$zinc->bind($green_group, '<ButtonRelease-1>', sub { &modify_item_lines($green_group) } );
+
+my $gc = $zinc->add('arc', $green_group,
+ [100,270, 140,310],
+ -filled => 1, -fillcolor => "green2",
+ -linewidth => 3, -linecolor => "white",
+ -tags => [ 'green_circle' ],
+ );
+
+my $gr = $zinc->add('rectangle', $green_group,
+ [300,270, 400,320],
+ -filled => 1, -fillcolor => "green2",
+ -linewidth => 3, -linecolor => "white",
+ -tags => [ 'green_rectangle' ],
+ );
+# the following callbacks will be called only if 'groups_group' IS NOT atomic
+# and if 'green_group' IS NOT atomic
+$zinc->bind($gc, '<1>', \&toggle_color);
+$zinc->bind($gc, '<ButtonRelease-1>', \&toggle_color);
+$zinc->bind($gr, '<1>', \&toggle_color);
+$zinc->bind($gr, '<ButtonRelease-1>', \&toggle_color);
+
+
+
+my $current_bg = '';
+###################### groups_group callback ##############
+sub modify_bitmap_bg {
+ if ($current_bg eq 'AlphaStipple2') {
+ $current_bg = '';
+ }
+ else {
+ $current_bg = 'AlphaStipple2';
+ }
+ foreach my $item ($rc, $rr, $gc, $gr) {
+ $zinc->itemconfigure($item, -fillpattern => $current_bg);
+ }
+}
+
+#################### red/green_group callback ##############
+sub modify_item_lines {
+ my ($gr) = @_;
+ my @children = $zinc->find('withtag', ".$gr*"); # we are using a pathtag (still undocumented feature of 3.2.6) to get items of an atomic group!
+ # we could also temporary modify the groups (make it un-atomic) to get its child
+
+ my $current_linewidth = $zinc->itemcget($children[0], -linewidth);
+ if ($current_linewidth == 3) {
+ $current_linewidth = 0;
+ }
+ else {
+ $current_linewidth = 3;
+ }
+ foreach my $item (@children) {
+ $zinc->itemconfigure($item, -linewidth => $current_linewidth);
+ }
+
+}
+
+
+##################### items callback ######################
+sub toggle_color {
+ my $item = $zinc->find('withtag', 'current');
+ my $fillcolor = $zinc->itemcget($item, -fillcolor);
+ my ($color,$num) = $fillcolor =~ /([a-z]+)(\d)/ ;
+ if ($num == 2) {
+ $num = 4;
+ }
+ else {
+ $num = 2;
+ }
+ $zinc->itemconfigure($item, -fillcolor => "$color$num");
+}
+
+
+###################### toggle buttons at the bottom #######
+my $row = $mw->Frame()->pack();
+$row->Checkbutton(-text => 'groups_group is atomic',
+ -variable => \$groups_group_atomicity,
+ -command => sub { &atomic_or_not ($groups_group, \$groups_group_atomicity) },
+ )->pack(-anchor => 'w');
+
+$row->Checkbutton(-text => 'red group is atomic ',
+ -foreground => "red4",
+ -variable => \$red_group_atomicity,
+ -command => sub { &atomic_or_not ($red_group, \$red_group_atomicity) },
+ )->pack(-anchor => 'w');
+
+$row->Checkbutton(-text => 'green group is atomic ',
+ -foreground => "green4",
+ -variable => \$green_group_atomicity,
+ -command => sub { &atomic_or_not ($green_group, \$green_group_atomicity) },
+ )->pack(-anchor => 'w');
+$row->Label()->pack(-anchor => 'w');
+$row->Label(-text => "Following command \"\$zinc->find('overlapping', 0,200,500,400)\" returns:")->pack(-anchor => 'w');
+my $label = $row->Label(-background => 'gray95')->pack(-anchor => 'w');
+
+
+sub atomic_or_not {
+ my ($gr,$ref_atomic) = @_;
+ my $atomic = ${$ref_atomic};
+ $zinc->itemconfigure( $gr, -atomic => $atomic);
+ &update_found_items;
+}
+
+##### to update the list of enclosed items
+sub update_found_items {
+ $zinc->update; # to be sure eveyrthing has been updated inside zinc!
+ my @found = $zinc->find('overlapping', 0,200,500,400);
+ my $str = "";
+ foreach my $item (@found) {
+ my @tags = $zinc->itemcget($item, -tags);
+ $str .= " " . $tags[0];
+ }
+ $label->configure (-text => $str);
+}
+
+# to init the list of enclosed items
+&update_found_items;
+
+Tk::MainLoop;
diff --git a/Perl/demos/zinc-demos b/Perl/demos/zinc-demos
index 3fe0d79..8d0c5e1 100644
--- a/Perl/demos/zinc-demos
+++ b/Perl/demos/zinc-demos
@@ -161,9 +161,10 @@ $T->insert('end', "6. Use of mapinfos.\n", [qw/demo demo-mapinfo/]);
$T->insert('end', "\n", '', "Groups, Priority and Clipping\n", 'title');
$T->insert('end', "1. Groups and Priorities.\n", [qw/demo demo-groups_priority/]);
$T->insert('end', "2. Clipping examples (with simple or multiple contours).\n", [qw/demo demo-clipping/]);
-$T->insert('end', "3. \"Windows\" with four glasses using curve with multiple contours.\n", [qw/demo demo-window-contours/]);
-$T->insert('end', "4. A counter quite impossible to do without clipping (needs openGL).\n", [qw/demo demo-counter/]);
-$T->insert('end', "5. Use of path tags... to come.\n");
+$T->insert('end', "3. Group atomicity.\n", [qw/demo demo-atomic-groups/]);
+$T->insert('end', "4. \"Windows\" with four glasses using curve with multiple contours.\n", [qw/demo demo-window-contours/]);
+$T->insert('end', "5. A counter quite impossible to do without clipping (needs openGL).\n", [qw/demo demo-counter/]);
+$T->insert('end', "6. Use of path tags... to come.\n");
$T->insert('end', "\n", '', "Interactions\n", 'title');
$T->insert('end', "1. Simple interaction on a track.\n", [qw/demo demo-simple_interaction_track/]);