aboutsummaryrefslogtreecommitdiff
path: root/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl/demos/Tk/demos/zinc_lib/groups_priority.pl')
-rw-r--r--Perl/demos/Tk/demos/zinc_lib/groups_priority.pl261
1 files changed, 0 insertions, 261 deletions
diff --git a/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl b/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl
deleted file mode 100644
index e7f872d..0000000
--- a/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl
+++ /dev/null
@@ -1,261 +0,0 @@
-#!/usr/bin/perl -w
-# $Id$
-# This simple demo has been developped by C. Mertz <mertz@cena.fr>
-
-package groups_priority; # for avoiding symbol sharing between different demos
-
-use vars qw( $VERSION );
-($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/);
-
-use Tk;
-use Tk::Zinc;
-
-use strict;
-
-my $mw = MainWindow->new();
-
-# The explanation displayed when running this demo
-my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2,
- -height => 12);
-$text->pack(qw/-expand yes -fill both/);
-
-$text->insert('0.0',
-'There are two groups (a red one and a green one) each containing
- 4 rectangles. Those rectangles display their current priority.
-The following operations are possible:
- "Mouse Button 1" for dragging objects.
- "Mouse Button 2" for dragging a colored group.
- "Key +" on a rectangle to raise it inside its group.
- "Key -" on a rectangle to lower it inside its group.
- "Key l" on a rectangle to lower its colored group.
- "Key r" on a rectangle to raise its colored group.
- "Key t" on a rectangle to change its group (but not its color!).
- "Key [0-9] on a rectangle to set the priority to [0-9]
-Raising or lowering an item inside a group modify its priority if necessary');
-
-# Creating the zinc widget
-my $zinc = $mw->Zinc(-width => 600, -height => 500,
- -font => "10x20", # usually fonts are sets in resources
- # but for this example it is set in the code!
- -borderwidth => 3, -relief => 'sunken',
- )->pack;
-
-#########################################################################"
-# Creating the redish group
-my $group1 = $zinc->add('group', 1, -visible => 1);
-
-my $counter=0;
-# Adding 4 rectangles with text to redish group
-foreach my $data ( [200,100, 'red'], [210,210,'red1'],
- [390,110,'red2'], [395,215,'red3'] ) {
- $counter += 2;
- my ($centerx,$centery,$color) = @{$data};
- # this small group is for merging together :
- # the rectangle and the text showing its name
- my $g = $zinc->add('group', $group1,
- -visible => 1,
- -atomic => 1,
- -sensitive => 1,
- -priority => $counter,
- );
- my $rec = $zinc->add('rectangle', $g, [$centerx-100,$centery-60,
- $centerx+100, $centery+60],
- -fillcolor => $color, -filled => 1,
- );
- my $txt = $zinc->add('text', $g,
- -position => [$centerx,$centery],
- -text => "pri=$counter",
- -anchor => 'center',
- );
- # Some bindings for dragging the rectangle or the full group
- $zinc->bind($g, '<ButtonPress-1>' => [\&press, $g, \&motion]);
- $zinc->bind($g, '<ButtonRelease-1>' => \&release);
- $zinc->bind($g, '<ButtonPress-2>' => [\&press, $g, \&groupMotion]);
- $zinc->bind($g, '<ButtonRelease-2>' => \&release);
-}
-
-#########################################################################"
-# Creating the greenish group
-my $group2 = $zinc->add('group', 1, -visible => 1);
-$counter=0;
-
-# Adding 4 rectangles with text to greenish group
-foreach my $data ( [200,300,'green1'], [210,410,'green2'],
- [390,310,'green3'], [395,415,'green4'] ) {
- $counter++;
- my ($centerx,$centery,$color) = @{$data};
- # this small group is for merging together a rectangle
- # and the text showing its priority
- my $g = $zinc->add('group', $group2,
- -atomic => 1,
- -sensitive => 1,
- -priority => $counter,
- );
- my $rec = $zinc->add('rectangle', $g, [$centerx-100,$centery-60,
- $centerx+100, $centery+60],
- -fillcolor => $color, -filled => 1,
- );
- my $txt = $zinc->add('text', $g,
- -position => [$centerx,$centery],
- -text => "pri=$counter",
- -anchor => 'center',
- );
- # Some bindings for dragging the rectangle or the full group
- $zinc->bind($g, '<ButtonPress-1>' => [\&press, $g, \&motion]);
- $zinc->bind($g, '<ButtonRelease-1>' => \&release);
- $zinc->bind($g, '<ButtonPress-2>' => [\&press, $g, \&groupMotion]);
- $zinc->bind($g, '<ButtonRelease-2>' => \&release);
-}
-
-
-#########################################################################"
-# adding the key bindings
-
-# the focus on the widget is ABSOLUTELY necessary for key bindings!
-$zinc->Tk::focus();
-
-$zinc->Tk::bind('<KeyPress-r>' => \&raiseGroup);
-$zinc->Tk::bind('<KeyPress-l>' => \&lowerGroup);
-$zinc->Tk::bind('<KeyPress-plus>' => \&raise);
-$zinc->Tk::bind('<KeyPress-KP_Add>' => \&raise);
-$zinc->Tk::bind('<KeyPress-minus>' => \&lower);
-$zinc->Tk::bind('<KeyPress-KP_Subtract>' => \&lower);
-$zinc->Tk::bind('<KeyPress-t>' => \&toggleItemGroup);
-
-my @KP_MAPPINGS = qw (Insert End Down Next Left Begin Right Home Up Prior);
-
-for my $i (0..9) {
- $zinc->Tk::bind("<KeyPress-$i>" => [\&setPriorrity, $i]);
- my $code = $KP_MAPPINGS[$i];
- $zinc->Tk::bind("<KeyPress-KP_$code>" => [\&setPriorrity, $i]);
-}
-
-# The following binding is currently not possible; only text items
-# with focus can get a KeyPress or KeyRelease event
-# $zinc->bind($g, '<KeyPress>' => [\&raise, $g]);
-
-#########################################################################"
-# Definition of all callbacks
-
-sub updateLabel {
- my ($group) = @_;
- my $priority = $zinc->itemcget($group, -priority);
- # we get the text item from this group:
- my $textitem = $zinc->find('withtype', 'text', ".$group.");
- $zinc->itemconfigure($textitem, -text => "pri=$priority");
-}
-
-sub setPriorrity {
- my ($zinc, $priority) = @_;
- my $item = $zinc->find('withtag', 'current');
- return unless $item;
- $zinc->itemconfigure ($item, -priority => $priority);
- &updateLabel($item);
-}
-
-
-# Callback to lower a small group of a rectangle and a text
-sub lower {
- my ($zinc) = @_;
- # to get the item under the cursor!
- my $item = $zinc->find('withtag', 'current');
- return unless $item;
- $zinc->lower($item);
- &updateLabel($item);
-}
-
-# Callback to raise a small group of a rectangle and a text
-sub raise {
- my ($zinc) = @_;
- # to get the item under the cursor!
- my $item = $zinc->find('withtag', 'current');
- return unless $item;
- $zinc->raise($item);
- &updateLabel($item);
-}
-
-# Callback to raise the group of groups of a rectangle and a text
-sub lowerGroup {
- my ($zinc) = @_;
- # to get the item under the cursor!
- my $item = $zinc->find('withtag', 'current');
- return unless $item;
- my $coloredGroup = $zinc->group($item);
- $zinc->lower($coloredGroup);
-}
-
-# Callback to raise the group of groups of a rectangle and a text
-sub raiseGroup {
- my ($zinc) = @_;
- # to get the item under the cursor!
- my $item = $zinc->find('withtag', 'current');
- return unless $item;
- my $coloredGroup = $zinc->group($item);
- $zinc->raise($coloredGroup);
- &updateLabel($item);
-}
-
-# Callback to change the group of groups of a rectangle and a text
-sub toggleItemGroup {
- my ($zinc) = @_;
- # to get the item under the cursor!
- my $item = $zinc->find('withtag', 'current');
- return unless $item;
- my $newgroup;
- if ($group1 == $zinc->group($item)) {
- $newgroup = $group2;
- }
- else {
- $newgroup = $group1;
- }
-
- $zinc->chggroup($item,$newgroup,1); ## the lats argument is true for mainting $item' position
- &updateLabel($item);
-}
-
-# callback for starting a drag
-my ($x_orig, $y_orig);
-sub press {
- my ($zinc, $group, $action) = @_;
- my $ev = $zinc->XEvent();
- $x_orig = $ev->x;
- $y_orig = $ev->y;
- $zinc->Tk::bind('<Motion>', [$action, $group]);
-}
-
-# Callback for moving a small group of a rectangle and a text
-sub motion {
- my ($zinc, $group) = @_;
- my $ev = $zinc->XEvent();
- my $x = $ev->x;
- my $y = $ev->y;
-
- $zinc->translate($group, $x-$x_orig, $y-$y_orig);
- $x_orig = $x;
- $y_orig = $y;
-}
-
-# Callback for moving a group of groups of a rectangle and a text
-sub groupMotion {
- my ($zinc, $group) = @_;
- my $ev = $zinc->XEvent();
- my $x = $ev->x;
- my $y = $ev->y;
-
- my $coloredGroup = $zinc->group($group);
- $zinc->translate($coloredGroup, $x-$x_orig, $y-$y_orig);
- $x_orig = $x;
- $y_orig = $y;
-}
-
-# Callback when releasing the mouse button. It removes any motion callback
-sub release {
- my ($zinc) = @_;
- $zinc->Tk::bind('<Motion>', '');
-}
-
-
-Tk::MainLoop();
-
-
-1;
generated by cgit v1.1 at 2024-05-18 15:45:51 +0000