Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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[0] ne "") {$file_passed = $ARGV[0]; } 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( -text => 'Read File', -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'); &updateSlvd; }); MainLoop; sub Quit { exit; } # Read in a file sub readFile { 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,'_'); } } } &updateSlvd; $w->selectionRange(0,'end'); } # ENTER HAS BEEN PRESSED sub enSub { my $w = $_[0]; $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 - sub updateSlvd { 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 not already matched 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

In reply to Re: Tk cryptogram (no, not cryptography) by duggles
in thread 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 avoiding work at the Monastery: (9)
    As of 2014-07-11 03:00 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      When choosing user names for websites, I prefer to use:








      Results (217 votes), past polls