CUFP
graff
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...)
<P>
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 <em>such a drag</em>, 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.
<P>
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?)
<code>
#!/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', -spacing3 => '5p'
)->pack(-side => 'top');
my $nxt = $main->Label(-text => "Now type a letter in each of these boxes 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', -spacing3 => '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',$_);
}
</code>