Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Mastermind Game in Perl/Tk

by Anonymous Monk
on Jan 23, 2007 at 15:50 UTC ( #596111=sourcecode: print w/replies, xml ) Need Help??
Category: fun stuff
Author/Contact Info Fabrizio Romano mauvais25@hotmail.com
Description: A version in perl/tk of the game known as Master Mind, it's not an example of good programming, sure, but it works :)

use Tk;
my $mw = MainWindow->new;
$code_font = $mw->fontCreate('code', -family => 'verdana', -size => 7)
+;
$code_font2 = $mw->fontCreate('font2', -family => 'verdana', -size => 
+12);
$linea = 1;

###############
# Subroutines #
sub start {
    &reclean;
    if ( $won == 1 ) {$winlabel->destroy;
              $won -= 1;
              $linea->delete($fuoco)};
    $coor = 10;
    $hiduno = int(rand 6) + 1;
    $hiddue = int(rand 6) + 1;
    $hidtre = int(rand 6) + 1;
    $hidquattro = int(rand 6) + 1;
    #print "uno:$hiduno,due:$hiddue,tre:$hidtre,quattro:$hidquattro";
    $nascosto = $mw->Canvas(-background => "black")->place(-relx => 0.
+0, -rely => 0.00, -relwidth => 0.4, -relheight => 0.1);  
    $qm = $nascosto->createText(40,10, -text => "?  ?  ?  ?", -fill =>
+ "white", -font => 'font2');
    $mialabel->configure(-text => "Line 1- choose colors");
    $fuoco = $steps[0]->createText($coor,8, -text=>"?", -fill => "whit
+e"); #x: 10,30,50,70
    $activeline = 1;
    $cerchio = 1;
    $coor = 10;
    }
    
    
sub colora {
    &cercalinea;
    &cercacerchio;
    $linea->delete($fuoco);
    $n = shift;
    $color = $linea->itemconfigure("$circ", -fill=>     "$n");
    #print "\n$coor\n";
    if ( $coor < 70 ) {
    $coor += 20;
    $fuoco = $linea->createText($coor,8, -text=>"?", -fill => "white")
+; #x: 10,30,50,70
    $cerchio += 1;
        }
    else {
        &valuta;
        if ( $activeline < 10 ) {
        $activeline += 1;
    }
    else {
        $loselabel = $mw->Label(-text => "You Lost!\n Press start to p
+lay again", -font => 'code', -background => "black", -foreground => "
+white")
            ->place(-relx => 0.2, -rely => 0.5, -relwidth => 0.6, -rel
+height => 0.3);
            }
        $coor = 10;
        &cercalinea;
        $fuoco = $linea->createText($coor,8, -text=>"?", -fill => "whi
+te"); #x: 10,30,50,70
        $mialabel->configure(-text => "Line $activeline- choose colors
+");
        $cerchio = 1;
        }
    }

sub cercalinea {
    if ($activeline == 1) { $linea =    $steps[0];}
    elsif ($activeline == 2) { $linea = $steps[1];}
    elsif ($activeline == 3) { $linea = $steps[2];}
    elsif ($activeline == 4) { $linea = $steps[3];}
    elsif ($activeline == 5) { $linea = $steps[4];}
    elsif ($activeline == 6) { $linea = $steps[5];}
    elsif ($activeline == 7) { $linea = $steps[6];}
    elsif ($activeline == 8) { $linea = $steps[7];}
    elsif ($activeline == 9) { $linea = $steps[8];}
    elsif ($activeline == 10) { $linea =$steps[9];}
        }

sub cercacerchio {
    if ($cerchio == 1) { $circ =$uno }
    elsif ($cerchio == 2) { $circ =$due }
    elsif ($cerchio == 3) { $circ =$tre }
    elsif ($cerchio == 4) { $circ =$quattro }
        }

sub valuta { 
    $buone = 0;
    $mezze = 0;
    $primo = $linea->itemcget("$uno", -fill);
    $secondo = $linea->itemcget("$due", -fill);
    $terzo = $linea->itemcget("$tre", -fill);
    $quarto = $linea->itemcget("$quattro", -fill);
    #print "primo: $primo\nsecondo: $secondo\nterzo: $terzo\nquarto: $
+quarto\n";
    &trasforma;

$hid[1] = 0;
$hid[2] = 0;
$hid[3] = 0;
$hid[4] = 0;
$mia[1] = 0;
$mia[2] = 0;
$mia[3] = 0;
$mia[4] = 0;

    if    ( $a == $hiduno     ) { $buone +=1 ;$hid[1] = 1 ; $mia[1] = 
+1}
    if    ( $b == $hiddue     ) { $buone +=1 ;$hid[2] = 1 ; $mia[2] = 
+1}
    if    ( $c == $hidtre     ) { $buone +=1 ;$hid[3] = 1 ; $mia[3] = 
+1}
    if    ( $d == $hidquattro ) { $buone +=1 ;$hid[4] = 1 ; $mia[4] = 
+1}
    
    if ( $a == $hiddue && $hid[2] == 0 && $mia[1] == 0 ) { $mezze +=1 
+;$hid[2] = 1 }
        elsif ( $a == $hidtre && $hid[3] == 0 && $mia[1] == 0 ) { $mez
+ze +=1 ;$hid[3] = 1 }
        elsif ( $a == $hidquattro && $hid[4] == 0 && $mia[1] == 0 ) { 
+$mezze +=1 ;$hid[4] = 1 }
        
    if ( $b == $hiduno && $hid[1] == 0 && $mia[2] == 0) { $mezze +=1 ;
+$hid[1] = 1 }
        elsif ( $b == $hidtre && $hid[3] == 0 && $mia[2] == 0) { $mezz
+e +=1 ;$hid[3] = 1 }
        elsif ( $b == $hidquattro && $hid[4] == 0 && $mia[2] == 0) { $
+mezze +=1 ;$hid[4] = 1 }
        
    if ( $c == $hiduno && $hid[1] == 0 && $mia[3] == 0) { $mezze +=1 ;
+$hid[1] = 1 }
        elsif ( $c == $hiddue && $hid[2] == 0 && $mia[3] == 0) { $mezz
+e +=1 ;$hid[2] = 1 }
        elsif ( $c == $hidquattro && $hid[4] == 0 && $mia[3] == 0) { $
+mezze +=1 ;$hid[4] = 1 }
        
    if ( $d == $hiduno && $hid[1] == 0 && $mia[4] == 0) { $mezze +=1 ;
+$hid[1] = 1 }
        elsif ( $d == $hiddue && $hid[2] == 0 && $mia[4] == 0) { $mezz
+e +=1 ;$hid[2] = 1 }
        elsif ( $d == $hidtre && $hid[3] == 0 && $mia[4] == 0) { $mezz
+e +=1 ;$hid[3] = 1 }
    
    #print "buone: $buone\nmezze: $mezze\n";
        if ( $buone == 4 ) {
        $won = 1;
        $winlabel = $mw->Label(-text => "You Won!\n Press start to pla
+y again", -font => 'code', -background => "black", -foreground => "wh
+ite")
            ->place(-relx => 0.2, -rely => 0.3, -relwidth => 0.6, -rel
+height => 0.3);
            }
    &risultato;
    }

sub risultato {
    $keok = 0;
    while ( $buone > 0 ) {
        $keok +=1;
        $colorok = $linea->itemconfigure($ok[$keok], -fill=>     "blac
+k");
        #print "buone: $buone\n";
        #print "okkeok:$ok[$keok]\n";
        $buone -=1;
    }
        while ( $mezze > 0 ) {
        $keok +=1;
        $colorok = $linea->itemconfigure($ok[$keok], -fill=>     "whit
+e");
        #print "buone: $buone\n";
        #print "okkeok:$ok[$keok]\n";
        $mezze -=1;
        }    
}

sub trasforma {
    
    if ( $primo eq "red") { $a=1 }
    elsif ( $primo eq "blue") { $a=2 }
    elsif ( $primo eq "green") { $a=3 }
    elsif ( $primo eq "yellow") { $a=4 }
    elsif ( $primo eq "purple") { $a=5 }
    elsif ( $primo eq "orange") { $a=6 }
    if ( $secondo eq "red") { $b=1 }
    elsif ( $secondo eq "blue") { $b=2 }
    elsif ( $secondo eq "green") { $b=3 }
    elsif ( $secondo eq "yellow") { $b=4 }
    elsif ( $secondo eq "purple") { $b=5 }
    elsif ( $secondo eq "orange") { $b=6 }
    if ( $terzo eq "red") { $c=1 }
    elsif ( $terzo eq "blue") { $c=2 }
    elsif ( $terzo eq "green") { $c=3 }
    elsif ( $terzo eq "yellow") { $c=4 }
    elsif ( $terzo eq "purple") { $c=5 }
    elsif ( $terzo eq "orange") { $c=6 }
    if ( $quarto eq "red") { $d=1 }
    elsif ( $quarto eq "blue") { $d=2 }
    elsif ( $quarto eq "green") { $d=3 }
    elsif ( $quarto eq "yellow") { $d=4 }
    elsif ( $quarto eq "purple") { $d=5 }
    elsif ( $quarto eq "orange") { $d=6 }
    }
    
    
######################
# Disegno le 10 aree #
$steps[0] = $mw->Canvas(-background => gray55)->place(  -relx => 0.4, 
+-rely => 0.8,  -relwidth => 0.6, -relheight => 0.09);
$steps[1] = $mw->Canvas(-background => gray52)->place(-relx => 0.4, -r
+ely => 0.71, -relwidth => 0.6, -relheight => 0.09);
$steps[2] = $mw->Canvas(-background => gray49)->place(  -relx => 0.4, 
+-rely => 0.62, -relwidth => 0.6, -relheight => 0.09);
$steps[3] = $mw->Canvas(-background => gray46)->place( -relx => 0.4, -
+rely => 0.53, -relwidth => 0.6, -relheight => 0.09);
$steps[4] = $mw->Canvas(-background => gray43)->place( -relx => 0.4, -
+rely => 0.44, -relwidth => 0.6, -relheight => 0.09);
$steps[5] = $mw->Canvas(-background => gray40)->place(  -relx => 0.4, 
+-rely => 0.35, -relwidth => 0.6, -relheight => 0.09);
$steps[6] = $mw->Canvas(-background => gray37)->place(-relx => 0.4, -r
+ely => 0.26, -relwidth => 0.6, -relheight => 0.09);
$steps[7] = $mw->Canvas(-background => gray34)->place( -relx => 0.4, -
+rely => 0.17, -relwidth => 0.6, -relheight => 0.09);
$steps[8] = $mw->Canvas(-background => gray31)->place(   -relx => 0.4,
+ -rely => 0.08, -relwidth => 0.6, -relheight => 0.09);
$steps[9] = $mw->Canvas(-background => gray29)->place( -relx => 0.4, -
+rely => 0.00, -relwidth => 0.6, -relheight => 0.09);

############################
# Definizione dei pulsanti #
$exitbtt = $mw->Button(-text => "Exit", -font => 'code', -command => s
+ub { exit })
    ->place(-relx => 0.8, -rely => 0.9, -relwidth => 0.2, -relheight =
+> 0.1);
$startbtt = $mw->Button(-text => "Start", -font => 'code', -command =>
+ sub { start })
    ->place(-relx => 0.0, -rely => 0.9, -relwidth => 0.2, -relheight =
+> 0.1); 
$redbtt = $mw->Button(-background => "red", -activebackground => "toma
+to", -command =>[ \&colora  , "red" ])
    ->place(-relx => 0.0, -rely => 0.8, -relwidth => 0.1, -relheight =
+> 0.1);
$bluebtt = $mw->Button(-background => "blue", -activebackground => "st
+eelblue", -command => [ \&colora  , "blue" ])
    ->place(-relx => 0.0, -rely => 0.7, -relwidth => 0.1, -relheight =
+> 0.1);
$grennbtt = $mw->Button(-background => "green", -activebackground => "
+limegreen", -command => [ \&colora  , "green" ])
    ->place(-relx => 0.0, -rely => 0.6, -relwidth => 0.1, -relheight =
+> 0.1);
$yellowbtt = $mw->Button(-background => "yellow", -activebackground =>
+ "gold1", -command => [ \&colora  , "yellow" ])
    ->place(-relx => 0.0, -rely => 0.5, -relwidth => 0.1, -relheight =
+> 0.1);
$purplebtt = $mw->Button(-background => "purple", -activebackground =>
+ "purple3", -command => [ \&colora  , "purple" ])
    ->place(-relx => 0.0, -rely => 0.4, -relwidth => 0.1, -relheight =
+> 0.1);
$orangebtt = $mw->Button(-background => "orange", -activebackground =>
+ "coral", -command => [ \&colora  , "orange" ])
    ->place(-relx => 0.0, -rely => 0.3, -relwidth => 0.1, -relheight =
+> 0.1);
    
######################
# Definisco la label #    
$mialabel = $mw->Label(-text => "Press Start!", -font => 'code', -back
+ground => "black", -foreground => "white")
    ->place(-relx => 0.2, -rely => 0.9, -relwidth => 0.6, -relheight =
+> 0.1);
    
    

###############################################
# 4 x 10 spazi vuoti da riempire con i colori #
sub clean {
foreach $step (@steps){
$uno = $step->createOval(3,2, 16, 15, -fill=>       "grey");
$due = $step->createOval(23,2, 36, 15, -fill=>      "grey");
$tre = $step->createOval(43,2, 56, 15, -fill=>      "grey");
$quattro = $step->createOval(63,2, 76, 15, -fill=>  "grey"); 
    }
}


sub reclean {
    foreach $step (@steps){
    $step->itemconfigure    ("$uno", -fill=>     "grey");
    $step->itemconfigure    ("$due", -fill=>     "grey");
    $step->itemconfigure    ("$tre", -fill=>     "grey");
    $step->itemconfigure    ("$quattro", -fill=>     "grey");
    $step  ->itemconfigure ($ok[1], -fill=> "grey");
    $step  ->itemconfigure ($ok[2], -fill=> "grey");
    $step  ->itemconfigure ($ok[3], -fill=> "grey");
    $step  ->itemconfigure ($ok[4], -fill=> "grey");
        }
}

    
######################################
# Disegno i quadratini dei risultati #
foreach $step (@steps){
$ok[1] = $step  ->createRectangle(81, 5, 88, 12);
$ok[2] = $step  ->createRectangle(90, 5, 97, 12);
$ok[3] = $step  ->createRectangle(99, 5, 106, 12);
$ok[4] = $step  ->createRectangle(108, 5, 115, 12);
}


&clean;
    if ( $buone == 4 ) {
        $winlabel = $mw->Label(-text => "You Won!\n Press start to pla
+y again", -font => 'code', -background => "black", -foreground => "wh
+ite")
            ->place(-relx => 0.2, -rely => 0.5, -relwidth => 0.6, -rel
+height => 0.3);
            }    


MainLoop;
Replies are listed 'Best First'.
Re: Mastermind Game in Perl/Tk
by Tux (Abbot) on Jan 23, 2007 at 16:18 UTC
    Here's a simple, dynamic (change number of colors and -places) I wrote back in February 2004 for my kids:
    #!/pro/bin/perl use strict; use warnings; sub usage () { print STDERR "usage: mastermind.pl [ -p places ] [ -c colors ]\n"; exit 0; } # usage use Getopt::Long qw( :config nopermute bundling ); my $ncolor = 7; my $nplace = 5; my $nguess = 14; GetOptions ( "p|places=i" => \$nplace, "c|colors=i" => \$ncolor, "g|guess=i" => \$nguess, ) or usage (); my @color = qw( black red green blue yellow cyan magenta darkred orange darkgreen gray50 darkblue white wheat purple gold ); unless ($^O ne "win32") { my $pid = fork; $pid < 0 and die "Unable to run in the background, cannot fork: $! +\n"; $pid and exit 0; } use Tk; my $mw = MainWindow->new; $mw->configure ( -bg => "Gray85", -fg => "Black"); $mw->optionAdd ('*background' => "Gray85"); $mw->optionAdd ('*foreground' => "Black"); $mw->optionAdd ('*activeBackground' => "Gray85"); $mw->optionAdd ('*activeForeground' => "Black"); my $gw = $mw->Frame (-relief => "ridge")->pack (qw( -side top -fill bo +th -expand 1 -anchor w)); my $cw = $mw->Frame (-relief => "ridge")->pack (qw( -side top -fill bo +th -expand 1)); my $bw = $mw->Frame (-relief => "ridge")->pack (qw( -side top -fill bo +th -expand 1)); my $grid = $gw->Frame ()->grid (-sticky => "nesw"); $grid->gridRowconfigure (0, -weight => 1); # allow expansion in bot +h ... $grid->gridColumnconfigure (0, -weight => 1); # ... X and Y dimensions sub opnw () { exec $^X, "mastermind.pl", "-p$nplace", "-c$ncolor", "-g$nguess"; } # opnw my (@g, @c); # Grid of widgets and colors my $cc; # Current color my $row; # Rows guessed my @X; # The great unknown my @ok = ( $mw->Pixmap (-file => "ok.xpm"), $mw->Pixmap (-file => "nok.xpm"), ); sub solve ($$) { my ($f, $r, @y) = @_; my @x = @X; foreach my $x (0 .. ($nplace - 1)) { ($y[$x] = $c[$r][$x]) == $x[$x] or next; $y[$x] = $x[$x] = -2; $f->Button ( -height => 7, -width => 8, -borderwidth => 0, -highlightthickness => 0, -image => $ok[0], -background => "Gray85")->pack (-side => "left"); } foreach my $x (0 .. ($nplace - 1)) { $x[$x] >= 0 or next; foreach my $y (0 .. ($nplace - 1)) { $x == $y and next; $y[$y] >= 0 or next; $x[$x] == $y[$y] or next; $x[$x] = $y[$y] = -2; $f->Button ( -height => 7, -width => 8, -borderwidth => 0, -highlightthickness => 0, -image => $ok[1], -background => "Gray85")->pack (-side => "left +"); } } $row = $r; } # solve sub init () { ($cc, $row) = (0, 0); foreach my $c (0 .. ($nplace - 1)) { $X[$c] = int rand ($ncolor); } foreach my $r (0 .. ($nguess - 1)) { foreach my $c (0 .. ($nplace - 1)) { $g[$r][$c] = $grid->Button ( -relief => "ridge", -background => "gray85", -command => sub { $r < $row and return; $g[$r][$c]->configure (-background => $color[($c[$ +r][$c] = $cc)]); }, )->grid (-column => $c, -row => $r, -sticky => "news") +; } my $f = $g[$r][$nplace] = $grid->Frame ()->grid (-column => $n +place, -row => $r, -sticky => "ew"); my $b; $b = $f->Button ( -text => "!", -command => sub { foreach my $x (0 .. ($nplace - 1)) { defined $c[$r][$x] && $c[$r][$x] >= 0 or return; } solve ($f, $r); $b->packForget; }, )->pack (qw( -side left -expand 1 -fill both)); } $cw->Button ( -text => "<", -command => sub { $ncolor > 2 or return; $ncolor--; opnw (); })->pack (qw( -side left -expand 0 -fill y )); foreach my $c (0 .. ($ncolor - 1)) { $cw->Button ( -relief => "ridge", -background => $color[$c], -command => sub { $cc = $c }, )->pack (qw( -side left -expand 1 -fill both )); } $cw->Button ( -text => ">", -command => sub { $ncolor >= 16 and return; $ncolor++; opnw (); })->pack (qw( -side left -expand 0 -fill y )); $bw->Button ( -text => "[", -command => sub { $nplace > 2 or return; $nplace--; opnw (); })->pack (qw( -side left -expand 0 -fill y )); $bw->Button (-text => "Stop", -command => \&exit)->pack (qw( -s +ide left -expand 1 -fill both )); $bw->Button ( -text => "]", -command => sub { $nplace++; # No limit :) opnw (); })->pack (qw( -side right -expand 0 -fill y )); $bw->Button (-text => "Opnieuw", -command => \&opnw)->pack (qw( -s +ide right -expand 1 -fill both )); } # init init (); MainLoop;

    Enjoy, Have FUN! H.Merijn
      couldn't read file "ok.xpm": No such file or directory at G:/perl/site/lib/Tk/Image.pm line 22.
        ok.xpm
        nok.xpm
        But they are really, really simple (really):
        > cat ok.xpm /* XPM */ static char * ProLogo [] = { /* width height ncolors cpp [x_hot y_hot] */ "6 5 2 1 0 0", /* colors */ " c Gray85", "# c Black", /* pixels */ " ", " ## ", " #### ", " ## ", " "}; > cat nok.xpm /* XPM */ static char * ProLogo [] = { /* width height ncolors cpp [x_hot y_hot] */ "6 5 2 1 0 0", /* colors */ " c Gray85", "o c White", /* pixels */ " ", " oo ", " oooo ", " oo ", " "};

        Enjoy, Have FUN! H.Merijn
Re: Mastermind Game in Perl/Tk
by wazoox (Prior) on Jan 24, 2007 at 17:03 UTC
    Really nice, however it misses use strict; at the first line :)

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (6)
As of 2020-09-30 07:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If at first I donít succeed, I Ö










    Results (160 votes). Check out past polls.

    Notices?