Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Stone Jam -- 21 challenging puzzles with perl Tk

by Discipulus (Monsignor)
on May 03, 2018 at 08:00 UTC ( #1213986=CUFP: print w/replies, xml ) Need Help??

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"; }

L*

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.

Replies are listed 'Best First'.
Re: Stone Jam -- 21 challenging puzzles with perl Tk
by Tux (Abbot) on May 03, 2018 at 11:51 UTC

    Nice!

    Some comments ...

    • I get errors like
      Tk::Error: bad screen distance "" at /pro/lib/perl5/site_perl/5.24.1/x +86_64-linux-thread-multi-ld/Tk.pm line 251. Tk callback for .canvas <Button-1> (command bound to event)
    • Clicking on one end of a block should move it in that direction
    • There should be a button Next game after "Victory"

    You might enjoy Nintendo DS Braintrainer and Mastermind I once wrote

    update:I notice that mastermind is currently broken. Need to check why
    update2:
     
    Found fixed and uploaded again
    < is less colors, > is more colors, [ is less squares, ] is more squares

    Enjoy, Have FUN! H.Merijn
Re: Stone Jam -- 21 challenging puzzles with perl Tk
by tybalt89 (Vicar) on May 03, 2018 at 15:39 UTC

    Fun little thing to write a solver for :)

    #!/usr/bin/perl # http://perlmonks.org/?node_id=1213986 use strict; # solver use warnings; $_ = <<END; # game 21 abbcc addde affge hRgii hRjj END my %seen; my @queue = [$_]; while( @queue ) { my @prev = shift(@queue)->@*; local $_ = $prev[-1]; $seen{$_}++ and next; if( /^.*R/ ) { my $moves = @prev - 1; my $count = 0; print "WINNER in $moves moves\n\n", map "\n " . $count++ . "\n$_", @prev; exit; } while( / ((\w)\2+)/g ) { push @queue, [ @prev, "$`$1 $'" ]; } while( /((\w)\2+) /g ) { push @queue, [ @prev, "$` $1$'" ]; } $_ = transpose($_); while( / ((\w)\2+)/g ) { push @queue, [ @prev, transpose("$`$1 $'") +]; } while( /((\w)\2+) /g ) { push @queue, [ @prev, transpose("$` $1$'") +]; } } print "Unsolvable\n"; sub transpose { local $_ = shift; my $answer = ''; $answer .= "\n" while s/^./ $answer .= $&; ''/gem; return $answer; }
Re: Stone Jam -- 21 challenging puzzles with perl Tk
by zentara (Archbishop) on May 03, 2018 at 12:40 UTC
    Hi Discipulus, no matter what I do I can't get the red block to move.

    I wI was for some method to produce some brick-like piece unable to collide themselves.as for some method to produce some brick-like piece unable to collide themselves.

    Try this tag method.

    #!/usr/bin/perl use warnings; use strict; use Tk; my $dx; my $dy; my $mw = MainWindow->new; $mw->geometry("700x600"); my $canvas = $mw->Canvas(-width => 700, -height => 565, -bg => 'black', -borderwidth => 3, -relief => 'sunken', )->pack; my $closebutton = $mw->Button(-text => 'Exit', -command => sub{Tk::exi +t(0)}) ->pack; my $dr = $canvas->createPolygon(0, 20, 50, 20, 50, 75, 0,75, -fill => 'red', -tags => ['move','red','paver'], ); my $db = $canvas->createPolygon(70, 20, 150,20, 150, 75, 70 , 75, -fill => 'blue', -tags => ['move','blue','paver'], ); my $dg = $canvas->createPolygon(200, 20, 250,20, 250, 75, -fill => 'green', -tags => ['move','green','paver'], ); my $dp = $canvas->createPolygon(300, 20, 350,20, 350, 75, -fill => 'purple', -tags => ['move','purple','paver'], ); $canvas->bind('move', '<1>', sub {&mobileStart();}); $canvas->bind('move', '<B1-Motion>', sub {&mobileMove();}); $canvas->bind('move', '<ButtonRelease-1>', sub {&mobileStop();}); MainLoop; sub mobileStart { my $ev = $canvas->XEvent; ($dx, $dy) = (0 - $ev->x, 0 - $ev->y); $canvas->raise('current'); # print "START MOVE-> $dx $dy\n"; } sub mobileMove { my $ev = $canvas->XEvent; # $canvas->bind('current', '<Leave>', sub {&mobileStop();}); + my @coords_in = $canvas->coords('current'); # print "@coords_in\n"; $canvas->move('current', $ev->x + $dx, $ev->y +$dy); ($dx, $dy) = (0 - $ev->x, 0 - $ev->y); # print "MOVING-> $dx $dy\n"; my @coords = $canvas->coords('current'); #print "@coords\n"; my (@olaps) = $canvas->find('overlapping', $coords[0],$coords[1] +,$coords[4],$coords[5], ); foreach my $id(@olaps){ print $canvas->gettags($id),"\t"; } print "@olaps\n"; print "\n"; if(scalar @olaps > 1){ # Redraw the rect $canvas->coords('current', @coords_in); } } sub mobileStop{ &mobileMove; }

    what happened to the -tile option for canvas? How can I fill canvas objects (rectangles, ovals..) with Photos or advanced grafic?

    I don't think there is a canvas -tile option for it's objects. What you would need to do is create canvas image objects of the appropriate size and manipulate them. See Tk ImageMap-color-zones for an example.


    I'm not really a human, but I play one on earth. ..... an animated JAPH
      Weird - you can move anything towards the hypotenuse of a triangle, but you can't move a triangle close to anything with its hypotenuse.

      ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
        Hi, yeah, thanks for pointing that out. It must have something to do with the overlap tag and the way polygon items are drawn. The polygon overlap must be detected by a hidden square made from it's most extreme vertices. More experiments with different types of polygons would be in order. Like what happens with a 5 or 10 sided polygon, or what happens with a circle? It still is a useful collision detection method. It favors "keeping away". :-)

        I'm not really a human, but I play one on earth. ..... an animated JAPH

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1213986]
Front-paged by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (5)
As of 2018-12-10 10:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    How many stories does it take before you've heard them all?







    Results (48 votes). Check out past polls.

    Notices?
    • (Sep 10, 2018 at 22:53 UTC) Welcome new users!