Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Mastermind Game in Perl/Tk

by Anonymous Monk
on Jan 23, 2007 at 15:50 UTC ( [id://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 (Canon) 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;

    [download]

    Enjoy, Have FUN! H.Merijn
[reply]
[d/l]
      couldn't read file "ok.xpm": No such file or directory at G:/perl/site/lib/Tk/Image.pm line 22.
[reply]
        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  ",
"      "};

        [download]

        Enjoy, Have FUN! H.Merijn
[reply]
[d/l]
[select]
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 :)
[reply]
[d/l]

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: sourcecode [id://596111]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others chilling in the Monastery: (5)
As of 2024-04-16 12:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found