Discipulus15puzzle.pl
perl Discipulus15puzzle.pl [ --verbose --nocolor --charsize n --positions 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 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
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!
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
Discipulus as found at www.perlmonks.org
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.
Re: Tk - Discipulus 15 puzzle
by tybalt89 (Monsignor) 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;
| [reply] [d/l] |
|
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.
| [reply] [d/l] |
|
#!/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 :(
| [reply] [d/l] |
|
I admire your work tybalt89, you have a real talent. :-)
| [reply] |
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. :-)
| [reply] |
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.
| [reply] |
|
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
| [reply] |
|
#!/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.
| [reply] [d/l] |
|
|
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.
| [reply] |
|
|
|
|
|
|
Re: Tk - Discipulus 15 puzzle
by RonW (Parson) on Jun 13, 2017 at 20:35 UTC
|
| [reply] |
|
|