http://www.perlmonks.org?node_id=166379

This was a little "game" project I cooked up a few years back as one of my early forays into Perl/Tk. It proved to be interesting (and successful) enough that I find myself referring back to it over the years when I need to remember how to get a particular behavior with Tk (or when I feel like doing a mindless word puzzle...)

Many newspapers provide a "cryptogram" puzzle on the comics page or next to the crossword, where a clever saying is "encrypted" by doing regular substitutions of letters (e.g. all "A"s in the "clear text" have been turned into "M"s, etc). They're kinda fun to solve (if you like that sort of thing), but doing it on paper is such a drag, especially when you have to erase things. Perl to the rescue! Once you get past the unavoidable kluge of having to type in the "cipher text", solving is a snap.

Okay, I admit this probably doesn't qualify as a "cool" use of Perl, but I think it is a nice demo of some useful GUI techniques, including special event bindings to optimize the task, a pop-up for helpful information, and overall ease and transparency of use -- man page/pod not included, because (I think) none is needed. (oh, no exit button either, but who needs that, really?)

#!/usr/bin/perl -w use strict; use Tk; my ($puzStr, %ent, %lbl); my $tfont = "Courier 14"; my $lfont = "Courier 12"; my @letters = qw/a b c d e f g h i j k l m n o p q r s t u v w x y z/; my $main = MainWindow->new; my $bg = $main->cget('-background'); my $fg = $main->cget('-foreground'); $main->Label(-text => "Type the cryptogram puzzle in this box and hit +the \"Enter\" key:", -font => $lfont )->pack(-side => 'top'); my $puzzle = $main->Text(-relief => 'sunken', -width => 80, -height => 3, -font => $tfont, -wrap => 'word', -spacing1 => '5p', -spacing2 => '5p', -spacin +g3 => '5p' )->pack(-side => 'top'); my $nxt = $main->Label(-text => "Now type a letter in each of these bo +xes to decode it:", -font => $lfont, -foreground => $bg )->pack(-side => 'top'); my $frm = $main->Frame()->pack(-side => 'top', -pady => 2); my $row = my $col = 1; foreach my $c (@letters) { $lbl{$c} = $frm->Label(-text => " $c>", -font => $tfont, -foreground => $bg )->grid(-row => $row, -col => $col++); $ent{$c} = $frm->Entry(-width => 1, -font => $tfont, -borderwidth => 1, -relief => 'flat' )->grid(-row => $row, -col => $col++ ); if ( $c eq 'n' ) { $row = 2, $col = 1; } } my $btn = $frm->Button(-text => "Show Counts", -command => \&scSub, -state => 'disabled', )->grid(-row => $row, -col => $col, -columnspan => 5 ); my $lst = $main->Label(-text => "The solution will appear below:", -font => $lfont, -foreground => $bg )->pack(-side => 'top'); my $solutn = $main->Text(-relief => 'raised', -width => 80, -height => 3, -font => $tfont, -wrap => 'word', -spacing1 => '5p', -spacing2 => '5p', -spacin +g3 => '5p' )->pack(-side => 'top'); $main->bind( 'Tk::Entry', '<KeyRelease>', [\&krSub, Ev('K')] ); $main->bind( 'Tk::Entry', '<Enter>', \&enSub ); $puzzle->bind( "<Return>" => sub { $puzStr = lc $puzzle->get('1.0','end'); $puzStr =~ s/\s+$//; $puzzle->delete('1.0','end'), $puzzle->insert('1.0',$puzStr); foreach my $c (@letters) { $ent{$c}->delete(0,'end'); if ( $puzStr =~ /$c/ ) { $ent{$c}->configure(-state => 'normal', -relief => 'sunken +'); $ent{$c}->insert(0,"_"); $lbl{$c}->configure(-foreground => $fg); } else { $ent{$c}->configure(-state => 'disabled', -relief => 'flat +'); $lbl{$c}->configure(-foreground => $bg); } } $nxt->configure(-foreground => $fg); $lst->configure(-foreground => $fg); $btn->configure(-state => 'normal'); &updateSlvd; }); MainLoop; sub krSub { my ( $w, $c ) = @_; if ( $c !~ /^[a-z]$/i ) { $w->delete(0,'end'), $w->insert(0,'_'); } else { foreach my $l (@letters) { next if ( $w eq $ent{$l} ); if ( $c eq $ent{$l}->get ) { $ent{$l}->delete(0,'end'), $ent{$l}->insert(0,'_'); } } } &updateSlvd; $w->selectionRange(0,'end'); } sub enSub { my $w = $_[0]; $w->selectionRange(0,'end'); $w->focus; } sub scSub { my %cnt = (); my ( $n, $chk ); my $maxn = my $maxw = 0; foreach my $c (@letters) { $chk = $puzStr; $chk =~ s/[^$c]//g; $n = length( $chk ); $cnt{$n} .= " $c"; $maxn = $n if ( $maxn < $n ); $n = length( $cnt{$n} ); $maxw = $n if ( $maxw < $n ); } my $top = $main->Toplevel(-title => 'Crypto-count'); $n = scalar( keys( %cnt )); $maxw += 5; my $txt = $top->Text(width => $maxw, height => $n, font => $lfont )->pack; $top->Button(-text => "Dismiss", -command => sub { $top->destroy } )->pack; for ( $n=$maxn; $n>0; $n-- ) { if ( exists( $cnt{$n} )) { $txt->insert( 'end', sprintf( "%3d %s\n", $n, $cnt{$n} )); } } } sub updateSlvd { local $_ = $puzStr; my $trStr1 = my $trStr2 = ""; foreach my $c (@letters) { my $t = uc $ent{$c}->get; if ( $t ne "" ) { $trStr1 .= $c; $trStr2 .= $t; } } eval "tr/$trStr1/$trStr2/"; $solutn->delete('1.0','end'), $solutn->insert('1.0',$_); }