comment on

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',$_);
}
[download]

In reply to Tk cryptogram (no, not cryptography) by graff

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


"be consistent"
	PerlMonks