Beefy Boxes and Bandwidth Generously Provided by pair Networks vroom
We don't bite newbies here... much
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
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',$_); }

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

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others romping around the Monastery: (9)
    As of 2014-04-17 10:35 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      April first is:







      Results (444 votes), past polls