$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