 We don't bite newbies here... much PerlMonks

### Tk - Discipulus 15 puzzle

by Discipulus (Abbot)
 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

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');

-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={
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, -column=> \$\$xy);
\$\$tile{btn}->configure(-command =>[\&move,\$\$xy,\$\$
+xy]);
\$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, -column=> \$\$xy);
\$\$tile{btn}->configure(-command => [ \&move, \$\$xy, \$\$xy
+ ]);
}
}
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) ? '' :
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]-> a
+nd
\$\$board[\$pos]->{'y'} == \$vic_cond[\$pos]->);
}
# 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;
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))",       #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__

Discipulus15puzzle.pl

perl Discipulus15puzzle.pl [ --verbose --nocolor --charsize n --positi
+ons n n ..]

-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

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!

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>

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 (Prior) 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 \$_->, sort {\$a-> <=> \$b->} map [\$_, rand], 0..15;
my (\$mw, \$hole) = new MainWindow;
sub xy { -row => \$_ % 4, -column => int \$_ / 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||1000) {
\$tbl[\$e->][\$e->] = \$tbl[\$new->][\$new->];
\$tbl[\$new->]->[\$new->] = 16;
\$e = [\$new->,\$new->];
}
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[\$\$_]->[\$\$_]==\$m}map{[\$_,0],[\$_,1],[\$_,2],[
+\$_,3]}0..3;
+]==\$m}
map {[\$_,0],[\$_,1],[\$_,2],[\$_,3]}0..3);
if (\$new){\$tbl[\$\$new][\$\$new]=\$m;\$tbl[\$\$tile][\$\$tile]=16;
+}
system (\$^O eq 'MSWin32' ? 'cls' : 'clear');
}
my \$e = shift; grep {\$_-><4 && \$_-><4 && \$_->>-1 && \$_-
+>>-1}
[\$\$e-1,\$\$e],[\$\$e+1,\$\$e],[\$\$e,\$\$e-1],[\$\$e,\$\$
+e+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(\$_->, sort {\$a-> <=> \$b->} map [\$_, rand],
1..15), 0), 1 & map { grep{ \$a[\$'] > \$_ } @a[\$_ + // .. 14] } 0..13;
sub xy { -row => \$_ % 4, -column => int \$_ / 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 (Priest) 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 (Parson) on Jun 13, 2017 at 20:35 UTC

Very impressive.

Congrats on 15 years of monk-dom.

Create A New User
Node Status?
node history
Node Type: CUFP [id://1192660]
Front-paged by Athanasius
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (5)
As of 2020-08-09 14:29 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
Which rocket would you take to Mars?

Results (54 votes). Check out past polls.

Notices?