#!/usr/bin/perl
use warnings;
use strict;
use Tk;
my $w=20;
my $x=0;
my $y=0;
# make up some data
my %bars;
foreach (0..500){
my $name = random_string();
$bars{$name}{'name'} = $name;
$bars{$name}{'data'} = 100 +rand 1200;
}
my $mw=tkinit;
my $c = $mw->Scrolled('Canvas',
-bg=>'white')->pack(-expand=>1,-fill=>'both');
#---determine font spacing by making a capital W---
my $fonttest = $c->createText(0,0,
-fill => 'black',
-text => 'W',
);
my ($bx,$by,$bx1,$by1) = $c->bbox($fonttest);
my $width = $bx1 - $bx;
my $height = $by1 - $by;
$c->delete($fonttest);
#--------------------------------------------
foreach my $key(sort keys %bars) {
my ( $bg, $fg ) = random_colors();
$bars{$key} = $c->createRectangle($x,$y,$x+20,$bars{$key}{'data'},
-fill=> $bg,
-tags=>[ $key]
);
my(@text) = split /(.)/, $key;
#print "@text\n";
foreach my $t( @text ){
$c->createText($x+10,$y,
-anchor=>'n',
-fill => $fg,
-text => $t
);
$y += $height/2;
}
$y = 0;
$x+=20;
}
$mw->Button(
-text => "Save",
-command => [sub {
$c->update;
my @capture=();
my ($x0,$y0,$x1,$y1)=$c->bbox('all');
@capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-$x
+0);
$c -> postscript(-colormode=>'color',
-file=>$0.'.ps',
-rotate=>90,
-width=>800,
-height=>500,
@capture);
}
] )->pack;
$c->Subwidget('scrolled')->Tk::bind("<Button-1>", [ \&print_xy, Ev('x'
+), Ev('y') ]);
# adjust canvas scrollbars size to show all
my ($x0,$y0,$x1,$y1)=$c->bbox('all');
$c->configure( -scrollregion=>[0,0,(($x1-$x0)+20),(($y1-$y0)+20) ] );
MainLoop;
##########################################################
sub print_xy {
#print "@_\n";
my ($canv, $x, $y) = @_;
#print "(x,y) = ", $canv->canvasx($x), ", ", $canv->canvasy($y), "\t
+";
my ($x1,$y1) = ($canv->canvasx($x),$canv->canvasy($y));
my $current = $canv->find(qw/withtag current/);
my (@tags) = $canv->gettags($current);
print "$y1 for @tags\n\n";
}
sub random_colors {
my ( $r, $g, $b ) = map { int rand 256 } 1 .. 3;
my $lum = ( $r * 0.3 ) + ( $g * 0.59 ) + ( $b * 0.11 );
my $bg = sprintf( "#%02x%02x%02x", $r, $g, $b );
my $fg = $lum < 128 ? "white" : "black";
return ( $bg, $fg );
}
sub random_string {
my($string) = '';
my($length) = 6;
my(@chars) = ('A' .. 'Z', 'a' .. 'z', 0 .. 9);
while (length($string) != $length) {
$string .= $chars[ rand($#chars) ];
}
return($string);
}
|