This week only. Pastebin PRO Accounts Christmas Special! Don't miss out!Want more features on Pastebin? Sign Up, it's FREE!
Guest

LCD.pm v1.3

By: a guest on May 6th, 2012  |  syntax: Perl  |  size: 10.58 KB  |  views: 43  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. $Tk::LCD::VERSION = '1.3';
  2. # Colon and leading '0' added by Steve Clark, Dec 2003.
  3. # See: http://search.cpan.org/~lusol/Tk-LCD-1.3/LCD.pm
  4.  
  5. package Tk::LCD;
  6.  
  7. use base qw/Tk::Derived Tk::Canvas/;
  8. use vars qw/$ELW %SHAPE %shape %LLCD %ULCD/;
  9. use vars qw/$CLW %CSHAPE %cshape %CLLCD/;
  10. use subs qw/ldifference/;
  11. use strict;
  12.  
  13. Construct Tk::Widget 'LCD';
  14.  
  15. # LCD class data.
  16.  
  17. $ELW = 22;                      # element pixel width
  18. $CLW = 8;                       # colon pixel width
  19.  
  20. # %SHAPE stolen with appreciation from Donal K. Fellows' Tcl game
  21. # of Maze. An LCD element can display a digit, space or minus sign.
  22. # It's made up of 7 segments labelled 'a' through 'g'.  Each segment
  23. # is defined by a series of Canvas widget polygon coordinates.
  24. #
  25. #    b
  26. #    -
  27. #  a| |c
  28. #    -   <--- g
  29. #  f| |d
  30. #    -
  31. #    e
  32.  
  33. %SHAPE = (
  34.     'a' => [qw/ 3.0  5  5.2  3  7.0  5  6.0 15  3.8 17  2.0 15/],
  35.     'b' => [qw/ 6.3  2  8.5  0 18.5  0 20.3  2 18.1  4  8.1  4/],
  36.     'c' => [qw/19.0  5 21.2  3 23.0  5 22.0 15 19.8 17 18.0 15/],
  37.     'd' => [qw/17.4 21 19.6 19 21.4 21 20.4 31 18.2 33 16.4 31/],
  38.     'e' => [qw/ 3.1 34  5.3 32 15.3 32 17.1 34 14.9 36  4.9 36/],
  39.     'f' => [qw/ 1.4 21  3.6 19  5.4 21  4.4 31  2.2 33  0.4 31/],
  40.     'g' => [qw/ 4.7 18  6.9 16 16.9 16 18.7 18 16.5 20  6.5 20/],
  41. );
  42.  
  43. %CSHAPE = (
  44.     'c1'=> [qw/ 2.5 10  5.0  7  7.1 10  4.6 13/],
  45.     'c2'=> [qw/ 0.9 26  3.4 23  5.5 26  3.0 29/],
  46. );
  47.  
  48. # %shape is 1/2 the size of %SHAPE.
  49.  
  50. foreach my $c (keys %SHAPE) {
  51.     $shape{$c} = [ map {$_ / 2.0} @{$SHAPE{$c}} ];
  52. }
  53.  
  54. foreach my $c (keys %CSHAPE) {
  55.     $cshape{$c} = [ map {$_ / 2.0} @{$CSHAPE{$c}} ];
  56. }
  57.  
  58. # To display an LCD element we must turn on and off certain segments.
  59. # %LLCD defines a list of segments to turn on for any particular
  60. # symbol.
  61.  
  62. %LLCD = (
  63.     '0' => [qw/a b c d e f/],
  64.     '1' => [qw/c d/],
  65.     '2' => [qw/b c e f g/],
  66.     '3' => [qw/b c d e g/],
  67.     '4' => [qw/a c d g/],
  68.     '5' => [qw/a b d e g/],
  69.     '6' => [qw/a b d e f g/],
  70.     '7' => [qw/b c d/],
  71.     '8' => [qw/a b c d e f g/],
  72.     '9' => [qw/a b c d e g/],
  73.     '-' => [qw/g/],
  74.     ' ' => [''],
  75. );
  76.  
  77. %CLLCD = (
  78.     ':' => [qw/c1 c2/],
  79.     ' ' => [''],
  80. );
  81.  
  82. # Similarly, %ULCD defines a list of LCD element segments to turn off
  83. # for any particular symbol. In Maze, %ULCD was manually generated,
  84. # but in the Perl/Tk rendition unlit LCD segments are dynamically
  85. # computed as the set difference of qw/a b c d e f g/ and the lit
  86. # segments.
  87.  
  88. $ULCD{$_} = [ ldifference [keys %SHAPE], $LLCD{$_} ] foreach (keys %LLCD);
  89.  
  90. sub Populate {
  91.  
  92.     my($self, $args) = @_;
  93.     $self->SUPER::Populate($args);
  94.  
  95.     $self->ConfigSpecs(
  96.         -commify    => [qw/PASSIVE commify    Commify    1/    ],
  97.         -elements   => [qw/METHOD  elements   Elements   5/    ],
  98.         -height     => [$self, qw/ height     Height     36/   ],
  99.         -onoutline  => [qw/PASSIVE onoutline  Onoutline  cyan/ ],
  100.         -onfill     => [qw/PASSIVE onfill     Onfill     black/],
  101.         -offoutline => [qw/PASSIVE offoutline Offoutline white/],
  102.         -offfill    => [qw/PASSIVE offfill    Offfill    gray/ ],
  103.         -size       => [qw/METHOD  size       Size       large/],
  104.         -variable   => [qw/METHOD  variable   Variable/, undef ],
  105.         -leading    => [qw/PASSIVE leading    Leading    ' '/  ],
  106.     );
  107.  
  108. } # end Populate
  109.  
  110. # Public methods.
  111.  
  112. sub set {                       # show an LCD number
  113.  
  114.     my ($self, $number) = @_;
  115.  
  116.     $self->delete('lcd');
  117.     return unless defined $number;
  118.  
  119.     my $onoutl    = $self->cget(-onoutline);
  120.     my $onfill    = $self->cget(-onfill);
  121.     my $offoutl   = $self->cget(-offoutline);
  122.     my $offfill   = $self->cget(-offfill);
  123.     my $shape;
  124.     my $size      = $self->cget(-size);
  125.     my $x_offset  = 0;
  126.     my $y_offset;
  127.  
  128.     # Format the output string
  129.     if ($size eq 'large') {
  130.         $shape    = \%SHAPE;
  131.         $y_offset = 0;
  132.     } else {
  133.         $shape    = \%shape;
  134.         $y_offset = $ELW / 2 - 4;
  135.         if ($self->cget(-commify)) {
  136.             $_ = $number;
  137.             s/^\s+//;
  138.             s/\s+$//;
  139.             s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/g;
  140.             $number = $_;
  141.         }
  142.     }
  143.     $_ = sprintf '%' . $self->{elements} . 's', $number;
  144.  
  145.     # convert leading spaces
  146.     my $lead = $self->cget(-leading);
  147.     if ($lead ne ' ') {
  148.         /^( *)(.*)/;
  149.         my $rest = $2;
  150.         ($number = $1) =~ s/ /$lead/g;
  151.         $number .= $rest;
  152.     }
  153.  
  154.     foreach my $c (split '', $number) {
  155.         if ($c =~ /[\.\,]/) {
  156.             if ($size eq 'small') {
  157.                 $self->move(
  158.                     $self->createPolygon(
  159.                           ($c eq '.') ?
  160.                           (0, 0, 0, 2, 2, 2, 2, 0) :
  161.                           (0, 4, 1, 4, 2, 3, 2, 0, 0, 0, 0, 2, 2, 2),
  162.                         -tags    => 'lcd',
  163.                         -outline => $onoutl,
  164.                         -fill    => $onfill,
  165.                     ),
  166.                 $x_offset - 5, 22);
  167.             }
  168.             next;
  169.         }
  170.         foreach my $symbol (@{$LLCD{$c}}) {
  171.  
  172.             $self->move(
  173.                         $self->createPolygon(
  174.                             $shape->{$symbol},
  175.                             -tags    => 'lcd',
  176.                             -outline => $onoutl,
  177.                             -fill    => $onfill,
  178.                         ),
  179.             $x_offset, $y_offset);
  180.         }
  181.         foreach my $symbol (@{$ULCD{$c}}) {
  182.             $self->move(
  183.                         $self->createPolygon(
  184.                             $shape->{$symbol},
  185.                             -tags    => 'lcd',
  186.                             -outline => $offoutl,
  187.                             -fill    => $offfill,
  188.                         ),
  189.             $x_offset, $y_offset);
  190.  
  191.         }
  192.         $x_offset += $ELW;
  193.     } # forend all characters
  194.  
  195. } # end set
  196.  
  197. sub colon {                     # show an LCD number
  198.  
  199.     my ($self, $on) = @_;
  200.  
  201.     $self->configure(-width => $CLW);
  202.     $self->delete('lcd');
  203.     return unless $on;
  204.  
  205.     my $onoutl    = $self->cget(-onoutline);
  206.     my $onfill    = $self->cget(-onfill);
  207.     my $offoutl   = $self->cget(-offoutline);
  208.     my $offfill   = $self->cget(-offfill);
  209.     my $shape;
  210.     my $size      = $self->cget(-size);
  211.     my $x_offset  = 0;
  212.     my $y_offset;
  213.     if ($size eq 'large') {
  214.         $shape    = \%CSHAPE;
  215.         $y_offset = 0;
  216.     } else {
  217.         $shape    = \%cshape;
  218.         $y_offset = $ELW / 2 - 4;
  219.     }
  220.  
  221.     if ($on) {
  222.         foreach my $symbol (@{$CLLCD{':'}}) {
  223.  
  224.             $self->move(
  225.                         $self->createPolygon(
  226.                             $shape->{$symbol},
  227.                             -tags    => 'lcd',
  228.                             -outline => $onoutl,
  229.                             -fill    => $onfill,
  230.                         ),
  231.             $x_offset, $y_offset);
  232.  
  233.         }
  234.     }
  235. } # end colon
  236.  
  237. # Private methods and subroutines.
  238.  
  239. sub elements {
  240.  
  241.     my ($self, $elements) = @_;
  242.     if (defined $elements) {
  243.         $self->{elements} = $elements;
  244.         $self->configure(-width => $elements * $ELW);
  245.     } else {
  246.         $self->{elements};
  247.     }
  248.  
  249. } # end elements
  250.  
  251. sub ldifference {               # @d = ldifference \@l1, \@l2;
  252.  
  253.     my($l1, $l2) = @_;
  254.     my %d;
  255.     @d{@$l2} = (1) x @$l2;
  256.     return grep(! $d{$_}, @$l1);
  257.  
  258. } # end ldifference
  259.  
  260. sub size {
  261.  
  262.     my ($self, $size) = @_;
  263.     if (defined $size) {
  264.         die "-size must be 'large' or 'small'." unless $size =~ /^large|small$/;
  265.         $self->{size} = $size;
  266.     } else {
  267.         $self->{size};
  268.     }
  269.  
  270. } # end size
  271.  
  272. sub variable {
  273.  
  274.     use Tk::Trace;
  275.  
  276.     my ($lcd, $vref) = @_;
  277.  
  278.     my $st = [sub {
  279.         my ($index, $new_val, $op, $lcd) = @_;
  280.         return unless $op eq 'w';
  281.         $lcd->set($new_val);
  282.         $new_val;
  283.     }, $lcd];
  284.  
  285.     $lcd->traceVariable($vref, 'w' => $st);
  286.     $lcd->{watch} = $vref;
  287.  
  288.     $lcd->OnDestroy( [sub {$_[0]->traceVdelete($_[0]->{watch})}, $lcd] );
  289.  
  290. } # end variable
  291.  
  292. 1;
  293. __END__
  294.  
  295. =head1 NAME
  296.  
  297. Tk::LCD - display Liquid Crystal Display symbols.
  298.  
  299. =head1 SYNOPSIS
  300.  
  301.  use Tk::LCD;
  302.  
  303.  $lcd = $parent->LCD(-opt => val, ... );
  304.  
  305. =head1 DESCRIPTION
  306.  
  307. Tk::LCD is a Canvas derived widget, based on a code snippet from
  308. Donal K. Fellows' Maze game. LCD symbols are displayed in elements
  309. composed of 8 segments, labeled "a" though "g", some on and some
  310. off.  For instance, the number 8 requires one LCD element that has
  311. all 8 segments lit:
  312.  
  313.      b
  314.  
  315.      -
  316.  a  | | c
  317.      -      <------  g
  318.  f  | | d
  319.      _  
  320.  
  321.      e
  322.  
  323. A Tk::LCD widget can consist of any number of elements, specified
  324. during widget creation.  To actually display an LCD number, either
  325. invoke the set() method, or use the -variable option.
  326.  
  327. LCD elements can display a space, minus sign or a numerical diget,
  328. meaning that any positive or negative I<integer number> can be displayed.
  329.  
  330. LCD elements can also be either I<large> or I<small> in size.  If an LCD
  331. widget's size is I<small>, then there is room enough between elements
  332. to display dots and commas. As a result, any positive or negative I<decimal
  333. number> can be displayed. Additionally, numbers can be
  334. "commified", that is, commas are inserted every third digit to the
  335. left of the decimal point.
  336.  
  337. =head1 OPTIONS
  338.  
  339. The following option/value pairs are supported:
  340.  
  341. =over 4
  342.  
  343. =item B<-commify>
  344.  
  345. Pertinent only if the LCD size is small, a boolean indicating
  346. whether a number is commified; that is, commas inserted every
  347. third digit.  Default is 1.
  348.  
  349. =item B<-leading>
  350.  
  351. Character to use for leading digits.  Default is ' ' (space). Obvious
  352. other choice is '0'.
  353.  
  354. =item B<-elements>
  355.  
  356. The number of LCD elements (digits).  Default is 5.
  357.  
  358. =item B<-onoutline>
  359.  
  360. Outline color for ON segments.
  361.  
  362. =item B<-onfill>
  363.  
  364. Fill color for ON segments.
  365.  
  366. =item B<-offoutline>
  367.  
  368. Outline color for OFF segments.
  369.  
  370. =item B<-offfill>
  371.  
  372. Fill color for OFF segments.
  373.  
  374. =item B<-size>
  375.  
  376. Size of LCD elements, either I<large> or I<small> (default is I<large>).
  377.  
  378. =item B<-variable>
  379.  
  380. A scalar reference that contains the LCD number to display.  The
  381. widget is updated when this variable changes value.
  382.  
  383. =back
  384.  
  385. =head1 METHODS
  386.  
  387. =head2 $lcd->set($number);
  388.  
  389. Display $number in the LCD widget.
  390.  
  391. =head2 $lcd->colon($on);
  392.  
  393. Convert lcd widget to a colon widget half the width of a digit.
  394. The argument specifies whether the colon is lit or dark.
  395. A subsequent call to set would revert to digit widgets.
  396.  
  397. =head1 ADVERTISED WIDGETS
  398.  
  399. Component subwidgets can be accessed via the B<Subwidget> method.
  400. This mega widget has no advertised subwidgets.
  401.  
  402. =head1 EXAMPLE
  403.  
  404.  $lcd = $mw->LCD(-variable => \$frog)->pack;
  405.  $lcd->set(4000);
  406.  $frog = 2001;
  407.  
  408. =head1 AUTHOR
  409.  
  410. sol0@Lehigh.EDU
  411.  
  412. Copyright (C) 2001 - 2003, Steve Lidie. All rights reserved.
  413.  
  414. This program is free software; you can redistribute it and/or
  415. modify it under the same terms as Perl itself.
  416.  
  417. =head1 KEYWORDS
  418.  
  419. LCD, Canvas
  420.  
  421. =cut
clone this paste RAW Paste Data