#!/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;
}
-
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.