Re: Value Display add-on for Tk::ProgressBar.pm

"Michael Krause" <[email protected]> writes:

> Hi Slaven,
> 
> First of all thank you for picking the ball and bringing Perl-Tk to a new release.
> I discussed 3 years ago with Nick-Ing about my add-on for the progressbar that would add an (optional) percentage/value display. For some time reasons it did not made it into the 804.027 release, but he promised to put this in a future release, which up to today has not become reality :-|
> Therefore I kindly ask you to consider to put it into your upcoming release. I made a diff to your *500 ProgressBar.pm and attach this diff below.
> 

I think the -valuecolor and -valuecolors options could be combined
into one? There are some minor glitches (indentation level is 8, not 4
like the rest of the file; "-colors" instead of "-valuecolors" in the
Pod), but I think I'll accept the patch.

Regards,
        Slaven

> Many thanks in advance,
> 
> Br.  Michael Krause.
> -- 
> Psssst! Schon vom neuen GMX MultiMessenger gehört?
> Der kanns mit allen: http://www.gmx.net/de/go/multimessenger
> 
> --- ProgressBar_804.027_500.pm	2007-05-11 12:12:42.953311000 +0200
> +++ ./ProgressBar.pm	2007-05-11 12:44:26.256274000 +0200
> @@ -45,6 +45,12 @@
>  		  => [SELF => 'highlightThickness','HighlightThickness',0],
>  	-troughcolor
>  		  => [PASSIVE => 'troughColor', 'Background', 'grey55'],
> +	# Add-On for Value-Display (percentage as text)
> + 	-showvalue      => [PASSIVE => undef, undef, 0],
> + 	-valueformat    => [PASSIVE => undef, undef, '%s%%'],
> + 	-valuecolor     => [PASSIVE => undef, undef, 'white'],
> + 	-font           => [PASSIVE => 'font', 'Font', undef],
> +	-valuecolors    => [PASSIVE => undef, undef, undef],
>      );
>      _layoutRequest($c,1);
>      $c->OnDestroy(['Destroyed' => $c]);
> @@ -84,6 +90,8 @@
>      my $x = abs(int($c->{Configure}{'-padx'})) + $bw;
>      my $y = abs(int($c->{Configure}{'-pady'})) + $bw;
>      my $value = $c->value;
> +	my $realvalue = $value;
> +
>      my $from = $c->{Configure}{'-from'};
>      my $to   = $c->{Configure}{'-to'};
>      my $horz = $c->{Configure}{'-anchor'} =~ /[ew]/i ? 1 : 0;
> @@ -144,6 +152,25 @@
>  		-width => 0,
>  		-outline => undef);
>  
> +	# Add-On for Value-Display (percentage as text)
> +	if ($c->cget('-showvalue')) {
> +		my $text = sprintf($c->cget('-valueformat'), $value);
> +		my @font; @font = (-font => $c->cget('-font') ) if defined $c->cget('-font');
> +		my ($xpos, $ypos) = ($x+$w/2, $y+$h/2);
> +		$c->createText($xpos, $ypos,
> +			-text => $text,
> +			-tags => 'percentage',
> +			-fill => $c->cget('-valuecolor'),
> +			@font,
> +		);
> +		$c->createText(++$xpos, ++$ypos,
> +			-text => $text,
> +			-tags => 'percentage_tr',
> +			-fill => $c->{Configure}{'-troughcolor'},
> +			@font,
> +		);
> +	}
> +
>  	my($x0,$y0,$x1,$y1);
>  
>  	if($horz) {
> @@ -170,6 +197,8 @@
>  	my $color = $c->cget('-foreground');
>  	my $pos   = 0;
>  	my $val   = $minv;
> +	# Add-On for Value-Display (percentage-related color)
> +	my $valuecolor = $c->cget('-valuecolor');
>  
>  	while($val < $maxv) {
>  	    my($bw,$nval);
> @@ -277,6 +306,38 @@
>  	$c->raise($cover);
>  	$c->coords($cover,$x0,$y0,$x1,$y1);
>      }
> +
> +    # Add-On for Value-Display (percentage as text)
> +    if ($c->cget('-showvalue')) {
> +        my ($min, $max);
> +        if ($c->{Configure}{'-to'} > $c->{Configure}{'-from'}) {
> +            $min = $c->{Configure}{'-from'};
> +            $max = $c->{Configure}{'-to'};
> +        }
> +        else {
> +            $min = $c->{Configure}{'-to'};
> +            $max = $c->{Configure}{'-from'};
> +        }
> +        $realvalue = $min if $realvalue < $min;
> +        $realvalue = $max if $realvalue > $max;
> +
> +        # Support for relative Value Colors
> +        my (%valuecolors, $valuecolors, $valuecolor, $pos);
> +        $valuecolors = $c->{Configure}{'-valuecolors'} || [0, $c->cget('-valuecolor')];
> +        %valuecolors = @$valuecolors;
> +        foreach $pos ( sort keys %valuecolors) {
> +            $valuecolor = $valuecolors{$pos} if $realvalue >= $pos;
> +        }
> +        $c->itemconfigure('percentage', -fill => $valuecolor);
> +        my $text = sprintf($c->cget('-valueformat'), $realvalue);
> +        $c->dchars('percentage_tr', 0, 'end');
> +        $c->insert('percentage_tr', 0, $text); 
> +        $c->raise('percentage_tr');
> +        #---------------------------------
> +        $c->dchars('percentage', 0, 'end');
> +        $c->insert('percentage', 0, $text); 
> +        $c->raise('percentage');
> +    }
>  }
>  
>  sub value {
> @@ -342,6 +403,11 @@
>  	-blocks => 10,
>  	-colors => [0, 'green', 50, 'yellow' , 80, 'red'],
>  	-variable => \$percent_done
> +	# New Options
> +	-showvalue => '1',
> +	-valuecolor => 'black',
> +	-font => '9x15',
> +	-valueformat => '<%s %%>',
>      );
>  
>      $progress->value($position);
> @@ -468,6 +534,38 @@
>  bars this is the ProgressBars height.  The default width is derived
>  from the values of C<-borderwidth> and C<-pady> and C<-highlightthickness>.
>  
> +
> +=item B<-showvalue>
> +
> +This enables the current (percentage) value to be displayed.
> +
> +
> +=item B<-valueformat>
> +
> +Specifies the desired text mask for the current value value
> +to be displayed. Defaults to '%s%%'
> +
> +
> +=item B<-valuecolor>
> +
> +Specifies the desired text color for the  current (percentage)
> +value to be displayed.
> +
> +
> +=item B<-valuecolors>
> +
> +Controls the colors to be used for value visualization of the progress bar.
> +The colors should be supplied as a reference to an array containing pairs
> +of positions and colors.
> +
> +  -colors => [ 0, 'black', 50, 'red' ]
> +
> +
> +=item B<-font>
> +
> +Specifies the desired text font for the  current (percentage)
> +value to be displayed.
> +
>  =back
>  
>  =head1 WIDGET METHODS
> @@ -493,6 +591,8 @@
>  This program is free software; you can redistribute it and/or modify it
>  under the same terms as Perl itself.
>  
> +ValueText-Add-On 02.2004 - 2007 by M. Krause, E<lt>F<KrauseM_AT_gmx_DOT_net>E<gt>
> +
>  =cut
>  
>  

-- 
Slaven Rezic - slaven <at> rezic <dot> de

    tknotes - A knotes clone, written in Perl/Tk.
    http://ptktools.sourceforge.net/#tknotes
--++**==--++**==--++**==--++**==--++**==--++**==--++**==
ptk mailing list
[email protected]
https://mailman.stanford.edu/mailman/listinfo/ptk