Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- $Tk::LCD::VERSION = '1.3';
- # Colon and leading '0' added by Steve Clark, Dec 2003.
- # See: http://search.cpan.org/~lusol/Tk-LCD-1.3/LCD.pm
- package Tk::LCD;
- use base qw/Tk::Derived Tk::Canvas/;
- use vars qw/$ELW %SHAPE %shape %LLCD %ULCD/;
- use vars qw/$CLW %CSHAPE %cshape %CLLCD/;
- use subs qw/ldifference/;
- use strict;
- Construct Tk::Widget 'LCD';
- # LCD class data.
- $ELW = 22; # element pixel width
- $CLW = 8; # colon pixel width
- # %SHAPE stolen with appreciation from Donal K. Fellows' Tcl game
- # of Maze. An LCD element can display a digit, space or minus sign.
- # It's made up of 7 segments labelled 'a' through 'g'. Each segment
- # is defined by a series of Canvas widget polygon coordinates.
- #
- # b
- # -
- # a| |c
- # - <--- g
- # f| |d
- # -
- # e
- %SHAPE = (
- 'a' => [qw/ 3.0 5 5.2 3 7.0 5 6.0 15 3.8 17 2.0 15/],
- 'b' => [qw/ 6.3 2 8.5 0 18.5 0 20.3 2 18.1 4 8.1 4/],
- 'c' => [qw/19.0 5 21.2 3 23.0 5 22.0 15 19.8 17 18.0 15/],
- 'd' => [qw/17.4 21 19.6 19 21.4 21 20.4 31 18.2 33 16.4 31/],
- 'e' => [qw/ 3.1 34 5.3 32 15.3 32 17.1 34 14.9 36 4.9 36/],
- 'f' => [qw/ 1.4 21 3.6 19 5.4 21 4.4 31 2.2 33 0.4 31/],
- 'g' => [qw/ 4.7 18 6.9 16 16.9 16 18.7 18 16.5 20 6.5 20/],
- );
- %CSHAPE = (
- 'c1'=> [qw/ 2.5 10 5.0 7 7.1 10 4.6 13/],
- 'c2'=> [qw/ 0.9 26 3.4 23 5.5 26 3.0 29/],
- );
- # %shape is 1/2 the size of %SHAPE.
- foreach my $c (keys %SHAPE) {
- $shape{$c} = [ map {$_ / 2.0} @{$SHAPE{$c}} ];
- }
- foreach my $c (keys %CSHAPE) {
- $cshape{$c} = [ map {$_ / 2.0} @{$CSHAPE{$c}} ];
- }
- # To display an LCD element we must turn on and off certain segments.
- # %LLCD defines a list of segments to turn on for any particular
- # symbol.
- %LLCD = (
- '0' => [qw/a b c d e f/],
- '1' => [qw/c d/],
- '2' => [qw/b c e f g/],
- '3' => [qw/b c d e g/],
- '4' => [qw/a c d g/],
- '5' => [qw/a b d e g/],
- '6' => [qw/a b d e f g/],
- '7' => [qw/b c d/],
- '8' => [qw/a b c d e f g/],
- '9' => [qw/a b c d e g/],
- '-' => [qw/g/],
- ' ' => [''],
- );
- %CLLCD = (
- ':' => [qw/c1 c2/],
- ' ' => [''],
- );
- # Similarly, %ULCD defines a list of LCD element segments to turn off
- # for any particular symbol. In Maze, %ULCD was manually generated,
- # but in the Perl/Tk rendition unlit LCD segments are dynamically
- # computed as the set difference of qw/a b c d e f g/ and the lit
- # segments.
- $ULCD{$_} = [ ldifference [keys %SHAPE], $LLCD{$_} ] foreach (keys %LLCD);
- sub Populate {
- my($self, $args) = @_;
- $self->SUPER::Populate($args);
- $self->ConfigSpecs(
- -commify => [qw/PASSIVE commify Commify 1/ ],
- -elements => [qw/METHOD elements Elements 5/ ],
- -height => [$self, qw/ height Height 36/ ],
- -onoutline => [qw/PASSIVE onoutline Onoutline cyan/ ],
- -onfill => [qw/PASSIVE onfill Onfill black/],
- -offoutline => [qw/PASSIVE offoutline Offoutline white/],
- -offfill => [qw/PASSIVE offfill Offfill gray/ ],
- -size => [qw/METHOD size Size large/],
- -variable => [qw/METHOD variable Variable/, undef ],
- -leading => [qw/PASSIVE leading Leading ' '/ ],
- );
- } # end Populate
- # Public methods.
- sub set { # show an LCD number
- my ($self, $number) = @_;
- $self->delete('lcd');
- return unless defined $number;
- my $onoutl = $self->cget(-onoutline);
- my $onfill = $self->cget(-onfill);
- my $offoutl = $self->cget(-offoutline);
- my $offfill = $self->cget(-offfill);
- my $shape;
- my $size = $self->cget(-size);
- my $x_offset = 0;
- my $y_offset;
- # Format the output string
- if ($size eq 'large') {
- $shape = \%SHAPE;
- $y_offset = 0;
- } else {
- $shape = \%shape;
- $y_offset = $ELW / 2 - 4;
- if ($self->cget(-commify)) {
- $_ = $number;
- s/^\s+//;
- s/\s+$//;
- s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/g;
- $number = $_;
- }
- }
- $_ = sprintf '%' . $self->{elements} . 's', $number;
- # convert leading spaces
- my $lead = $self->cget(-leading);
- if ($lead ne ' ') {
- /^( *)(.*)/;
- my $rest = $2;
- ($number = $1) =~ s/ /$lead/g;
- $number .= $rest;
- }
- foreach my $c (split '', $number) {
- if ($c =~ /[\.\,]/) {
- if ($size eq 'small') {
- $self->move(
- $self->createPolygon(
- ($c eq '.') ?
- (0, 0, 0, 2, 2, 2, 2, 0) :
- (0, 4, 1, 4, 2, 3, 2, 0, 0, 0, 0, 2, 2, 2),
- -tags => 'lcd',
- -outline => $onoutl,
- -fill => $onfill,
- ),
- $x_offset - 5, 22);
- }
- next;
- }
- foreach my $symbol (@{$LLCD{$c}}) {
- $self->move(
- $self->createPolygon(
- $shape->{$symbol},
- -tags => 'lcd',
- -outline => $onoutl,
- -fill => $onfill,
- ),
- $x_offset, $y_offset);
- }
- foreach my $symbol (@{$ULCD{$c}}) {
- $self->move(
- $self->createPolygon(
- $shape->{$symbol},
- -tags => 'lcd',
- -outline => $offoutl,
- -fill => $offfill,
- ),
- $x_offset, $y_offset);
- }
- $x_offset += $ELW;
- } # forend all characters
- } # end set
- sub colon { # show an LCD number
- my ($self, $on) = @_;
- $self->configure(-width => $CLW);
- $self->delete('lcd');
- return unless $on;
- my $onoutl = $self->cget(-onoutline);
- my $onfill = $self->cget(-onfill);
- my $offoutl = $self->cget(-offoutline);
- my $offfill = $self->cget(-offfill);
- my $shape;
- my $size = $self->cget(-size);
- my $x_offset = 0;
- my $y_offset;
- if ($size eq 'large') {
- $shape = \%CSHAPE;
- $y_offset = 0;
- } else {
- $shape = \%cshape;
- $y_offset = $ELW / 2 - 4;
- }
- if ($on) {
- foreach my $symbol (@{$CLLCD{':'}}) {
- $self->move(
- $self->createPolygon(
- $shape->{$symbol},
- -tags => 'lcd',
- -outline => $onoutl,
- -fill => $onfill,
- ),
- $x_offset, $y_offset);
- }
- }
- } # end colon
- # Private methods and subroutines.
- sub elements {
- my ($self, $elements) = @_;
- if (defined $elements) {
- $self->{elements} = $elements;
- $self->configure(-width => $elements * $ELW);
- } else {
- $self->{elements};
- }
- } # end elements
- sub ldifference { # @d = ldifference \@l1, \@l2;
- my($l1, $l2) = @_;
- my %d;
- @d{@$l2} = (1) x @$l2;
- return grep(! $d{$_}, @$l1);
- } # end ldifference
- sub size {
- my ($self, $size) = @_;
- if (defined $size) {
- die "-size must be 'large' or 'small'." unless $size =~ /^large|small$/;
- $self->{size} = $size;
- } else {
- $self->{size};
- }
- } # end size
- sub variable {
- use Tk::Trace;
- my ($lcd, $vref) = @_;
- my $st = [sub {
- my ($index, $new_val, $op, $lcd) = @_;
- return unless $op eq 'w';
- $lcd->set($new_val);
- $new_val;
- }, $lcd];
- $lcd->traceVariable($vref, 'w' => $st);
- $lcd->{watch} = $vref;
- $lcd->OnDestroy( [sub {$_[0]->traceVdelete($_[0]->{watch})}, $lcd] );
- } # end variable
- 1;
- __END__
- =head1 NAME
- Tk::LCD - display Liquid Crystal Display symbols.
- =head1 SYNOPSIS
- use Tk::LCD;
- $lcd = $parent->LCD(-opt => val, ... );
- =head1 DESCRIPTION
- Tk::LCD is a Canvas derived widget, based on a code snippet from
- Donal K. Fellows' Maze game. LCD symbols are displayed in elements
- composed of 8 segments, labeled "a" though "g", some on and some
- off. For instance, the number 8 requires one LCD element that has
- all 8 segments lit:
- b
- -
- a | | c
- - <------ g
- f | | d
- _
- e
- A Tk::LCD widget can consist of any number of elements, specified
- during widget creation. To actually display an LCD number, either
- invoke the set() method, or use the -variable option.
- LCD elements can display a space, minus sign or a numerical diget,
- meaning that any positive or negative I<integer number> can be displayed.
- LCD elements can also be either I<large> or I<small> in size. If an LCD
- widget's size is I<small>, then there is room enough between elements
- to display dots and commas. As a result, any positive or negative I<decimal
- number> can be displayed. Additionally, numbers can be
- "commified", that is, commas are inserted every third digit to the
- left of the decimal point.
- =head1 OPTIONS
- The following option/value pairs are supported:
- =over 4
- =item B<-commify>
- Pertinent only if the LCD size is small, a boolean indicating
- whether a number is commified; that is, commas inserted every
- third digit. Default is 1.
- =item B<-leading>
- Character to use for leading digits. Default is ' ' (space). Obvious
- other choice is '0'.
- =item B<-elements>
- The number of LCD elements (digits). Default is 5.
- =item B<-onoutline>
- Outline color for ON segments.
- =item B<-onfill>
- Fill color for ON segments.
- =item B<-offoutline>
- Outline color for OFF segments.
- =item B<-offfill>
- Fill color for OFF segments.
- =item B<-size>
- Size of LCD elements, either I<large> or I<small> (default is I<large>).
- =item B<-variable>
- A scalar reference that contains the LCD number to display. The
- widget is updated when this variable changes value.
- =back
- =head1 METHODS
- =head2 $lcd->set($number);
- Display $number in the LCD widget.
- =head2 $lcd->colon($on);
- Convert lcd widget to a colon widget half the width of a digit.
- The argument specifies whether the colon is lit or dark.
- A subsequent call to set would revert to digit widgets.
- =head1 ADVERTISED WIDGETS
- Component subwidgets can be accessed via the B<Subwidget> method.
- This mega widget has no advertised subwidgets.
- =head1 EXAMPLE
- $lcd = $mw->LCD(-variable => \$frog)->pack;
- $lcd->set(4000);
- $frog = 2001;
- =head1 AUTHOR
- sol0@Lehigh.EDU
- Copyright (C) 2001 - 2003, Steve Lidie. All rights reserved.
- This program is free software; you can redistribute it and/or
- modify it under the same terms as Perl itself.
- =head1 KEYWORDS
- LCD, Canvas
- =cut
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement