## command.tcl
##
## This demo shows the use of the table widget's -command options
##
## jeff.hobbs@acm.org
##  Converted to perl/tk by John Cerney


use Tk;

use Tk::TableMatrix;

my ($rows,$cols) = (10,10); # number of rows/cols
my $top = MainWindow->new;

# Sub to fill the array variable
sub fill{

	my ($array,$x,$y) = @_;
	my ($i,$j);
	for( $i = -$x; $i<$x; $i++){
		for( $j = -$y; $j<$y; $j++){
			$array->{"$i,$j"} = "$i x $j";
		}
	}
}



## Test out the use of a callback to define tags on rows and columns
sub rowSub{
	my $row = shift;
	return "OddRow" if( $row > 0 && $row % 2) 
}
sub colSub{
	my $col = shift;
	return "OddCol" if( $col > 0 && $col%2) ;
}

sub tblCmd{ 
	my ($array, $set, $row,$col,$val) = @_;
	# my @args = @_;
	# print "In Table Command, Args = '".join("', '",@args)."'\n";

	my $index = "$row,$col";
	if( $set ){
		$array->{$index} = $val;
	}
	else{
		if( defined( $array->{$index})){
			return $array->{$index};
		}
		else{
			return '';
		}
	}
}


my $label = $top->Label(-text => "TableMatrix -command Example");

# Label the changes with the value of currentTest
my $currentText = '';
my $currentLabel = $top->Label(-textvariable => \$currentText);

# Entry that changes with the value of activeText
my $activeText = '';
my $activeEntry = $top->Entry(-textvariable => \$activeText);

my $arrayVar = {};

fill($arrayVar, $rows,$cols); # fill up the array variable


my $t = $top->Scrolled('TableMatrix', -rows => $rows, -cols => $cols, 
                              -width => 6, -height => 6,
			      -titlerows => 1, -titlecols => 2,
			      -command => [\&tblCmd, $arrayVar],
			      -roworigin =>  -1,  -colorigin  => -2, 
			      -rowtagcommand => \&rowSub, 
			      -coltagcommand => \&colSub,
			      -selectmode => 'extended',
			      -flashmode => 'on',
			      -variable => $arrayVar,		      				

                    );

$t->configure( -browsecommand => sub{
					my ($index) = @_;
					$currentText = $index;
					$activeText = $t->get($index);
				});


$t->configure(  -validate => 1,
		-validatecommand => sub{
					my ($row,$col,$old,$new,$index) = @_;
					$activeText = $new;
					return 1;
					}
		);
$t->configure(  
		-selectioncommand => sub{
					my ($NumRows,$Numcols,$selection,$noCells) = @_;
					my @args = @_;
					print "In Selection Command, Args = '".join("', '",@args)."'\n";
					return $selection;
					}
		);




# hideous Color definitions here:
$t->tagConfigure('OddRow', -bg => 'orange', -fg => 'purple');
$t->tagConfigure('OddCol', -bg => 'brown', -fg => 'pink');

$t->colWidth( -2 => 7, -1 => 7, 1=> 5, 2 => 8, 4=> 14);

$label->pack( -expand => 1, -fill => 'both');
$currentLabel->pack( -expand => 1, -fill => 'both');
$activeEntry->pack( -expand => 1, -fill => 'both');

$t->pack(-expand => 1, -fill => 'both');


Tk::MainLoop;