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

quick and dirty cryptogram puzzle

by Snarius (Sexton)
on Jan 01, 2008 at 09:37 UTC ( #659856=sourcecode: print w/replies, xml ) Need Help??
Category: Fun stuff
Author/Contact Info Zach Morgan
Description: Here's a little game that I made today. It finds a fortune using the fortune command, scrambles the letters using a substitution cipher, and has you guess what each letter represents.

This requires fortune and gtk2-perl

This can be challenging. If you have trouble, either increase the mininum fortune size or use the Jack Bauer fortune file.

It can also be very easy. A lot of fortunes have unique patterns that are easy to spot.

I made this for my grandfather, but I don't know if I'll have a chance to set it up on his computer.
#!/usr/bin/perl -w
use strict;

use Gtk2 '-init';
#use Gtk2::SimpleList;  
use Gtk2::SimpleMenu;
use Text::Wrap;
sub TRUE{1} sub FALSE{0}

my $min_fortune=80;
my $max_fortune=130;
my $fortune_command = "fortune -n $min_fortune -l";
my $numColumns = 40;
my $font_size = 15;

my $fortune;
my $key;
my $victorious = FALSE;
my %encrypt;
my %decrypt;
my %guesses;  #win when enough of %guesses is like %decrypt. (not all 
+letters are used.)
my %guessLabels; #lists of (empty at first) labels in fortuneview
my @guessEntries; #list of 26 entries in guesstable
my %letterCount;  #unencrypted
my %enc_letterCount;
my $victory_message = 
    "Congratulations.\n You took 5 points from Jack Bauer. \nRun.";
my $labelfont = Gtk2::Pango::FontDescription->from_string("Andale Mono
+ Bold $font_size");
my $entryfont = Gtk2::Pango::FontDescription->from_string("Andale Mono
+ $font_size");

my $win = Gtk2::Window->new();
$win->signal_connect("delete_event", sub {Gtk2->main_quit} );

my $fortuneView;
my $guessTable;

my $vbox = Gtk2::VBox->new(FALSE,0);

my $menu_tree = [
    _File => {
        item_type => '<Branch>',
        children => [
            _New => {
                item_type => '<StockItem>',
                callback => \&new_puzzle,
                callback_action => 0,
                accelerator => '<ctrl>N',
                extra_data => 'gtk-new',
            _Cheat => {
                callback => \&cheat,
                callback_action => 1,
                callback_data => 'per entry cbdata',
                accelerator => '<ctrl>C',
            _Quit => {
                item_type => '<StockItem>',
                callback => sub{Gtk2->main_quit},
                callback_action => 2,
                accelerator => '<ctrl>Q',
                extra_data => 'gtk-quit',
my $menu = Gtk2::SimpleMenu->new (
        menu_tree => $menu_tree,
        default_callback => sub {print "unimplemented\n"},
        user_data => 'user_data',

$vbox->pack_start($menu->{widget}, TRUE, FALSE, 0);


sub new_puzzle{
    $victorious = FALSE;
    %guesses = ();
    $fortune = uc get_fortune($min_fortune, $max_fortune);

sub reload_crypto_tables{
    $fortuneView->destroy if defined $fortuneView;
    $guessTable->destroy if defined $guessTable;
    $fortuneView = Gtk2::Table->new(6, $numColumns);
    $guessTable = Gtk2::Table->new(2, 26, TRUE);
    $vbox->pack_start($fortuneView, TRUE, FALSE, 0);
    $vbox->pack_start($guessTable, TRUE, FALSE, 0);

sub count_letters{
    %letterCount = ();
    %enc_letterCount = ();
    for my $char (split //, $fortune){
        $letterCount{$char}++  if  $char =~ /[A-Z]/;
        $char = encrypt($char);
        $enc_letterCount{$char}++  if  $char =~ /[A-Z]/;
        $guesses{$char} = '' if $char  =~ /[A-Z]/;

sub get_fortune{
    my ($min,$max) = @_;
        my $fortune = `$fortune_command`;
        next if length ($fortune) < $min;
        next if length ($fortune) > $max;
        $fortune =~ s/\t/   /g; #tabs to (3) spaces
        #newlines to 1 space, unless there's space after it. (as in qu
        $fortune =~ s/\n(\S)/ $1/g; 
        return $fortune;

#modified fisher yates shuffle
sub gen_random_key{
    my @array = split (//, $alpha);
    my @alpha = @array;
    for (my $i = @array; --$i; ) {
        my $j = int rand ($i+1);
        @array[$i, $j] = @array[$j, $i];
    for (0..$#alpha){
        $decrypt{$alpha[$_]} = $array[$_];
        $encrypt{$array[$_]} = $alpha[$_];
    #ensure a derangement
    for (0..$#alpha){
        if ($alpha[$_] eq $array[$_]) {
            #print "key not deranged, setting another..\n";

sub getGuess{
    my $char = shift;
    return $char    if    $char !~ /[A-Z]/; #space, num, or punctuatio
    return $guesses{$char}  if $guesses{$char};
    return '_';

sub encrypt{
    my $char = shift;
    return $char unless defined $encrypt{$char};
    return $encrypt{$char};
sub decrypt{
    my $char = shift;
    return $char unless defined $encrypt{$char};
    return $decrypt{$char};

#is for fortuneview:
sub insert_char_label{
    my ($lbl, $col, $row) = @_;
    $fortuneView->attach_defaults ($lbl, $col,$col+1, $row,$row+1);

#split into lines and then split each line into chars
sub get_fortune_chars{
    $Text::Wrap::columns = $numColumns;
    my @splitFortune = split ("\n", wrap('','',$fortune));
    @splitFortune = map { [split(//,$_)] } @splitFortune;
    return @splitFortune;

#set data in the table
sub reloadFortuneView{
    %guessLabels = ();
    my @splitFortune = get_fortune_chars();
    for (my $rownum=0 ; $rownum<@splitFortune ; $rownum++){
        my @line=@{$splitFortune[$rownum]};
        for (my $colnum=0 ; $colnum<@line ; $colnum++){
            my $char=$line[$colnum];
            my $label1 = Gtk2::Label->new (getGuess ($encrypt{$char} o
+r $char));
            insert_char_label ($label1, $colnum, 3*$rownum);
            push @{$guessLabels{$char}}, $label1;
            my $label2 = Gtk2::Label->new (encrypt($char));
            insert_char_label ($label2, $colnum, 3*$rownum+1);
        insert_char_label(Gtk2::Label->new(' '), 0, 3*$rownum+2);

sub reloadGuessTable{
    my @alpha = split //, $alpha; #all uc letters
    for (0..$#alpha){
        my $char = $alpha[$_];
        my $guessEntry = Gtk2::Entry->new_with_max_length (1);
        useMyEntryFont ($guessEntry);
        $guessEntry->set_size_request ($font_size+6, $font_size*2);
        my $guess = '';
        $guessEntry->set_text ($guess);
        $guessTable->attach_defaults ($guessEntry, $_,$_+1, 0,1);
        $guessEntry->signal_connect("changed", \&make_guess, $char);
        $guessEntries[$_] = $guessEntry;
        my $lbl = Gtk2::Label->new ($char);
        $guessTable->attach_defaults ($lbl, $_,$_+1, 1,2);
sub setGuessBgColor{
    my ($char, $color) = @_;
    my $widget = $guessEntries[ord($char) - ord('A')];
    $color = Gtk2::Gdk::Color->parse ($color);
    $widget->modify_base('normal', $color);
#letters never represent themselves. Blue when people guess otherwise.
#letter representations are one-to-one. Yellow when that is violated.
my %blues;
my %yellows;
sub set_entry_conflicts{
    #key and guess should be different
    my %sameAsGuess;
    for (keys %guesses){
        if ($_ eq $guesses{$_}){
            unless ($blues{$_}){ 
                setGuessBgColor($_, 'lightblue');
                $blues{$_} = 1;
    for (keys %blues){
        unless ($sameAsGuess{$_}){
            setGuessBgColor($_, 'white');
            setGuessBgColor($_, 'yellow') if $yellows{$_};
            delete $blues{$_};
    #only one-to-one guesses
    my %multiple_guesses;
    for (values %guesses){
        next unless defined $_;
        #print $_;
    for my $key (keys %guesses){
        my $guess = $guesses{$key};
        next unless $guess;
        next unless defined $multiple_guesses{$guess};
        next unless ($multiple_guesses{$guess} > 1);
        next if $yellows{$key};
        #warn "$key $guess $multiple_guesses{$guess}";
        setGuessBgColor($key, 'yellow');
        $yellows{$key} = 1;
    for (keys %yellows){
        next if $guesses{$_} and $multiple_guesses{$guesses{$_}} > 1;
        setGuessBgColor($_, 'white');
        setGuessBgColor($_, 'lightblue') if $blues{$_};
        delete $yellows{$_};

sub make_guess{
    my ($entry, $char) = @_;
    my $guess = $entry->get_text;
    if ($guess =~ /[A-Za-z]/){
        $guesses{$char} = uc $guess;
        $entry->set_text(uc $guess);
        delete $guesses{$char}
    #adjust fortuneview to new guess
    for my $lbl ( @{ $guessLabels {decrypt($char)} } ){
        my $text = $guesses{$char} ? $guesses{$char} : '_';
    if (detectVictory()){
sub detectVictory{
    return 0 if $victorious;
    my $lettersCorrect = 0;
    for my $char (keys %enc_letterCount){
        return 0 unless defined $guesses{$char};
        return 0 if $guesses{$char} ne $decrypt{$char}
    return 1;

sub useMyLabelFont{
    my $label = shift;
sub useMyEntryFont{
    my $label = shift;

#display victory window
sub doVictory{
    $victorious = TRUE;
    my $victWin = Gtk2::Window->new();
    my $label = Gtk2::Label->new($victory_message);
    useMyLabelFont ($label);
    my $okbutton = Gtk2::Button->new("ok");
    $okbutton->signal_connect("clicked", sub {$victWin->destroy} );
    my $vb = Gtk2::VBox->new(FALSE,0);
    $vb->pack_start($label, TRUE, FALSE, 0);
    $vb->pack_start($okbutton, TRUE, FALSE, 0);

sub cheat{
    my $cheatWin = Gtk2::Window->new();
    $Text::Wrap::columns = $numColumns;
    my $wrappedFortune = wrap('','',$fortune);
    my $label = Gtk2::Label->new($wrappedFortune);
    useMyLabelFont ($label);
    my $okbutton = Gtk2::Button->new("ok");
    $okbutton->signal_connect("clicked", sub {$cheatWin->destroy} );
    my $vb = Gtk2::VBox->new(FALSE,0);
    $vb->pack_start($label, TRUE, FALSE, 0);
    $vb->pack_start($okbutton, TRUE, FALSE, 0);
    # if I don't do this, Text::Wrap will turn spaces into tabs
    $Text::Wrap::unexpand = 0;
Replies are listed 'Best First'.
Re: quick and dirty cryptogram puzzle
by graff (Chancellor) on Jan 01, 2008 at 18:04 UTC
    Thanks!++ I enjoy the occasional cryptogram puzzle, and I'm always glad to find a good example of using a GUI library other than Tk, so I was really happy to see this.

    There's just one thing about your "gen_random_key" function (update: as it was originally posted, without the "derangement" part), and it's an issue I had thought of posting here at the Monastery under SoPW. In every published cryptogram puzzle I've ever seen (i.e. in newspapers and puzzle books), the shuffling of the substitution cipher is always "complete", in the sense that no letter is ever "substituted" with itself. Unfortunately, your gen_random_key function does not have this property.

    It's not clear to me whether your algorithm for shuffling differs in method from the "standard" shuffle (e.g. as provided in List::Util), but having looked at the results of both approaches, they seem to produce the same quality of output with regard to "completeness" of the shuffle: as often as not, one or more of the "substitution" pairs end up with the same letter as both "clear text" and "cipher" (e.g. "B is replaced by B").

    So, being rather rusty with sorting and shuffling algorithms, I'm wondering: what would be a "good" method for doing a complete shuffle (where "good" means "efficient", and/or "not requiring an indeterminate number of iterations"). For example, the following "complete_shuffle" function will never return anything other than a completely shuffled list, but the problem is it may try hundreds of random numbers before finishing a list of 26 items, and for reasons I have not yet figured out, sometimes it simply does not return at all...

    sub complete_shuffle { my @sorted = @_; my @shuffled = (); my $niters = 0; my %shuff_used = (); for my $i ( 0 .. $#sorted ) { my $j = $i; while ( $j == $i or exists( $shuff_used{$j} )) { $j = int(rand(@sorted)); $niters++; } $shuffled[$j] = $sorted[$i]; $shuff_used{$j}++; } warn "complete shuffle finished in $niters iterations\n"; return @shuffled; }
    I suspect there are good reasons for solving the "complete shuffle" problem (besides wanting to do cryptogram puzzles), so I'd like to know how to solve it properly.
        Aha! Thanks. This is a perfect demonstration of the fundamental problem for search-engine users: of course there would be a "jargon term" that designates exactly the particular concept you have in mind -- but when you don't know that term, searches based on various descriptions of (circumlocutions about) the concept tend to have very low precision (and recall success for such queries can be no better than a crap-shoot). There's no substitute for relevant experience...
      Thanks for the criticism! I've not played many cryptograms, so I wasn't familiar with that idea. I wouldn't have called it a "complete shuffle" though. An "incomplete shuffle", maybe :)

      I've added a bit to my shuffling function to ensure a derangement. It's a bit quick and dirty...
      sub gen_random_key{ ####sub fisher_yates_shuffle { my @array = split ("", $alpha); my @alpha = @array; for (my $i = @array; --$i; ) { my $j = int rand ($i+1); next if $i == $j; @array[$i, $j] = @array[$j, $i]; } for (0..$#alpha){ $decrypt{$alpha[$_]} = $array[$_]; $encrypt{$array[$_]} = $alpha[$_]; } #ensure a derangement for (0..$#alpha){ if ($alpha[$_] eq $array[$_]) { gen_random_key(); #warn 'key not deranged, setting another..'; return; } } }
        next if $i == $j;
        This line is unnecessary. It's been discussed before here and elsewhere, but in an array of any significant size (>10 or 20 or so), the odds that i and j are equal are low enough that the logic to test if they are equal outweighs the cost of just swapping the array element with itself (i.e. you're testing to see if they're equal on every iteration, costing something on every iteration, where if you dont' test you'd hardly ever be swapping something with itself anyway).

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://659856]
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (3)
As of 2020-09-27 10:05 GMT
Find Nodes?
    Voting Booth?
    If at first I donít succeed, I Ö

    Results (142 votes). Check out past polls.