Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
#!/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 $alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; 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); $win->add($vbox); 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); $win->add_accel_group($menu->{accel_group}); new_puzzle(); Gtk2->main(); sub new_puzzle{ $victorious = FALSE; %guesses = (); $fortune = uc get_fortune($min_fortune, $max_fortune); gen_random_key(); count_letters(); reload_crypto_tables(); } 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); reloadFortuneView(); reloadGuessTable(); $win->show_all; } 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) = @_; while(1){ 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 +otes) $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[$_]) { gen_random_key(); #print "key not deranged, setting another..\n"; return; } } } sub getGuess{ my $char = shift; return $char if $char !~ /[A-Z]/; #space, num, or punctuatio +n 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)); useMyLabelFont($label1); insert_char_label ($label1, $colnum, 3*$rownum); push @{$guessLabels{$char}}, $label1; my $label2 = Gtk2::Label->new (encrypt($char)); useMyLabelFont($label2); 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); useMyLabelFont($lbl); $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); $widget->show_all(); } #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{$_}){ $sameAsGuess{$_}=1; 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 $_; $multiple_guesses{$_}++; #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; } #unyellow: 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); } else{ $entry->set_text(''); delete $guesses{$char} } #adjust fortuneview to new guess for my $lbl ( @{ $guessLabels {decrypt($char)} } ){ my $text = $guesses{$char} ? $guesses{$char} : '_'; $lbl->set_text($text) } set_entry_conflicts(); if (detectVictory()){ doVictory() } } 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; $label->modify_font($labelfont); } sub useMyEntryFont{ my $label = shift; $label->modify_font($entryfont); } #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); $victWin->add($vb); $victWin->show_all; } 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); $cheatWin->add($vb); $cheatWin->show_all; } BEGIN{ # if I don't do this, Text::Wrap will turn spaces into tabs $Text::Wrap::unexpand = 0; }

In reply to quick and dirty cryptogram puzzle by Snarius

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



  • 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.
Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (4)
As of 2024-03-28 21:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found