path: root/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl

#!/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;