Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Tk - Discipulus 15 puzzle

by Discipulus (Monsignor)
on Jun 13, 2017 at 07:00 UTC ( #1192660=CUFP: print w/replies, xml ) Need Help??

NAME

Discipulus15puzzle.pl

SYNOPSIS

perl Discipulus15puzzle.pl [ --verbose --nocolor --charsize n --positions n n ..]

OPTIONS

     -v|verbose
                   print to the screen the appearence of the board
                   and the solvability/difficulty of the game based
                   on the calculated and shown parity of permutations
                   
     -n|nocolor
                  high contrast colors instead of default ones
                  default colors are imperial red and gold
                  
     -c|charsize  number
                  the size used for numbers on tiles
                  
     -tiles|positions  sequence of numbers from 1 to 16
                  providing a correct sequence of numbers from 1 (the tile with
                  the 1 on it) to 16 (the empty tile) you can force the game
                  to show a particular initial disposition
                  This is unavailable while --extreme is used
                  
     -x|extreme|perl
                  instead of numbers, perl statements are shown
                  the victory condition is shown briefly then the board is
                  shuffled: good luck monks

DESCRIPTION

This classic puzzle game is dedicated to my 15th anniversary of presence at the perlmonks community.

If run without arguments nor switches it displays a shuffled board with, in the above part, a description of the diffuculty and solvability of the current game.

Not every disposition can lead to a victorious game: this is due to permutations parity. Games with odd permutations are impossible.

You can shuffle the board using CTRL-S sequence.

To play just click on the tile you want to move.

Winners are rewarded with a surprise.

Have fun!

REFERENCES

See about 15 puzzle at OEIS https://oeis.org/A087725

mathworld http://mathworld.wolfram.com/15Puzzle.html

Info in italian http://utenti.quipo.it/base5/jsgioco15/g15did.htm

Reference and support site for this program, if needed, http://www.perlmonks.org

AUTHOR

Discipulus as found at www.perlmonks.org

CODE

use strict; use warnings; use Getopt::Long; use List::Util 1.29 qw(shuffle pairmap first all); use Tk; # 5 options 1 label text my ($verbose,@fixed,$nocolor,$charsize,$extreme,$solvability); unless (GetOptions ( 'verbose!' => \$verbose, 'tiles|positions=i{16}' => \@fixed, 'nocolor' => \$nocolor, 'charsize|size|c|s=i' => \$charsize, 'extreme|x|perl' => \$extreme, ) ) { die "invalid arguments!";} @fixed = &check_req_pos(@fixed) if @fixed; my $mw = Tk::MainWindow->new(-bg=>'black',-title=>'Giuoco del 15'); if ($nocolor){ $mw->optionAdd( '*Button.background', 'ivory' );} $mw->optionAdd('*Button.font', 'Courier '.($charsize or 16).' bold' ); $mw->bind('<Control-s>', sub{#&init_board; &shuffle_board}); my $top_frame = $mw->Frame( -borderwidth => 2, -relief => 'groove', )->pack(-expand => 1, -fill => 'both'); $top_frame->Label( -textvariable=>\$solvability, )->pack(-expand => 1, -fill => 'both'); my $game_frame = $mw->Frame( -background=>'saddlebrown', -borderwidth => 10, -relief => 'groove', )->pack(-expand => 1, -fill => 'both'); # set victory conditions in pairs of coordinates my @vic_cond = pairmap { [$a,$b] } qw(0 0 0 1 0 2 0 3 1 0 1 1 1 2 1 3 2 0 2 1 2 2 2 3 3 0 3 1 3 2 3 3); my $board = []; my $victorious = 0; &init_board; if ( $extreme ){ &extreme_perl} &shuffle_board; MainLoop; ###################################################################### +########## sub init_board{ # tiles from 1 to 15 for (0..14){ $$board[$_]={ btn=>$game_frame->Button( -text => $_+1, -relief => 'raised', -borderwidth => 3, -height => 2, -width => 4, -background=>$nocolor?'ivory':'gold1 +', -activebackground => $nocolor?'ivory +':'gold1', -foreground=> $nocolor?'black':'Dark +Red', -activeforeground=>$nocolor?'black': +'DarkRed' ), name => $_+1, # x and y set by shuffle_board }; if (($_+1) =~ /^(2|4|5|7|10|12|13|15)$/ and !$nocolor){ $$board[$_]{btn}->configure( -background=>'DarkRed', -activebackground => 'DarkRed', -foreground=> 'gold1', -activeforeground=>'gold1' ); } } # empty tile $$board[15]={ btn=>$game_frame->Button( -relief => 'sunken', -borderwidth => 3, -background => 'lavender', -height => 2, -width => 4, ), name => 16, # x and y set by shuffle_board }; } ###################################################################### +########## sub shuffle_board{ if ($victorious){ $victorious=0; &init_board; } if (@fixed){ my $index = 0; foreach my $tile(@$board[@fixed]){ my $xy = $vic_cond[$index]; ($$tile{x},$$tile{y}) = @$xy; $$tile{btn}->grid(-row=>$$xy[0], -column=> $$xy[1]); $$tile{btn}->configure(-command =>[\&move,$$xy[0],$$ +xy[1]]); $index++; } undef @fixed; } else{ my @valid = shuffle (0..15); foreach my $tile ( @$board ){ my $xy = $vic_cond[shift @valid]; ($$tile{x},$$tile{y}) = @$xy; $$tile{btn}->grid(-row=>$$xy[0], -column=> $$xy[1]); $$tile{btn}->configure(-command => [ \&move, $$xy[0], $$xy +[1] ]); } } my @appear = map {$_->{name}==16?'X':$_->{name}} sort{$$a{x}<=>$$b{x}||$$a{y}<=>$$b{y}}@$board; print "\n".('-' x 57)."\n". "Appearence of the board:\n[@appear]\n". ('-' x 57)."\n". "current\tfollowers\t less than current\n". ('-' x 57)."\n" if $verbose; # remove the, from now on inutile, 'X' for the empty space @appear = grep{$_ ne 'X'} @appear; my $permutation; foreach my $num (0..$#appear){ last if $num == $#appear; my $perm; $perm += grep {$_ < $appear[$num]} @appear[$num+1..$#appear] +; if ($verbose){ print "[$appear[$num]]\t@appear[$num+1..$#appear]". (" " x (37 - length "@appear[$num+1..$#appear]")). "\t $perm ".($num == $#appear - 1 ? '=' : '+')."\n"; } $permutation+=$perm; } print +(' ' x 50)."----\n" if $verbose; if ($permutation % 2){ print "Impossible game with odd permutations!".(' ' x 13). "$permutation\n"if $verbose; $solvability = "Impossible game with odd permutations [$permut +ation]\n". "(ctrl-s to shuffle)". (($verbose or $extreme) ? '' : " run with --verbose to see more info"); return; } # 105 is the max permutation my $diff = $permutation == 0 ? 'SOLVED' : $permutation < 35 ? 'EASY ' : $permutation < 70 ? 'MEDIUM' : 'HARD '; print "$diff game with even permutations".(' ' x 17). "$permutation\n" if $verbose; $solvability = "$diff game with permutation parity of [$permutatio +n]\n". "(ctrl-s to shuffle)"; } ###################################################################### +########## sub move{ # original x and y my ($ox, $oy) = @_; my $self = first{$_->{x} == $ox and $_->{y} == $oy} @$board; return if $$self{name}==16; # check if one in n,s,e,o is the empty one my $empty = first {$_->{name} == 16 and ( ($_->{x}==$ox-1 and $_->{y}==$oy) or ($_->{x}==$ox+1 and $_->{y}==$oy) or ($_->{x}==$ox and $_->{y}==$oy-1) or ($_->{x}==$ox and $_->{y}==$oy+1) ) } @$board; return unless $empty; # empty x and y my ($ex,$ey) = ($$empty{x},$$empty{y}); # reconfigure emtpy tile $$empty{btn}->grid(-row => $ox, -column => $oy); $$empty{x}=$ox; $$empty{y}=$oy; # reconfigure pressed tile $$self{btn}->grid(-row => $ex, -column => $ey); $$self{btn}->configure(-command => [ \&move, $ex, $ey ]); $$self{x}=$ex; $$self{y}=$ey; # check for victory if the empty one is at the bottom rigth tile ( +3,3) &check_win if $$empty{x} == 3 and $$empty{y} == 3; } ###################################################################### +########## sub check_win{ foreach my $pos (0..$#$board){ return unless ( $$board[$pos]->{'x'} == $vic_cond[$pos]->[0] a +nd $$board[$pos]->{'y'} == $vic_cond[$pos]->[1]); } # victory! $victorious = 1; my @text = ('Dis','ci','pu','lus','15th','','','at', 'P','e','r','l','M','o','n','ks*'); foreach my $tile(@$board){ $$tile{btn}->configure( -text=> shift @text, -command=>sub{return}); $mw->update; sleep 1; } } ###################################################################### +########## sub check_req_pos{ my @wanted = @_; # fix @wanted: seems GetOptions does not die if more elements are +passed @wanted = @wanted[0..15]; my @check = (1..16); unless ( all {$_ == shift @check} sort {$a<=>$b} @wanted ){ die "tiles must be from 1 to 16 (empty tile)\nyou passed [@wan +ted]\n"; } return map {$_-1} @wanted; } ###################################################################### +########## sub extreme_perl { $verbose = 0; $mw->optionAdd('*font', 'Courier 20 bold'); my @extreme = ( 'if $0', #1 "\$_=\n()=\n\"foo\"=~/o/g", #2 "use warnings;\n\$^W ?\nint((length\n'Discipulus')/3)\n:'15'", # +3 "length \$1\nif \$^X=~\n\/(?:\\W)(\\w*)\n(?:\\.exe)\$\/", #4 "use Config;\n\$Config{baserev}", #5. "(split '',\nvec('JAPH'\n,1,8))[0]", #6 "scalar map\n{ord(\$_)=~/1/g}\nqw(p e r l)", #7 "\$_ = () =\n'J A P H'\n=~\/\\b\/g", # 8 "eval join '+',\nsplit '',\n(substr\n'12345',3,2)", #9 'printf \'%b\',2', #10 "int(((1+sqrt(5))\n/ 2)** 7 /\nsqrt(5)+0.5)-2", #11 "split '',\nunpack('V',\n01234567))\n[6,4]", # 12 'J','A','P','H' # 13..16 ); foreach (0..15){ $$board[$_]{btn}->configure(-text=> $extreme[$_], -height => 8, -width => 16, ) if $extreme[$_]; } @fixed = qw(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15); $mw->after(5000,\&shuffle_board);# } __DATA__ =head1 NAME Discipulus15puzzle.pl =head1 SYNOPSIS perl Discipulus15puzzle.pl [ --verbose --nocolor --charsize n --positi +ons n n ..] =head1 OPTIONS -v|verbose print to the screen the appearence of the board and the solvability/difficulty of the game based on the calculated and shown parity of permutations -n|nocolor high contrast colors instead of default ones default colors are imperial red and gold -c|charsize number the size used for numbers on tiles -tiles|positions sequence of numbers from 1 to 16 providing a correct sequence of numbers from 1 (the +tile with the 1 on it) to 16 (the empty tile) you can force th +e game to show a particular initial disposition This is unavailable while --extreme is used -x|extreme|perl instead of numbers, perl statements are shown the victory condition is shown briefly then the boar +d is shuffled: good luck monks =head1 DESCRIPTION This classic puzzle game is dedidicated to my 15th anniversary of pres +ence at the perlmonks community. If run without arguments nor switches it display a shuffled board with +, in the above part, a description of the diffuculty and solvability of the cur +rent game. Not every disposition can lead to a victorious game: this is due to pe +rmutations parity. Games with odd permutations are impossible. You can shuffle the board using C<CTRL-S> sequence. To play just click on the tile you want to move. Winners are rewarded with a surprise. Have fun! =head1 REFERENCES See about 15 puzzle at OEIS L<https://oeis.org/A087725> mathworld L<http://mathworld.wolfram.com/15Puzzle.html> Info in italian L<http://utenti.quipo.it/base5/jsgioco15/g15did.htm> Reference and support site for this program, if needed, L<http://www.p +erlmonks.org> =head1 AUTHOR Discipulus as found at www.perlmonks.org

PS some typo fixed: thanks to hexcoder

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: Tk - Discipulus 15 puzzle
by tybalt89 (Deacon) on Jun 14, 2017 at 14:03 UTC

    A long time ago in a galaxy (oops, no, a city) far, far away, I wrote this as one of my first Tk programs.

    Initially it was slightly longer, but then I squeezed a little (hehehe) to see if I could get a

    "15 in 15(lines)" program.

    #!/usr/bin/perl use Tk; use strict; my @a = map $_->[0], sort {$a->[1] <=> $b->[1]} map [$_, rand], 0..15; my ($mw, $hole) = new MainWindow; sub xy { -row => $_[0] % 4, -column => int $_[0] / 4 } for my $ii (0..15) { my ($num, $i, $but) = ($a[$ii], $ii); $hole = $i, next unless $num; $but = $mw->Button(-text => $num, -width => 2, -height => 2, -comman +d => sub { $but->grid(xy(($i,$hole) = ($hole,$i))) if abs $i - $hole == 4 or abs $i - $hole == 1 and int $i/4 == int $hole/4 })->grid(xy $i); } MainLoop;
      Eh eh tybalt89 yes, you have a real talent and not only in Tk!

      But if I can accept the challenge I'd present a commandline version of the 15 puzzle that is a bit longer than your (25 vs 15 lines) but always poses resolvable games.. ;=)

      unless ($^W){use strict; use warnings;} use List::Util qw(shuffle first); my @tbl = ([1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,16]); my $e = [3,3]; for (1..$ARGV[0]||1000) { my $new = (shuffle &ad($e))[0]; $tbl[$e->[0]][$e->[1]] = $tbl[$new->[0]][$new->[1]]; $tbl[$new->[0]]->[$new->[1]] = 16; $e = [$new->[0],$new->[1]]; } while(1){ print +(join ' ',map{$_==16?' ':sprintf '%02s',$_}@{$tbl[$_]}),"\n" + for 0..3; my $m = <STDIN>; chomp $m; die "Enter a number to move!" unless $m; my $tile=first{$tbl[$$_[0]]->[$$_[1]]==$m}map{[$_,0],[$_,1],[$_,2],[ +$_,3]}0..3; my $new=first{$tbl[$$_[0]]->[$$_[1]]==16}&ad(grep{$tbl[$$_[0]]->[$$_ +[1]]==$m} map {[$_,0],[$_,1],[$_,2],[$_,3]}0..3); if ($new){$tbl[$$new[0]][$$new[1]]=$m;$tbl[$$tile[0]][$$tile[1]]=16; +} system ($^O eq 'MSWin32' ? 'cls' : 'clear'); } sub ad{ my $e = shift; grep {$_->[0]<4 && $_->[1]<4 && $_->[0]>-1 && $_- +>[1]>-1} [$$e[0]-1,$$e[1]],[$$e[0]+1,$$e[1]],[$$e[0],$$e[1]-1],[$$e[0],$$ +e[1]+1] }

      Never reached such square brackets density..

      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.

        But it only takes one additional line (with a tiny bit of reshuffling and a very small golf trick involving // ) to get it to pose only resolvable games :)

        #!/usr/bin/perl use Tk; use strict; my ($mw, $hole, @a) = new MainWindow; 1 while @a = (map($_->[0], sort {$a->[1] <=> $b->[1]} map [$_, rand], 1..15), 0), 1 & map { grep{ $a[$'] > $_ } @a[$_ + // .. 14] } 0..13; sub xy { -row => $_[0] % 4, -column => int $_[0] / 4 } for my $ii (0..15) { my ($num, $i, $but) = ($a[$ii], $ii); $hole = $i, next unless $num; $but = $mw->Button(-text => $num, -width => 2, -height => 2, -comman +d => sub { $but->grid(xy(($i,$hole) = ($hole,$i))) if abs $i - $hole == 4 or abs $i - $hole == 1 and int $i/4 == int $hole/4 })->grid(xy $i); } MainLoop;

        The extra line, however, spoils the whole "15 in 15" esthetic :(

Re: Tk - Discipulus 15 puzzle
by zentara (Archbishop) on Jun 13, 2017 at 12:57 UTC
    Great game. Man I wish we could get Perl Tk apps running on Android. :-) Now we need an AI program to solve it. :-)

    I'm not really a human, but I play one on earth. ..... an animated JAPH
Re: Tk - Discipulus 15 puzzle
by perldigious (Deacon) on Jun 13, 2017 at 15:16 UTC

    Very cool and fun little program. This brings back vague fond awful memories of having to do this game (a far less pretty/feature inclusive version of it anyway) for our final program of my assembly language class in college... on an x86 processor in a Windows environment (*shudders*), and it was the only program we did in a Windows environment instead of Linux because the professor wanted us to know, "exactly how good we had it up until then." I do remember being slightly disappointed that I no longer got my old friend "Segmentation Fault" as an error and instead Windows gave some "Out of Bounds" memory access message IIRC.

    Just another Perl hooker - Yep, I've definitely seen more than my share of d*cks in the world, that's for sure.
      So, you have familiarity on how to programatically solve the problem? I hope Perl6 is well-suited to writing AI software, we need something like that to solve this efficiently. There must be some clue as to the way the slides must be moved to efficiently move 1 number from here to there? I sometimes wish I was back in school, studying the matrix math needed to solve that problem

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

        Unsolved problem + boredom =

        #!/usr/bin/perl # 15 puzzle solver use strict; use warnings; my $start = <<END; # initial layout, 0 for empty cell 14 15 1 2 12 7 6 10 13 3 11 9 8 4 5 0 END my @squarestomove = solve( split ' ', $start ); while( @squarestomove > 10 ) { print "steps: @{[ splice @squarestomove, 0, 10 ]}\n"; } print "steps: @squarestomove\n"; exit; sub solve # internally runs in letters, not numbers, for regex purpose +s { my (%numbers2letters, %letters2numbers); @numbers2letters{ 0..15 } = (' ', 'a'..'o'); %letters2numbers = reverse %numbers2letters; my $board = join '', @numbers2letters{@_}; $board =~ s/....\K(?=.)/\n/g; my $win = "abcd\nefgh\nijkl\nmno "; my $moves = ''; for my $n (1..18) # place first, then first two, first three, etc. { (my $path, $board) = solvepart($board, substr $win, 0, $n ); print "path: $path\n\n$board\n\n"; $moves .= $path; } #print "\nmoves: $moves\n"; 1 while $moves =~ s/(.)\1//g; # remove dups print "\nmoves: $moves\n\n"; return @letters2numbers{ split //, $moves}; } sub solvepart { my ($have, $want) = @_; my @stack = $have; my %seen; my $delta = length $have =~ s/\n.*//sr; my $count = 0; while( $_ = shift @stack ) { $count++; if( $count > 1e7 ) # loop protection, may need to be larger { my $size = keys %seen; die "died with $size seen\n"; } my ($path, $board) = /(.*),(.*)/s ? ($1, $2 ) : ('', $_); #print "$board\n\n"; if( $want eq substr $board, 0, length $want) { return $path, $board; } elsif( $seen{$board}++ ) { } else { my $new = $board; if( $new =~ s/(\w) / $1/ ) # right { $seen{$new} or push @stack, "$path$1,$new"; } $new = $board; if( $new =~ s/ (\w)/$1 / ) # left { $seen{$new} or push @stack, "$path$1,$new"; } $new = $board; if( $new =~ s/(\w)(.{$delta}) / $2$1/s ) # down { $seen{$new} or push @stack, "$path$1,$new"; } $new = $board; if( $new =~ s/ (.{$delta})(\w)/$2$1 /s ) # up { $seen{$new} or push @stack, "$path$2,$new"; } } } die "no solution for $_"; }

        It's just a simple breadth first search looking to position the 1 first, then 1 & 2, then 1 & 2 & 3, etc. Trying to do the whole thing at once was too big for my machine (and maybe any machine :).

        There are still some debug prints left on, and some near infinite loop detection code.

        Internally I use letters to simplify (and speed up?) the regex for finding moves.

        So, you have familiarity on how to programmatically solve the problem?

        Ha, no, in fact the "feature inclusive" comment I made was based on my being impressed Discipulus' code actively can figure out things like the minimum number of moves remaining or even that a solution was impossible based on the random shuffle. My college course's 15 puzzle was, I believe, primarily selected by our professor because he wanted us to use a Windows environment and actually take input from mouse clicks and resolve screen position and current board state for what action to take for changing the appearance on the screen (we hadn't done any sort of GUI yet either). It didn't include any such features beyond those goals (and it was still really difficult for all of us in the class at the time).

        I sometimes wish I was back in school, studying the matrix math needed to solve that problem

        I often have the, "I wish I was back in school," thought too, and then I remember what school was like and being massively in debt, with no spending cash, living on ramen noodles, in a slum apartment I shared with 2-3 other people every semester, beating my brains out over my course load so I could actually finish an engineering degree in 4 years with a good GPA, and I compare that with my relatively awesome life now and I think twice. :-)

        Just a few weeks ago I was trying to use some simple matrix math for what's called Cramer's Rule to solve a linear system of equations for a circuit I was analyzing, only to quickly determine I can no longer correctly do the matrix math I was probably capable of early on in high school... so naturally I just used a computer.

        Most people get wiser as they age, or so I'm told, I swear I'm getting dumber every year I get further from school.

        Just another Perl hooker - Yep, I've definitely seen more than my share of d*cks in the world, that's for sure.
Re: Tk - Discipulus 15 puzzle
by RonW (Vicar) on Jun 13, 2017 at 20:35 UTC

    Very impressive.

    Congrats on 15 years of monk-dom.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1192660]
Front-paged by Athanasius
help
Chatterbox?
[ambrus]: erix: further, SQLite may be the second most installed piece of software on earth after zlib.
[erix]: heh, really? yeah, I suppose it may be so

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (10)
As of 2017-09-25 14:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    During the recent solar eclipse, I:









    Results (280 votes). Check out past polls.

    Notices?