Stone Jam -- 21 challenging puzzles with perl Tk

Hello nuns and monks!
April was the month dedicated to Perl/Tk here at the monastery (grin grin..) and during this time I developed another funny Tk puzzle. I have some unanswered question I put here even if the game is perfectly functioning.
I took the inspiration from a puzzle game of my daughter and suddenly I had the idea to translete in perl.
The program presents 21 different puzzles where you have to move a red stone up to border of the tablebaord, while other stones have to be shifted to make the path free.
The challenge, for me, was to reproduce some realistic moves for canvas: I was for some method to produce some brick-like piece unable to collide themselves. I had no chance till the moment I focused on free tiles, recalculating possible moves for all stones everytime one get moved. CPU cycles are so cheap nowadays..
there is some better way to achieve the above? For my own sanity I abstracted the board avoiding direct coordinates calculations.
About the graphic: I planned to use some advanced tecnique for this game like texture applied to stones or tile (graphic ones) applied to them but I had absolutely no luck in this and I ended with à la Mondrian color scheme (with, as always, the high contrast option: many many people has problems with colors..)
what happened to the -tile option for canvas? How can I fill canvas objects (rectangles, ovals..) with Photos or advanced grafic?
About the code: I realized about free space too late, also the moves caclulation was modified in fieri so the resulting code can be probably shortened a lot. Anyway the code is complete and runs fine and some of the puzzles is really challenging.
Have fun!
PS added to my github repos: Stone-Jam I'd like issues and eventual reports to be directed there.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::BrowseEntry;

my $mw  = Tk::MainWindow->new(-title=>'Stone jam');
$mw->optionAdd( '*font',   'Courier 8'  );
my $cont_frame = $mw->Frame(    
                                -borderwidth => 2, 
                                -relief => 'groove'
                            )->pack(    
                                        -side=>'top',
                                        -anchor=>'w',
                                        -pady=>5,
                                        -padx=>5,
                                        -expand=>1,
                                        -fill=>'both'
                            );

my $frame_1 = $cont_frame->Frame()->pack(
                                            -side=>'top',
                                            -anchor=>'w',
                                            -pady=>5
                                    );
$frame_1->Label(
                -text => "Drive the red stone to the upper border.\n".
                         "Click on stones to cycle their moves.",
                -justify=>'left'
                )->pack(
                        -side=>'top',
                        -anchor=>'w',
                        -pady=>2,
                        -expand=>1,
                        -fill=>'both'
                );                       
my $frame_2 = $cont_frame->Frame()->pack(
                                            -side=>'top',
                                            -anchor=>'w',
                                            -pady=>5,
                                            -expand=>1,
                                            -fill=>'both'
                                    );
my @games = (1..21);
my $game_num = 1;
my $be = $frame_2->BrowseEntry(
                                -label => 'play game level  ',
                                -variable => \$game_num,
                                -choices => \@games,
                                -width=>5,
                                -browsecmd=> \&draw_game,           
                )->pack(-side => 'left');
my $high_contrast = 0;
$frame_2->Checkbutton(-text => 'b/w', -variable => \$high_contrast)->p
+ack(-side => 'left',);
$frame_2->Button(    
                    -padx=> 5,
                    -text => "exit",
                    -borderwidth => 2, 
                    -command => sub{Tk::exit}
                )->pack(    
                        -side => 'right',
                        -expand => 1,
                        -padx=>5
                );
# main underlying canvas for the game
my $can = $mw->Canvas(
                -height => 300,
                -width  => 300,
                -bg => 'snow4',
                -highlightthickness => 0,                
            )->pack( );
# used to abstract and dump coordinates
my %board;
# used to store stones data
my %stones;
# free tiles
my %free;

# squares for tiles in %board starting at 0,0
my ($sq_x,$sq_y) = (0,0);

# fill the board hash from 1-1 to 6-6
# each tile with topX topY bottomX and bottomY
foreach my $row (1..6){
    foreach my $col (1..6){        
        $board{"$row-$col"} = {    
                                tx=>$sq_x,
                                ty=>$sq_y,
                                bx=>$sq_x+50,
                                by=>$sq_y+50
        };
        # add 50
        $sq_x += 50;          
    }
    # reset x to 0 for new row
    $sq_x = 0;
    # add 50 to y
    $sq_y += 50;
}
# bind to move items tagged as stone
$can->bind('stone', '<1>', sub {&move_stone();});

$mw->bind('<Control-Key-s>' => \&save_board);
# draw the first game level
draw_game(undef,1);
# go!
MainLoop;


######################################################################
+################
sub create_stone{
    my $tiles = shift;
    my $dir    = shift;
    my $color = shift;
    # top left and bottom right (extreme defaults)
    my (%tl,%br);
    $tl{x} = 300;    $tl{y} = 300;
    $br{x} = 0;        $br{y} = 0;
    foreach my $tile (@$tiles){
        $tl{x} = $board{$tile}{tx} if $board{$tile}{tx} < $tl{x};
        $tl{y} = $board{$tile}{ty} if $board{$tile}{ty} < $tl{y};
        $br{x} = $board{$tile}{bx} if $board{$tile}{bx} > $br{x};
        $br{y} = $board{$tile}{by} if $board{$tile}{by} > $br{y};
    }
    my $minus = 5;
    my $stone_id = $can->createRectangle (    
                            $tl{x}+$minus,
                            $tl{y}+$minus,
                            $br{x}-$minus,
                            $br{y}-$minus,
                            -fill =>$color,#'red',
                            -width => 4,
                            # mark the red stone to check victory
                            -tags=> $color eq 'red' ? ['stone', 'red']
+ : ['stone']    
     );
    $stones{$stone_id}={
        where => $tiles,
        dir    => $dir,
    }
}
######################################################################
+################
sub move_stone{
    my $ev = $can->XEvent;
    my ($dx, $dy) = ($ev->x, $ev->y);
    print "CLICKED  $dx  $dy\n";
    my $cur_id = ($can->find('withtag','current'))[0];
    print "current stone number: $cur_id\n";
    my @orig_pos = @{$stones{$cur_id}{where}};
    if (  $stones{$cur_id}{moves}  ){
        unshift @{$stones{$cur_id}{moves}},pop @{$stones{$cur_id}{move
+s}};
        print "was in @orig_pos and had ".
            ($stones{$cur_id}{dir} eq 'h' ? 'horizontal' : 'vertical')
+.
            " moves: ",(join ' ',map {$_ / 50} grep {defined $_ } @{$s
+tones{$cur_id}{moves}}),"\n";
        my $first_move = shift @{$stones{$cur_id}{moves}} ;
        # horizontal
        if ($stones{$cur_id}{dir} eq 'h'){
            $can->move($cur_id, $first_move, 0);
            my $howmuch = $first_move / 50;
            print "stone moved by $howmuch\n";
            foreach my $pos ( @{$stones{$cur_id}{where}} ){
                    my($row,$col)=split '-',$pos;
                    $col += $howmuch;
                    $pos = "$row-$col";            
            }
            print "after move is in @{$stones{$cur_id}{where}}\n";
            # remove occupied tiles from %free ones
            delete $free{$_} for @{$stones{$cur_id}{where}};
            # negative moves pops
            if ($first_move < 0){
                while ($howmuch != 0){
                    my $free = pop @orig_pos;
                    last unless $free;
                    print "freeing $free (",(join ' ', keys %free),")\
+n";
                    add_free($free, keys %free);
                    $howmuch++;
                }                
            }
            # positive moves shifts
            else {
                while ($howmuch != 0){
                    my $free = shift @orig_pos;
                    last unless $free;
                    print "freeing $free\n";
                    add_free($free, keys %free);
                    $howmuch--;
                }
            }
        }        
        # vertical
        else {
            $can->move($cur_id, 0, $first_move);
            my $howmuch = $first_move / 50;
            print "stone moved by $howmuch\n";
            foreach my $pos ( @{$stones{$cur_id}{where}} ){
                    my($row,$col)=split '-',$pos;
                    $row += $howmuch;
                    $pos = "$row-$col";            
            }
            print "after move is in @{$stones{$cur_id}{where}}\n";
            # VICTORY CHECK
            if ($cur_id == ($can->find('withtag','red'))[0] and grep {
+ /1\-/ } @{$stones{$cur_id}{where}} ){
                print "VICTORY!!\n";
                $mw->after(2000, \&show_victory);
                return;
            }
            # END VICTORY CHECK
            # remove occupied tiles from %free ones
            delete $free{$_} for @{$stones{$cur_id}{where}};
            # negative moves pops
            if ($first_move < 0){
                while ($howmuch != 0){
                    my $free = pop @orig_pos;
                    last unless $free;
                    print "freeing $free (",(join ' ', keys %free),")\
+n";
                    add_free($free, keys %free);
                    $howmuch++;
                }                
            }
            # positive moves shifts
            else {
                while ($howmuch != 0){
                    my $free = shift @orig_pos;
                    last unless $free;
                    print "freeing $free\n";
                    add_free($free, keys %free);
                    $howmuch--;
                }
            }
        }        
    }    
}
######################################################################
+################
sub add_free{
    # reset all moves for all stones
    map {$stones{$_}{moves} = () } keys %stones;
    print "#### recalculating moves for all stones\n";
    foreach my $tile (@_){
        next unless $tile;
        $free{$tile}++;
        my ($row,$col) = split '-',$tile;
        print "\ttile $row-$col is free\n";
        foreach my $stone (keys %stones){            
            # horizontal moving stones 
            if ($stones{$stone}{dir} eq 'h'){
                my $how_many = @{$stones{$stone}{where}} ;
                unless ( $how_many == grep {/$row\-\d/} @{$stones{$sto
+ne}{where}}  ){
                     #print "\tskipping stone $stone because horizonta
+l and not in row $row\n";
                     next;
                }
                my @pos = map{s/\d\-//r} @{$stones{$stone}{where}}; 
                print "\tstone $stone horizontal tiles: @pos\n";
                # negative moves
                my $minpos = ( sort{$a<=>$b} @pos )[0];
                if ($col < $minpos){
                    print "\tminimal pos $minpos\n";
                    # avoid moving of more than one tile..
                    # added later: make everything much simpler..
                    unless (int($minpos - $col) > 1){
                        push @{$stones{$stone}{moves}}, 50 * ($col - $
+minpos) ;
                        print "\tstone $stone can move horizontally by
+ ",$col - $minpos," tile\n";                    
                    }
                }
                # positive moves
                my $maxpos = ( sort{$b<=>$a} @pos )[0];
                if ($maxpos < $col){
                    print "\tmaximal pos $maxpos\n";
                    unless (int($col - $maxpos) > 1){
                        push @{$stones{$stone}{moves}}, 50 * ($col - $
+maxpos);
                        print "\tstone can move horizontally by ",$col
+ - $maxpos," tile\n";                                            
                    }                    
                }
            }            
            # vertical moving stones 
            else {
                my $how_many = @{$stones{$stone}{where}} ;
                unless ( $how_many == grep {/\d\-$col/} @{$stones{$sto
+ne}{where}}  ){
                     # print "\tskipping stone $stone because vertical
+ and not in column $col\n";
                     next;
                }
                my @pos = map{s/\-\d//r} @{$stones{$stone}{where}}; 
                print "\tstone $stone vertical tiles: @pos\n";
                # negative moves
                my $minpos = ( sort{$a<=>$b} @pos )[0];
                if ($row < $minpos){
                    print "\tminimal pos $minpos\n";
                    # avoid moving of more than one tile..
                    unless (int($minpos - $row) > 1){
                        push @{$stones{$stone}{moves}}, 50 * ($row - $
+minpos) ;
                        print "\tstone $stone can move vertically by "
+,$row - $minpos," tile\n";                    
                    }
                }
                # positive moves
                my $maxpos = ( sort{$b<=>$a} @pos )[0];
                if ($maxpos < $row){
                    print "\tmaximal pos $maxpos\n";
                    # avoid moving of more than one tile..
                    unless (int($row - $maxpos) > 1){
                        push @{$stones{$stone}{moves}}, 50 * ($row - $
+maxpos);
                        print "\tstone can move vertically by ",$row -
+ $maxpos," tile\n";                    
                    }
                }
            }        
        }
        print "\n";    
    }
}
######################################################################
+################
sub show_victory{    
    $can->delete('stone');
    $can->createText(150,150, 
                    -text => "VICTORY!", 
                    -fill => 'red',
                    -font => 'Arial 20 bold',
                    # tagged as stone to be removed
                    # as a new game level is drawn
                    -tags => ['stone']);    
}
######################################################################
+################
sub draw_game{
    my $widget = shift; # automatically passed by the BrowserEntry wid
+get
    my $game= shift;
    # deleting all items tagged as 'stone' in the canvas
    $can->delete('stone');
    # freeing containers
    undef %stones;
    undef %free;
    print "\nStarting game number $game\n";
    # select color scheme
    my @colors = $high_contrast ?
                ( ('white') x 13) :
                qw( SlateBlue1 DodgerBlue2 aquamarine2 PaleTurquoise3
                SpringGreen1 DeepSkyBlue3 cyan2 CornflowerBlue MediumO
+rchid3 
                LightSkyBlue MediumTurquoise
                SlateBlue1 DodgerBlue2);
    # configure bg for color scheme
    if ($high_contrast){
        $can->configure(-background=>'black');
    }
    else{$can->configure(-background=>'snow4');}
    # GAMES POSITIONING
    # fake game to trig victory:
    # create_stone( [qw(2-3 3-3)],'v', shift @colors ); # red (winning
+ one) always first
    # add_free(qw( 1-3) );
    # create_stone needs arrayref of tiles, direction and color
    
    if ($game == 1){
        create_stone( [qw( 5-3 6-3 )],'v', 'red' ); # red (winning one
+) always first
        create_stone( [qw(1-1 1-2 1-3 )],'h', shift @colors );
        create_stone( [qw( 1-4 2-4)],'v', shift @colors );
        create_stone( [qw( 2-5 2-6)],'h', shift @colors );
        create_stone( [qw(4-1 5-1 6-1 )],'v', shift @colors );
        create_stone( [qw(4-2 4-3 4-4 )],'h', shift @colors );
        create_stone( [qw(6-4 6-5 )],'h', shift @colors );
        create_stone( [qw( 4-6 5-6 6-6)],'v', shift @colors );
        
        add_free (qw(1-5 1-6 2-1 2-2 2-3 3-1 3-2 3-3 3-4 3-5 3-6 4-5 5
+-2 5-4 5-5 6-2 ));
        
    }
    elsif ($game == 2){
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(1-1 2-1)],'v', shift @colors  );
        create_stone( [qw(1-2 1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(2-4 3-4 4-4)],'v', shift @colors  );
        create_stone( [qw(2-5 2-6)],'h', shift @colors  );
        create_stone( [qw(3-5 4-5)],'v', shift @colors  );
        create_stone( [qw(5-4 5-5)],'h', shift @colors  );
        create_stone( [qw(4-1 4-2 4-3)],'h', shift @colors  );

        add_free(qw( 1-5 1-6 2-2 2-3 3-1 3-2 3-3 3-6 4-6 5-1 5-2 5-6 6
+-1 6-2 6-4 6-5 6-6 ));
    }
    elsif ($game == 3){
        create_stone( [qw(3-3 4-3)],'v', 'red' ); 
        create_stone( [qw(2-2 2-3 2-4)],'h', shift @colors  );
        create_stone( [qw(1-5 2-5)],'v', shift @colors  );
        create_stone( [qw(3-1 4-1 5-1)],'v', shift @colors  );
        create_stone( [qw(3-2 4-2 5-2)],'v', shift @colors  );
        create_stone( [qw(3-4 4-4)],'v', shift @colors  );
        create_stone( [qw(3-5 3-6)],'h', shift @colors  );
        create_stone( [qw(5-3 5-4 5-5)],'h', shift @colors  );
        create_stone( [qw(6-1 6-2)],'h', shift @colors  );
        create_stone( [qw(4-6 5-6 6-6)],'v', shift @colors  );
        
        add_free(qw( 1-1 1-2 1-3 1-4 1-6 2-1 2-6 4-5 6-3 6-4 6-5  ));
    }
    elsif ($game == 4){
        create_stone( [qw(4-3 5-3)],'v', 'red' ); 
        create_stone( [qw(1-1 1-2)],'h', shift @colors  );
        create_stone( [qw(1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(2-2 3-2)],'v', shift @colors  );
        create_stone( [qw(2-3 2-4)],'h', shift @colors  );
        create_stone( [qw(2-5 2-6)],'h', shift @colors  );
        create_stone( [qw(3-3 3-4)],'h', shift @colors  );
        create_stone( [qw(3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(4-1 4-2)],'h', shift @colors  );
        create_stone( [qw(5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(6-2 6-3)],'h', shift @colors  );
        create_stone( [qw(5-4 6-4)],'v', shift @colors  );
        create_stone( [qw(5-5 6-5)],'v', shift @colors  );
        create_stone( [qw(5-6 6-6)],'v', shift @colors  );
        
        add_free(qw(1-5 1-6 2-1 3-1 3-5 4-4 4-5 5-2));
    }
    elsif ($game == 5){
        create_stone( [qw(2-3 3-3)],'v', 'red' ); 
        create_stone( [qw(1-1 2-1)],'v', shift @colors  );
        create_stone( [qw(1-2 2-2 3-2)],'v', shift @colors  );
        create_stone( [qw(1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(1-5 1-6)],'h', shift @colors  );
        create_stone( [qw(2-4 2-5)],'h', shift @colors  );
        create_stone( [qw(3-5 4-5)],'v', shift @colors  );
        create_stone( [qw(2-6 3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(4-1 5-1)],'v', shift @colors  );
        create_stone( [qw(4-2 4-3 4-4)],'h', shift @colors  );
        create_stone( [qw(6-1 6-2)],'h', shift @colors  );
        create_stone( [qw(5-4 6-4)],'v', shift @colors  );
        create_stone( [qw(5-5 5-6)],'h', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        
        add_free(qw(3-1 3-4 5-2 5-3 6-3));
    }
    elsif ($game == 6){
        create_stone( [qw(4-3 5-3)],'v', 'red' ); 
        create_stone( [qw(1-4 2-4)],'v', shift @colors  );
        create_stone( [qw(2-1 2-2 2-3)],'h', shift @colors  );
        create_stone( [qw(3-1 3-2)],'h', shift @colors  );
        create_stone( [qw(3-3 3-4)],'h', shift @colors  );
        create_stone( [qw(3-5 4-5)],'v', shift @colors  );
        create_stone( [qw(2-6 3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(5-5 5-6)],'h', shift @colors  );
        create_stone( [qw(6-3 6-4)],'h', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        
        add_free(qw(1-1 1-2 1-3 1-5 1-6 2-5 4-1 4-2 4-4 5-2 5-4 6-2));
    }
    elsif ($game == 7){
        create_stone( [qw(5-3 6-3)],'v','red' ); 
        create_stone( [qw(1-1 2-1)],'v', shift @colors  );
        create_stone( [qw(1-2 1-3)],'h', shift @colors  );
        create_stone( [qw(1-4 1-5)],'h', shift @colors  );
        create_stone( [qw(2-4 2-5)],'h', shift @colors  );
        create_stone( [qw(4-1 4-2)],'h', shift @colors  );
        create_stone( [qw(4-3 4-4)],'h', shift @colors  );
        create_stone( [qw(4-5 5-5 6-5)],'v', shift @colors  );
        create_stone( [qw(4-6 5-6 6-6)],'v', shift @colors  );
        
        add_free(qw(1-6 2-2 2-3 2-6 3-1 3-2 3-3 3-4 3-5 3-6 5-1 5-2 5-
+4 6-1 6-2 6-4));
    }
    elsif ($game == 8){
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(1-1 2-1)],'v', shift @colors  );
        create_stone( [qw(1-2 2-2)],'v', shift @colors  );
        create_stone( [qw(1-4 1-5 1-6)],'h', shift @colors  );
        create_stone( [qw(3-1 3-2)],'h', shift @colors  );
        create_stone( [qw(4-1 4-2 4-3)],'h', shift @colors  );
        create_stone( [qw(3-4 4-4 5-4)],'v', shift @colors  );
        create_stone( [qw(3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(5-1 5-2)],'h', shift @colors  );
        create_stone( [qw(6-4 6-5)],'h', shift @colors  );
        create_stone( [qw(5-6 6-6)],'v', shift @colors  );
        add_free(qw(1-3 2-3 2-4 2-5 2-6 3-3 3-5 4-5 5-5 6-1 6-2));
    }
    elsif ($game == 9){
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(1-1 1-2)],'h', shift @colors  );
        create_stone( [qw(1-4 2-4)],'v', shift @colors  );
        create_stone( [qw(1-6 2-6)],'v', shift @colors  );
        create_stone( [qw(2-1 2-2 2-3)],'h', shift @colors  );
        create_stone( [qw(3-2 4-2)],'v', shift @colors  );
        create_stone( [qw(3-3 3-4)],'h', shift @colors  );
        create_stone( [qw(4-3 4-4)],'h', shift @colors  );
        create_stone( [qw(3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(5-2 6-2)],'v', shift @colors  );
        create_stone( [qw(5-4 5-5 5-6)],'h', shift @colors  );
        create_stone( [qw(6-4 6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-3 1-5 2-5 3-1 3-5 4-1 4-5));
    }
    elsif ($game == 10){
        create_stone( [qw(4-3 5-3)],'v', 'red' ); 
        create_stone( [qw(1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(1-5 1-6)],'h', shift @colors  );
        create_stone( [qw(2-1 2-2 2-3)],'h', shift @colors  );
        create_stone( [qw(2-4 3-4)],'v', shift @colors  );
        create_stone( [qw(2-5 3-5)],'v', shift @colors  );
        create_stone( [qw(3-6 4-6 5-6)],'v', shift @colors  );
        create_stone( [qw(5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(4-2 5-2 6-2)],'v', shift @colors  );
        create_stone( [qw(4-4 4-5)],'h', shift @colors  );
        create_stone( [qw(6-3 6-4)],'h', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-1 1-2 2-6 3-1 3-2 3-3 4-1 5-4 5-5));
    }
    elsif ($game == 11){
        create_stone( [qw(2-3 3-3)],'v', 'red' ); 
        create_stone( [qw(1-1 1-2 1-3)],'h', shift @colors  );
        create_stone( [qw(1-5 2-5)],'v', shift @colors  );
        create_stone( [qw(1-6 2-6 3-6)],'v', shift @colors  );
        create_stone( [qw(3-1 4-1 5-1)],'v', shift @colors  );
        create_stone( [qw(3-4 3-5)],'h', shift @colors  );
        create_stone( [qw(4-2 4-3)],'h', shift @colors  );
        create_stone( [qw(4-4 5-4 6-4)],'v', shift @colors  );
        create_stone( [qw(6-1 6-2 6-3)],'h', shift @colors  );
        create_stone( [qw(5-5 5-6)],'h', shift @colors  );
        add_free(qw(1-4 2-1 2-2 2-4 3-2 4-5 4-6 5-2 5-3 6-5 6-6));
    }
    elsif ($game == 12){
        create_stone( [qw(4-3 5-3)],'v', 'red' ); 
        create_stone( [qw(1-2 1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(2-1 3-1)],'v', shift @colors  );
        create_stone( [qw(2-2 2-3 2-4)],'h', shift @colors  );
        create_stone( [qw(4-1 4-2)],'h', shift @colors  );
        create_stone( [qw(3-4 4-4)],'v', shift @colors  );
        create_stone( [qw(3-5 4-5)],'v', shift @colors  );
        create_stone( [qw(2-6 3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(6-2 6-3)],'h', shift @colors  );
        create_stone( [qw(5-4 6-4)],'v', shift @colors  );
        create_stone( [qw(5-5 5-6)],'h', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-1 1-5 1-6 2-5 3-2 3-3 5-1 5-2 6-1));
    }
    elsif ($game == 13){
        create_stone( [qw(4-3 5-3)],'v', 'red' ); 
        create_stone( [qw(1-1 2-1)],'v', shift @colors  );
        create_stone( [qw(1-2 2-2)],'v', shift @colors  );
        create_stone( [qw(1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(2-3 2-4)],'h', shift @colors  );
        create_stone( [qw(2-6 3-6)],'v', shift @colors  );
        create_stone( [qw(3-1 3-2 3-3)],'h', shift @colors  );
        create_stone( [qw(3-4 4-4)],'v', shift @colors  );
        create_stone( [qw(4-1 4-2)],'h', shift @colors  );
        create_stone( [qw(5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(5-4 5-5 5-6)],'h', shift @colors  );
        add_free(qw(1-5 1-6 2-5 3-5 4-5 4-6 5-2 6-2 6-3 6-4 6-5 6-6));
    }
    elsif ($game == 14){
        create_stone( [qw(3-3 4-3)],'v', 'red' ); 
        create_stone( [qw(1-1 1-2)],'h', shift @colors  );
        create_stone( [qw(2-1 2-2 2-3)],'h', shift @colors  );
        create_stone( [qw(2-5 3-5)],'v', shift @colors  );
        create_stone( [qw(2-6 3-6)],'v', shift @colors  );
        create_stone( [qw(4-1 5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(5-2 6-2)],'v', shift @colors  );
        create_stone( [qw(4-4 4-5)],'h', shift @colors  );
        create_stone( [qw(4-6 5-6)],'v', shift @colors  );
        create_stone( [qw(5-3 5-4 5-5)],'h', shift @colors  );
        create_stone( [qw(6-3 6-4)],'h', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-3 1-4 1-5 1-6 2-4 3-1 3-2 3-4 4-2));
    }
    elsif ($game == 15){
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(1-1 2-1)],'v', shift @colors  );
        create_stone( [qw(1-4 1-5 1-6)],'h', shift @colors  );
        create_stone( [qw(3-1 3-2)],'h', shift @colors  );
        create_stone( [qw(3-3 3-4)],'h', shift @colors  );
        create_stone( [qw(2-6 3-6)],'v', shift @colors  );
        create_stone( [qw(4-1 4-2 4-3)],'h', shift @colors  );
        create_stone( [qw(5-2 6-2)],'v', shift @colors  );
        create_stone( [qw(4-4 5-4 6-4)],'v', shift @colors  );
        create_stone( [qw(4-6 5-6)],'v', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-2 1-3 2-2 2-3 2-4 2-5 3-5 4-5 5-1 5-5 6-1));
    }
    elsif ($game == 16){
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(2-1 2-2)],'h', shift @colors  );
        create_stone( [qw(1-5 2-5)],'v', shift @colors  );
        create_stone( [qw(1-6 2-6 3-6)],'v', shift @colors  );
        create_stone( [qw(3-1 4-1)],'v', shift @colors  );
        create_stone( [qw(3-2 4-2)],'v', shift @colors  );
        create_stone( [qw(3-3 3-4 3-5)],'h', shift @colors  );
        create_stone( [qw(4-3 4-4)],'h', shift @colors  );
        create_stone( [qw(4-5 4-6)],'h', shift @colors  );
        create_stone( [qw(5-1 5-2)],'h', shift @colors  );
        create_stone( [qw(6-4 6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-1 1-2 1-3 1-4 2-3 2-4 5-4 5-5 5-6 6-1 6-2));
    }
    elsif ($game == 17){
        create_stone( [qw(3-3 4-3)],'v', 'red' ); 
        create_stone( [qw(1-1 1-2)],'h', shift @colors  );
        create_stone( [qw(2-1 3-1 4-1)],'v', shift @colors  );
        create_stone( [qw(2-2 2-3 2-4)],'h', shift @colors  );
        create_stone( [qw(1-5 2-5 3-5)],'v', shift @colors  );
        create_stone( [qw(2-6 3-6)],'v', shift @colors  );
        create_stone( [qw(4-4 4-5)],'h', shift @colors  );
        create_stone( [qw(4-6 5-6)],'v', shift @colors  );
        create_stone( [qw(5-1 5-2 5-3)],'h', shift @colors  );
        create_stone( [qw(6-1 6-2 6-3)],'h', shift @colors  );
        create_stone( [qw(5-4 6-4)],'v', shift @colors  );
        add_free(qw(1-3 1-4 1-6 3-2 3-4 4-2 5-5 6-5 6-6));
    }
    elsif ($game == 18){ # non vinto..
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(1-2 1-3)],'h', shift @colors  );
        create_stone( [qw(1-4 2-4)],'v', shift @colors  );
        create_stone( [qw(1-5 1-6)],'h', shift @colors  );
        create_stone( [qw(2-1 2-2 2-3)],'h', shift @colors  );
        create_stone( [qw(3-2 4-2)],'v', shift @colors  );
        create_stone( [qw(3-3 3-4)],'h', shift @colors  );
        create_stone( [qw(3-5 4-5)],'v', shift @colors  );
        create_stone( [qw(4-3 4-4)],'h', shift @colors  );
        create_stone( [qw(4-1 5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(5-4 5-5)],'h', shift @colors  );
        add_free(qw(1-1 2-5 2-6 3-1 3-6 4-6 5-2 5-6 6-2 6-4 6-5 6-6));
    }
    elsif ($game == 19){ 
        create_stone( [qw(5-3 6-3)],'v', 'red' ); 
        create_stone( [qw(1-1 1-2 1-3)],'h', shift @colors  );
        create_stone( [qw(1-4 2-4)],'v', shift @colors  );
        create_stone( [qw(3-1 4-1)],'v', shift @colors  );
        create_stone( [qw(3-2 3-3)],'h', shift @colors  );
        create_stone( [qw(3-4 3-5)],'h', shift @colors  );
        create_stone( [qw(3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(4-2 4-3 4-4)],'h', shift @colors  );
        create_stone( [qw(4-5 5-5)],'v', shift @colors  );
        create_stone( [qw(5-1 6-1)],'v', shift @colors  );
        create_stone( [qw(6-5 6-6)],'h', shift @colors  );
        add_free(qw(1-5 1-6 2-1 2-2 2-3 2-5 2-6 5-2 5-4 5-6 6-2 6-4));
    }
    elsif ($game == 20){ 
        create_stone( [qw(2-3 3-3)],'v', 'red' ); 
        create_stone( [qw(1-2 2-2)],'v', shift @colors  );
        create_stone( [qw(1-3 1-4)],'h', shift @colors  );
        create_stone( [qw(1-5 1-6)],'h', shift @colors  );
        create_stone( [qw(3-1 3-2)],'h', shift @colors  );
        create_stone( [qw(4-1 5-1)],'v', shift @colors  );
        create_stone( [qw(4-2 4-3)],'h', shift @colors  );
        create_stone( [qw(4-4 4-5)],'h', shift @colors  );
        create_stone( [qw(3-6 4-6)],'v', shift @colors  );
        create_stone( [qw(5-2 5-3)],'h', shift @colors  );
        create_stone( [qw(5-4 6-4)],'v', shift @colors  );
        create_stone( [qw(5-6 6-6)],'v', shift @colors  );
        create_stone( [qw(6-1 6-2 6-3)],'h', shift @colors  );
        add_free(qw(1-1 2-1 2-4 2-5 2-6 3-4 3-5 5-5 6-5));
    }
    # GAME 21 GENERATED BY CTRL-S 
    elsif ($game == 21){ 
        create_stone( [qw( 4-3 5-3 )],  'v',  'red' );
        create_stone( [qw( 1-2 1-3 )],  'h',  shift @colors );
        create_stone( [qw( 3-4 4-4 )],  'v',  shift @colors );
        create_stone( [qw( 1-4 1-5 )],  'h',  shift @colors );
        create_stone( [qw( 2-2 2-3 2-4 )],  'h',  shift @colors );
        create_stone( [qw( 4-2 5-2 )],  'v',  shift @colors );
        create_stone( [qw( 3-2 3-3 )],  'h',  shift @colors );
        create_stone( [qw( 2-5 3-5 )],  'v',  shift @colors );
        create_stone( [qw( 4-5 4-6 )],  'h',  shift @colors );
        create_stone( [qw( 1-1 2-1 3-1 )],  'v',  shift @colors );
        create_stone( [qw( 5-4 5-5 )],  'h',  shift @colors );

        add_free (qw(1-6 2-6 3-6 4-1 5-1 5-6 6-1 6-2 6-3 6-4 6-5 6-6))
+;
    }
    else{1}
}
######################################################################
+################
sub save_board{ 
    my $widget = shift;
    my $red = ($can->find('withtag','red') )[0];
    my @stones = $can->find('withtag','stone^red');
    
    my $red_switch = 1;
    print "\n\nstone positions:\n\n";
    foreach my $stone ($red,@stones){
        print     "\t",'[qw( ',
                join ' ',@{$stones{$stone}{where}},
                ')], ',
                "'$stones{$stone}{dir}', ",
                ($red_switch ? "'red'" : 'shift @colors'),
                "\n";
        $red_switch = 0;
    }
    print "\nfree tiles:\n\n\tqw(",
            (join ' ', sort keys %free),
            ")\n";    
}
[download]
There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Back to Cool Uses for Perl