There's more than one way to do things PerlMonks

### Tk cryptogram (no, not cryptography)

by graff (Chancellor)
 on May 14, 2002 at 05:25 UTC ( #166379=CUFP: 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');
});

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,'_');
}
}
}
\$w->selectionRange(0,'end');
}

sub enSub {
my \$w = \$_;
\$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} ));
}
}
}

{
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',\$_);
}

Replies are listed 'Best First'.
Re: Tk cryptogram (no, not cryptography)
by brianarn (Chaplain) on May 14, 2002 at 17:48 UTC
I'm still learning Tk myself, so I can't really comment on much there - just one thing to add because I think it's a nice Perl feature. =)

You can create the @letters array with the following line:
my @letters = (a..z);

It's able to increment the letters up from a to z. I just think it's an interesting feature that people can play with. =)

~Brian
Re: Tk cryptogram (no, not cryptography)
by duggles (Acolyte) on Sep 23, 2009 at 14:09 UTC

This original post was over 7 years ago, but I downloaded the code about 2 years ago to study and use for my own purposes and then laid the project aside. A week or so ago, I picked it back up and made some modifications to suit my purposes (when I thought I was ready to tackle TK). I don't know if you or anyone else might still care about solving cryptograms, but I thought I'd post my (still evolving) code just in case you might be interested in the modifications.

The code I added is not too pretty, and I'm sure there are better (and easier/faster) ways to do what I've done, but the code does work. I'm still working on a better way to get the cryptogram from a file into the text box. The way it works now is after clicking "Read File" you have to put the cursor after the cryptogram in the text box and press enter. I'm just getting into TK so I've got LOTS to learn. The way I've got it now, a filename containing the cryptogram is required since if you just type it in to the text box, there are some problems I haven't resolved. Like I say, the code is still evolving.

The biggest thing I did was to add the ability to display the patterns of the words, and to make a file available to the script that can display all the words that match a given pattern. The smaller file (which I normally use) is 390k and the big version is almost 3MB so I uploaded the current version (as of 9/23/09) to my website.
sorted.patterns.txt 390k (current on 9/23/09)
and
sorted-combined-patterns.txt 2.7mb (current on 9/23/09)
These files are created by another script which reads in all the words in a file containing all the solved cryptograms I have done, and sorts them by word length, pattern, and frequency, which of course is a big help in solving cryptograms.

The "Select Word" button does nothing currently, but a future enhancement is to take the selected word that matched a pattern, and translate it to see if it might be the right one. An extremely useful enhancement would be to do this with multiple words.

Thank you so much for a very good example of how to use TK for what I feel is a very useful purpose!! ;-)

```#!/usr/bin/perl -w
# from http://www.perlmonks.org/index.pl?node_id=166379
# original code by graff

#TK notes for study
# GREAT Stuff here!!! http://phaseit.net/claird/comp.lang.perl.tk/ptkF
+AQ.html
# Good tutorial : http://www.bin-co.com/perl/perl_tk_tutorial/
# Good information here as well: http://www.ida.liu.se/~tompe/perltk/i
+ndex.html

# TO DO
#  take selected word(s) from a pattern and test it as a part of the s
+olution.

use strict;
use Tk;
use Text::Autoformat;

my (\$puzStr, \$solutionStr, %ent, %lbl);
my (\$crypto, \$solution, \$List, \$trStr1, \$trStr2, @template, @patterns)
+;
my \$patterns = "";
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/;
+  # lower case
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/;
+  #ALL CAPS
my \$tfont = "Courier 12";
my \$lfont = "Courier 10";
my \$file_passed = "";

if (\$ARGV ne "") {\$file_passed = \$ARGV; }
else {print "no file passed!!!\n"; exit; }

my \$which_dict = "<../sortedpatterns.txt";   # NO ZERO OCCURRENCES;
# This file is created by another perl script I use to read a file con
+taining all the cryptograms I have solved
# to create a list of patterns sorted by word length, the pattern, and
+ the frequency of use.
#FORMAT
#   Number of Letters - PATTERN - WORD - Occurences
#   3 =11 ALL 731
#   3 =11 TOO 212
#  .
#  .
#  .
#  .
#3 === THE 7933
#3 === AND 2983
#3 === YOU 2593
#3 === ARE 1348
# The much larger file includes words that I have yet to encounter but
+ are found in a dictionary of common words.
# Both of these files are available at my website:
# http://www.happenstance-music.com/sortedpatterns.txt  390k   (curren
+t on 9/23/09)
# http://www.happenstance-music.com/sorted-combined-patterns.txt  2.7m
+b  (current on 9/23/09)

#if (\$d) {
#    \$which_dict = "<../sorted-combined-patterns.txt";  # THE BIG ONE
#}

open(DICT, \$which_dict) || die "\$which_dict: \$!\n";
chomp(my @dict = <DICT>);
close DICT;

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # #
#   THIS IS THE TOP OF THE MAINLOOP!
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # #
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:",
\$main->Label(-text => "Click on \"Read File\", put cursor at the end o
+f the puzzle and press the \"Enter\" key:",
-font => \$lfont
)->pack(-side => 'top');
\$main->Button(
-command => sub { &readFile },
)->pack;
\$main->Button(
-text    => 'Quit',
-command => sub { &Quit },
)->pack;

my \$puzzle = \$main->Text(-relief => 'sunken',
-width => 126, -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);  # pady SP
+ECIFIES HOW MUCH VERTICAL EXTERNAL PADDING TO LEAVE ON EACH SIDE???

my \$row = my \$col = 1;
foreach my \$c (@letters)
{
\$lbl{\$c} = \$frm->Label(-text => " \$c>",
-font => \$tfont,
-foreground => \$bg
)->grid(-row => \$row,
-column => \$col++);
\$ent{\$c} = \$frm->Entry(-width => 1,
-font => \$tfont,
-borderwidth => 2,
-relief => 'flat'
)->grid(-row => \$row,
-column => \$col++ );
if ( \$c eq 'm' ) {
\$row = 2, \$col = 1;
}
}
\$row = 3; \$col = 12;
my \$btn1 = \$frm->Button(-text => "Show Counts",
-command => \&scSub,
-state => 'disabled',
)->grid(-row => \$row,
-column => \$col,
-columnspan => 5 );
\$row = 4; \$col = 12;
my \$btn2 = \$frm->Button(-text => "List Patterns / Suggest Words",
-command => \&listPatterns,
-state => 'disabled',
)->grid(-row => \$row,
-column => \$col,
-columnspan => 5 );
\$row = 5; \$col = 12;
my \$btn3 = \$frm->Button(-text => "Print Solved",
-command => \&printSolved,
-state => 'disabled',
)->grid(-row => \$row,
-column => \$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 => 126, -height => 6,
-font => \$tfont,
-wrap => 'word',
-spacing1 => '5p', -spacing2 => '0p', -spacin
+g3 => '1p'
)->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+\$//;
\$crypto = \$puzStr;
\$puzStr =~ s/ /  /g;
\$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);
\$btn1->configure(-state => 'normal');
\$btn2->configure(-state => 'normal');
\$btn3->configure(-state => 'normal');
});

MainLoop;

sub Quit { exit; }

if (\$file_passed ne "") {
open(CRYPTO, \$file_passed) || die "\$file_passed: \$!\n";
\$puzStr = <CRYPTO>;
chomp \$puzStr;
\$puzStr = lc \$puzStr;
\$crypto = \$puzStr;
}
&buildPatterns;
\$puzStr =~ s/\s+\$//;
\$puzzle->delete('1.0','end'), \$puzzle->insert('1.0',\$puzStr);
}

# KEY HAS BEEN RELEASED -  THIS IS WHERE WE HAVE ENTERED A LETTER TO B
+E TRANSLATED
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,'_');
}
}
}
\$w->selectionRange(0,'end');
}

# ENTER HAS BEEN PRESSED
sub enSub {
my \$w = \$_;
\$w->selectionRange(0,'end');
\$w->focus;
}

# SHOW COUNTS SUBROUTINE
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} ));
}
}
}

# PRINT SOLVED CRYPTOGRAM TO A TEXT BOX
sub printSolved {
local \$_ = \$crypto;
my \$solved = "";
my \$maxw = 100;
my \$top2 = \$main->Toplevel(-title => 'Cryptogram Solved');
\$maxw += 5;
my \$txt = \$top2->Text(width => \$maxw,
height => 5,
font => \$lfont
)->pack;
\$top2->Button(-text => "Dismiss",
-command => sub { \$top2->destroy }
)->pack;
eval "tr/\$trStr1/\$trStr2/";
\$solved  = \$_;
my \$formatted = autoformat \$solved, { case => 'sentence', right =>
+ 123 };
\$solved = \$solved . "\n" . \$formatted;
#print "\\$trStr1:\$trStr1\n\\$trStr2:\$trStr2\n\\$crypto: \$crypto\n\\$s
+olved: \$solved\n";
\$txt->insert( 'end', \$solved);

}
# UPDATE SOLVED TEXT  -

{
local \$_ = \$puzStr;
\$trStr1 = \$trStr2 = "";
foreach my \$c (@letters) {
my \$t = uc \$ent{\$c}->get;
if ( \$t ne "" ) {
\$trStr1 .= \$c;
\$trStr2 .= \$t;
}
}
eval "tr/\$trStr1/\$trStr2/";
my \$solution = \$patterns . "\n" . \$puzStr . "\n" . \$_;
\$solutionStr = \$_;
#\$solutn->delete('1.0','end'), \$solutn->insert('1.0',\$_);
\$solutn->delete('1.0','end'), \$solutn->insert('1.0',\$solution);
}

sub selectWord {
#print "nothing here yet....\n";
#print "future enhancement is to take the selected word, and trans
+late using it to see\n";
#print "if it might be the right one.\n";
#print "an extremely useful enhancement would be to do this with m
+ultiple words.\n";
}

sub selectPattern {
my \$selectedIndex =    \$List->curselection();
my \$selected = \$List->get(\$selectedIndex);
my @pattern_list = grep {/ \$selected /} @dict;
my \$top = \$main->Toplevel(-title => 'List Patterns');
my \$maxn = \$#pattern_list;
my \$maxw = 50;
my \$maxh = \$maxn +5;
my \$n;
my \$WordList = \$top->Listbox(-selectmode=>'single',
-height=>\$maxh,
-width=>\$maxw)->pack;
\$top->Button(-text => "Select a word/pattern",
-command => sub { &selectWord }
)->pack;
\$top->Button(-text => "Dismiss",
-command => sub { \$top->destroy }
)->pack;
for ( \$n = 0; \$n <= \$maxn; \$n++ ) {
\$WordList->insert( 'end', \$pattern_list[\$n] );
}
}

sub listPatterns {
my \$top = \$main->Toplevel(-title => 'Select Pattern');
my \$maxn = \$#patterns;
my \$maxw = 50;
my \$maxh = \$maxn +5;
my \$n;
#foreach my \$word (@patterns) {
#    print "\$word \n";
#}

\$List = \$top->Listbox(-selectmode=>'single',
-height=>\$maxh,
-width=>\$maxw)->pack;

#    my \$top = \$main->Toplevel(-title => 'patterns');
\$top->Button(-text => "Select a word/pattern",
-command => sub { &selectPattern }
)->pack;
\$top->Button(-text => "Dismiss",
-command => sub { \$top->destroy }
)->pack;
for ( \$n = 0; \$n <= \$maxn; \$n++ ) {
\$List->insert( 'end', \$patterns[\$n] );
}
}

sub suggestions {
my \$maxn = \$#patterns;
my \$maxw = 50;
my \$maxh = \$maxn +5;
my \$n;
my \$top = \$main->Toplevel(-title => 'patterns');
my \$txt = \$top->Text(width => \$maxw,
height => \$maxh,
font => \$lfont
)->pack;
\$top->Button(-text => "Select a word/pattern",
-command => sub { &selectWord }
)->pack;
\$top->Button(-text => "Dismiss",
-command => sub { \$top->destroy }
)->pack;
for ( \$n = 0; \$n <= \$maxn; \$n++ ) {
\$txt->insert( 'end', sprintf( "%2d %s\n", \$n, \$patterns[\$n
+] ));
}
}

#Build a pattern
sub doword {
#print "DOWORD SUB\n";
my \$cryptogram;
#my \$doword = uc shift;   #DON'T UPPERCASE IT SINCE IN THIS PROGRA
+M WE DIFFERENTIATE BETWEEN SOLVED AND UNSOLVED LETTERS BY UPPER/LOWER
+ CASE
my \$doword = shift;
my \$len = length \$doword;
my \$pat = '';
my \$got_a_pattern = 0;
my \$solution;
my @hits = ();
my @matchset = ('1', '2', '3', '4', '5', '6', '7', '8', '9', 'A',
+'B', 'C', 'D', 'E');
my (\$i,\$j,\$match,\$newmatch,\$mc);
for (\$i = 0; \$i < \$len; \$i++) {
if (substr(\$doword,\$i,1) ne "-") { substr(\$pat,\$i,1) = "="; }
else { substr(\$pat,\$i,1) = '-'; }

if (substr(\$doword,\$i,1) eq ":") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "'") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq ",") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq ".") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "!") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "?") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "\"") { substr(\$pat,\$i,1) = substr
+(\$doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "_") { substr(\$pat,\$i,1) = substr(
+\$doword,\$i,1); }

for (\$j = 0; \$j < 26; \$j++) {
if (substr(\$doword,\$i,1) eq \$letters[\$j]) {
\$hits[\$j]++;
}
}
} # (end of first big "for loop"
for (\$j = 0; \$j < 52; \$j++) {
if (defined \$hits[\$j]) {
if (\$hits[\$j] > 1) {
\$got_a_pattern = 1;
}
}
} # (end of this little "for loop"
if (\$got_a_pattern)  {
\$match = 0;
\$newmatch = 0;
#       go through the word a letter at a time
for (\$i = 0; \$i < \$len; \$i++) {
if (substr(\$pat,\$i,1) eq '=') {
if (\$newmatch > 0) {
\$match++;
\$newmatch = 0;
}
\$mc = \$matchset[\$match];
}
#   go through the rest of the word beginning at \$i+1
if (substr(\$pat,\$i,1) eq '=') {
for (\$j =\$i+1; \$j < \$len; \$j++) {
if (substr(\$doword,\$i,1) eq substr(\$doword,\$j,1))
+{
substr(\$pat,\$i,1) = \$mc;
substr(\$pat,\$j,1) = \$mc;
\$newmatch++;
}
}
}
} # (end of for loop)
} # (end of if \$pattern loop)
return \$pat;
}    # (end of doword subroutine)

# Get an array of all the words
sub  extractTemplates {
my \$crypt = shift;
# extract templates by splitting on whitespace
my  @template2 = split / /,\$crypt;
# remove leading and trailing punctuation
# add templates not already in the list, to the template list
my \$which_word = 0;
foreach ( @template2 ) {
my \$len1 = (length \$_) -1;
\$which_word++;
}
foreach (@template2) {
\$_  =~ tr/ //d;
if (\$_ eq " ") { next; }
push @template,\$_;
}
return @template;

} # END OF EXTRACTTEMPLATES

sub buildPatterns {
# FIRST BUILD AN ARRAY (@template) WITH ALL THE WORDS IN IT - INCL
+UDING PUNCTUATION
extractTemplates (\$crypto);
# NOW BUILD THE \$patterns STRING AND  THE @patterns ARRAY
# THE STRING IS USED IN THE DISPLAY - THE  ARRAY CAN BE USED FOR S
+UGGESTED SUBSTITUTION
foreach (@template) {
#print "\$_\n";
my \$pat = doword (\$_);
\$patterns .= \$pat ."  ";
# STRIP PUNCTUATION FROM EACH ITEM BEFORE ADDING IT TO THE ARR
+AY
\$pat  =~ tr/.,:;!?"(){}//d;
push @patterns,\$pat;
}
}

Hope this meets with monk standards... I removed a lot of unneccessary comments, but wasn't sure if I should try to shorten the code listing or not... I'm still learning, if I erred, I apologize..

Duggles...
Life is short, but it's wide -- Chuck Pyle
Thank you so much...

You're so welcome! I'm glad to see someone having fun with this. Do you happen to have a source of cryptograms in electronic form, such that you can extract input files for use with your version of the script? Or are you just using a text editor to create your input files? (I would have used my version more often if I didn't have to always type in the puzzle from the newspaper or puzzle book.)

If you're going to insist on having a puzzle file provided as a command-line arg, you can leave out the "Read File" button -- just call your "readFile" sub before you call MainLoop.

As for loading (a big or huge version of) a "dictionary" file that has been crafted in some strange and mysterious way, that seems like too much work -- there must be a way to just use a simple word list. I would point out that your format doesn't really need the initial "string length" field, since this is evident from the string itself.

I don't really understand what's going on with the patterns and the dictionary, but alas, I feel like you ought to be scolded about this part of your "doword" sub:

```    ...
my @hits = ();
...
for (\$i = 0; \$i < \$len; \$i++) {
if (substr(\$doword,\$i,1) ne "-") { substr(\$pat,\$i,1) = "="; }
else { substr(\$pat,\$i,1) = '-'; }

if (substr(\$doword,\$i,1) eq ":") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "'") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq ",") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq ".") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "!") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "?") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "\"") {substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }
if (substr(\$doword,\$i,1) eq "_") { substr(\$pat,\$i,1) = substr(\$
+doword,\$i,1); }

for (\$j = 0; \$j < 26; \$j++) {
if (substr(\$doword,\$i,1) eq \$letters[\$j]) {
\$hits[\$j]++;
}
}
}                           # (end of first big "for loop"
for (\$j = 0; \$j < 52; \$j++) {
if (defined \$hits[\$j]) {
if (\$hits[\$j] > 1) {
\$got_a_pattern = 1;
}
}
}                           # (end of this little "for loop"
if (\$got_a_pattern)  {
...
Apart from those comments being a waste, I think all those calls to substr could be replaced with something like this:
```    ...
for my \$chr ( split //, \$doword ) {
\$pat .= ( \$chr =~ /\W/ ) ? \$chr : '=';
for my \$ltr ( @letters ) {
\$got_a_pattern++ if ( \$chr eq \$ltr );
}
}
if (\$got_a_pattern)  {
...
One other nit-pick, in the "extractTemplates" sub:
```    foreach (@template2) {
\$_  =~ tr/ //d;
if (\$_ eq " ") { next; }
push @template,\$_;
}
Notice how the "if" condition there can never return true, because all the spaces in the string have been removed by the previous "tr///"; meanwhile, you are able to push empty strings onto your @template array. Maybe you want it to be like this?
```        tr/ //d;
push @template, \$_  if (\$_);  # true when \$_ is not an empty s
+tring
But I don't know what difference it makes in how things actually work. I noticed that if you hit the enter key more than once, you get extra spacing in some of the strings being displayed (but fixing that "if" condition didn't change this behavior). Anyway, good luck with that.

Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://166379]
Approved by Zaxo
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (2)
As of 2023-02-07 01:50 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
{"ft_lang_label":"__label__en","ft_lang_prob":0.69907576,"math_prob":0.7807832,"size":23623,"snap":"2022-40-2023-06","text_gpt3_token_len":7908,"char_repetition_ratio":0.13340954,"word_repetition_ratio":0.37472284,"special_character_ratio":0.40143082,"punctuation_ratio":0.19763264,"nsfw_num_words":0,"has_unicode_error":false,"math_prob_llama3":0.9692307,"pos_list":[0,1,2],"im_url_duplicate_count":[null,null,null],"WARC_HEADER":"{\"WARC-Type\":\"response\",\"WARC-Date\":\"2023-02-07T01:50:15Z\",\"WARC-Record-ID\":\"<urn:uuid:a1042f49-7c6f-48fa-b1d0-23f4a901539b>\",\"Content-Length\":\"57844\",\"Content-Type\":\"application/http; msgtype=response\",\"WARC-Warcinfo-ID\":\"<urn:uuid:33d2a09a-e5f7-499a-89e5-4decd4e7ebf0>\",\"WARC-Concurrent-To\":\"<urn:uuid:01d9c932-55b9-4d68-8127-49ee336770ef>\",\"WARC-IP-Address\":\"216.92.34.251\",\"WARC-Target-URI\":\"https://www.perlmonks.org/?node_id=166379\",\"WARC-Payload-Digest\":\"sha1:X3UOR5ZILKR3TCFZV6IHTUTOU7D5YCA5\",\"WARC-Block-Digest\":\"sha1:LKLDLZSI2F6KOQRLV6OQAGRLZNCAXZMP\",\"WARC-Identified-Payload-Type\":\"text/html\",\"warc_filename\":\"/cc_download/warc_2023/CC-MAIN-2023-06/CC-MAIN-2023-06_segments_1674764500368.7_warc_CC-MAIN-20230207004322-20230207034322-00813.warc.gz\"}"}