Games-Sokoban/Sokoban.pm

=head1 NAME

Games::Sokoban - load/transform/save sokoban levels in various formats

=head1 SYNOPSIS

 use Games::Sokoban;

=head1 DESCRIPTION

I needed something like this quickly - if you need better docs, you have to ask.

Supports xsb (text), rle, sokevo and a small "binpack" format for input
and output and can normalise levels as well as calculate unique IDs.

=over 4

=cut

package Games::Sokoban;

use common::sense;

use Carp ();
use List::Util ();

our $VERSION = '1.01';

=item $level = new Games::Sokoban [format => "text|rle|binpack"], [data => "###..."]

=cut

sub new {
   my ($class, %arg) = @_;

   my $self = bless \%arg, $class;

   $self->data (delete $self->{data}, delete $self->{format})
      if exists $self->{data};

   $self
}

=item $level = new_from_file Games::Sokoban $path[, $format]

=cut

sub new_from_file {
   my ($class, $path, $format) = @_;

   open my $fh, "<:perlio", $path
      or Carp::croak "$path: $!";
   local $/;

   $class->new (data => (scalar <$fh>), format => $format)
}

sub detect_format($) {
   my ($data) = @_;

   return "text" if $data =~ /^[ #\@\*\$\.\+\015\012\-_]+$/;

   return "rle"  if $data =~ /^[ #\@\*\$\.\+\015\012\-_|1-9]+$/;

   my ($a, $b) = unpack "ww", $data;
   return "binpack" if defined $a && defined $b;

   Carp::croak "unable to autodetect sokoban level format";
}

=item $level->data ([$new_data, [$new_data_format]])

Sets the level from the given data.

=cut

sub data {
   if (@_ > 1) {
      my ($self, $data, $format) = @_;

      $format ||= detect_format $data;

      if ($format eq "text" or $format eq "rle") {
         $data =~ y/-_|/  \n/;
         $data =~ s/(\d)(.)/$2 x $1/ge;
         my @lines = split /[\015\012]+/, $data;
         my $w = List::Util::max map length, @lines;

         $_ .= " " x ($w - length)
            for @lines;

         $self->{data} = join "\n", @lines;

      } elsif ($format eq "binpack") {
         (my ($w, $s), $data) = unpack "wwB*", $data;

         my @enc = ('#', '$', '.', '   ', ' ', '###', '*', '# ');

         $data = join "",
                 map $enc[$_],
                 unpack "C*",
                 pack "(b*)*",
                 unpack "(a3)*", $data;

         # clip extra chars (max. 2)
         my $extra = (length $data) % $w;
         substr $data, -$extra, $extra, "" if $extra;

         (substr $data, $s, 1) =~ y/ ./@+/;

         $self->{data} =
           join "\n",
           map "#$_#",
               "#" x $w,
               (unpack "(a$w)*", $data),
               "#" x $w;
           
      } else {
         Carp::croak "$format: unsupported sokoban level format requested";
      }

      $self->{format} = $format;
      $self->update;
   }

   $_[0]{data}
}

sub pos2xy {
   use integer;

   $_[1] >= 0
      or Carp::croak "illegal buffer offset";

   (
      $_[1] % ($_[0]{w} + 1),
      $_[1] / ($_[0]{w} + 1),
   )
}

sub update {
   my ($self) = @_;

   for ($self->{data}) {
      s/^\n+//;
      s/\n$//;

      /^[^\n]+/ or die;

      $self->{w} = index $_, "\n";
      $self->{h} = y/\n// + 1;
   }
}

=item $text = $level->as_text

Returns the level in xsb/text format - every row of the level is one line
ended by a newline, e.g.:

   "###\n# #\n###\n"

=cut

sub as_text {
   my ($self) = @_;

   "$self->{data}\n"
}

=item $binary = $level->as_binpack

Binpack is a very compact binary format (usually 17% of the size of an xsb
file), that is still reasonably easy to encode/decode.

It only tries to store simplified levels with full fidelity - other levels
can be slightly changed outside the playable area.

=cut

sub as_binpack {
   my ($self) = @_;

   my $binpack = chr $self->{w} - 2;

   my $w = $self->{w};

   my $data = $self->{data};

   # crop away all four borders
   $data =~ s/^#+\n//;
   $data =~ s/#+$//;
   $data =~ s/#$//mg;
   $data =~ s/^#//mg;

   $data =~ y/\n//d;

   $data =~ /[\@\+]/ or die;
   my $s = $-[0];
   (substr $data, $s, 1) =~ y/@+/ ./;

   $data =~ s/\#\#\#/101/g;
   $data =~ s/\ \ \ /110/g;
   $data =~ s/\#\ /111/g;

   $data =~ s/\#/000/g;
   $data =~ s/\ /001/g;
   $data =~ s/\./010/g;
   $data =~ s/\*/011/g;
   $data =~ s/\$/100/g;

   # width, @-offset, data

   pack "wwB*", $w - 2, $s, $data
}

=item @lines = $level->as_lines

Returns the level as a list of rows, each row is a text representation of
the respective level row, e.g.:

   ("###", "# #", "###")

=cut

sub as_lines {
   split /\n/, $_[0]{data}
}

=item $line = $level->as_rle

http://www.sokobano.de/wiki/index.php?title=Level_format

Example:

   "3#|# #|3#"

=cut

sub as_rle {
   my $data = $_[0]{data};

   $data =~ s/ +$//mg;
   $data =~ y/\n /|-/;
   $data =~ s/((.)\2{2,8})/(length $1) . $2/ge;

   $data
}

=item ($x, $y) = $level->start

Returns (0-based) starting coordinate.

=cut

sub start {
   my ($self) = @_;

   $self->{data} =~ /[\@\+]/ or Carp::croak "level has no starting point";
   $self->pos2xy ($-[0]);
}

=item $level->hflip

Mirror horizontally.

=item $level->vflip

Mirror vertically.

=item $level->transpose

Transpose level (mirror at top-left/bottom-right diagonal).

=item $level->rotate_90

Rotate by 90 degrees clockwise.

=item $level->rotate_180

Rotate by 180 degrees clockwise.

=cut

sub hflip {
   $_[0]{data} = join "\n", map { scalar reverse $_ } split /\n/, $_[0]{data};
}

sub vflip {
   $_[0]{data} = join "\n", reverse split /\n/, $_[0]{data};
}

sub transpose {
   my ($self) = @_;

   # there must be a more elegant way :/
   my @c;

   for (split /\n/, $self->{data}) {
      my $i;

      $c[$i++] .= $_ for split //;
   }

   $self->{data} = join "\n", @c;
   ($self->{w}, $self->{h}) = ($self->{h}, $self->{w})
}

sub rotate_90 {
   $_[0]->vflip;
   $_[0]->transpose;
}

sub rotate_180 {
   $_[0]{data} = reverse $_[0]{data};
}

=item $id = $level->simplify

Detect playable area, crop to smallest size.

=cut

sub simplify {
   my ($self) = @_;

   # first detect playable area
   my ($w, $h) = ($self->{w}, $self->{h});
   my ($x, $y) = $self->start;

   my @data = split /\n/, $self->{data};
   my @mask = @data;

   y/#/\x00/c, y/#/\x7f/ for @mask;

   my @stack = [$x, $y, 0];

   while (@stack) {
      my ($x, $y, $l) = @{ pop @stack };
      my $line = $mask[$y];

      for my $x ($x .. $x + $l) {
         (reverse substr $line, 0, $x + 1) =~ /\x00+/
            or next;

         $l = $+[0];

         $x -= $l - 1;
         (substr $line, $x) =~ /^\x00+/ or die;
         $l = $+[0];

         substr $mask[$y], $x, $l, "\xff" x $l;

         push @stack, [$x, $y - 1, $l - 1] if $y > 0;
         push @stack, [$x, $y + 1, $l - 1] if $y < $h - 1;
      }
   }

   my $walls = "#" x $w;

   for (0 .. $h - 1) {
      $data[$_] = ($data[$_] & $mask[$_]) | ($walls & ~$mask[$_]);
   }

   # reduce borders
   pop   @data while @data > 2 && $data[-2] eq $walls; # bottom
   shift @data while $data[1] eq $walls; # top

   for ($self->{data} = join "\n", @data) {
      s/#$//mg until /[^#]#$/m; # right
      s/^#//mg until /^#[^#]/m; # left
   }

   # phew, done
}

=item $id = $level->normalise

Simplifies the level map and calculates/returns its identity code.
.
http://www.sourcecode.se/sokoban/level_id.php, assume uppercase and hex.

=cut

sub normalise {
   my ($self) = @_;

   $self->simplify;

   require Digest::MD5;

   my ($best_md5, $best_data) = "\xff" x 9;

   my $chk = sub {
      my $md5 = substr Digest::MD5::md5 ("$self->{data}\n"), 0, 8;
      if ($md5 lt $best_md5) {
         $best_md5  = $md5;
         $best_data = $self->{data};
      }
   };

   $chk->(); $self->hflip;
   $chk->(); $self->vflip;
   $chk->(); $self->hflip;
   $chk->(); $self->rotate_90;
   $chk->(); $self->hflip;
   $chk->(); $self->vflip;
   $chk->(); $self->hflip;
   $chk->();

   $self->data ($best_data, "text");

   uc unpack "H*", $best_md5
}

=item $levels = Games::Sokoban::load_sokevo $path

Loads a sokevo snapshot/history file and returns all contained levels as
Games::Sokoban objects in an arrayref.

=cut

sub load_sokevo($) {
   open my $fh, "<:crlf", $_[0]
      or Carp::croak "$_[0]: $!";

   my @levels;

   # skip file header
   local $/ = "\n\n";
   scalar <$fh>;

   while (<$fh>) {
      chomp;
      my %meta = split /(?:: |\n)/;

      $_ = <$fh>;

      /^##+\n/ or last;

      # sokevo internally locks some cells
      y/^%:,;-=?/ #.$* +#/;

      # skip levels without pusher
      y/@+// or next;

      push @levels, new Games::Sokoban data => $_, meta => \%meta;
   }

   \@levels
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.12
Committed:	Wed May 12 20:55:30 2010 UTC (14 years ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.11:	+14 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Games::Sokoban - load/transform/save sokoban levels in various formats
4
5			=head1 SYNOPSIS
6
7			use Games::Sokoban;
8
9			=head1 DESCRIPTION
10
11			I needed something like this quickly - if you need better docs, you have to ask.
12
13	root	1.2	Supports xsb (text), rle, sokevo and a small "binpack" format for input
14			and output and can normalise levels as well as calculate unique IDs.
15	root	1.1
16			=over 4
17
18			=cut
19
20			package Games::Sokoban;
21
22			use common::sense;
23
24			use Carp ();
25			use List::Util ();
26
27	root	1.11	our $VERSION = '1.01';
28	root	1.1
29	root	1.4	=item $level = new Games::Sokoban [format => "text\|rle\|binpack"], [data => "###..."]
30	root	1.1
31			=cut
32
33			sub new {
34			my ($class, %arg) = @_;
35
36			my $self = bless \%arg, $class;
37
38			$self->data (delete $self->{data}, delete $self->{format})
39			if exists $self->{data};
40
41			$self
42			}
43
44			=item $level = new_from_file Games::Sokoban $path[, $format]
45
46			=cut
47
48			sub new_from_file {
49			my ($class, $path, $format) = @_;
50
51			open my $fh, "<:perlio", $path
52			or Carp::croak "$path: $!";
53			local $/;
54
55			$class->new (data => (scalar <$fh>), format => $format)
56			}
57
58			sub detect_format($) {
59			my ($data) = @_;
60
61			return "text" if $data =~ /^[ #\@\*\$\.\+\015\012\-_]+$/;
62
63			return "rle" if $data =~ /^[ #\@\*\$\.\+\015\012\-_\|1-9]+$/;
64
65			my ($a, $b) = unpack "ww", $data;
66			return "binpack" if defined $a && defined $b;
67
68			Carp::croak "unable to autodetect sokoban level format";
69			}
70
71	root	1.9	=item $level->data ([$new_data, [$new_data_format]])
72	root	1.1
73	root	1.6	Sets the level from the given data.
74
75	root	1.1	=cut
76
77			sub data {
78	root	1.6	if (@_ > 1) {
79			my ($self, $data, $format) = @_;
80
81			$format \|\|= detect_format $data;
82	root	1.1
83	root	1.6	if ($format eq "text" or $format eq "rle") {
84			$data =~ y/-_\|/ \n/;
85			$data =~ s/(\d)(.)/$2 x $1/ge;
86			my @lines = split /[\015\012]+/, $data;
87			my $w = List::Util::max map length, @lines;
88
89			$_ .= " " x ($w - length)
90			for @lines;
91
92			$self->{data} = join "\n", @lines;
93
94			} elsif ($format eq "binpack") {
95			(my ($w, $s), $data) = unpack "wwB*", $data;
96
97			my @enc = ('#', '$', '.', ' ', ' ', '###', '*', '# ');
98
99			$data = join "",
100			map $enc[$_],
101			unpack "C*",
102			pack "(b)",
103			unpack "(a3)*", $data;
104
105			# clip extra chars (max. 2)
106			my $extra = (length $data) % $w;
107			substr $data, -$extra, $extra, "" if $extra;
108
109			(substr $data, $s, 1) =~ y/ ./@+/;
110
111			$self->{data} =
112			join "\n",
113			map "#$_#",
114			"#" x $w,
115			(unpack "(a$w)*", $data),
116			"#" x $w;
117
118			} else {
119			Carp::croak "$format: unsupported sokoban level format requested";
120			}
121	root	1.1
122	root	1.9	$self->{format} = $format;
123	root	1.6	$self->update;
124	root	1.1	}
125
126	root	1.6	$_[0]{data}
127	root	1.1	}
128
129			sub pos2xy {
130			use integer;
131
132			$_[1] >= 0
133			or Carp::croak "illegal buffer offset";
134
135			(
136			$_[1] % ($_[0]{w} + 1),
137			$_[1] / ($_[0]{w} + 1),
138			)
139			}
140
141			sub update {
142			my ($self) = @_;
143
144			for ($self->{data}) {
145			s/^\n+//;
146			s/\n$//;
147
148			/^[^\n]+/ or die;
149
150			$self->{w} = index $_, "\n";
151			$self->{h} = y/\n// + 1;
152			}
153			}
154
155			=item $text = $level->as_text
156
157	root	1.12	Returns the level in xsb/text format - every row of the level is one line
158			ended by a newline, e.g.:
159
160			"###\n# #\n###\n"
161
162	root	1.1	=cut
163
164			sub as_text {
165			my ($self) = @_;
166
167			"$self->{data}\n"
168			}
169
170			=item $binary = $level->as_binpack
171
172	root	1.8	Binpack is a very compact binary format (usually 17% of the size of an xsb
173			file), that is still reasonably easy to encode/decode.
174
175			It only tries to store simplified levels with full fidelity - other levels
176			can be slightly changed outside the playable area.
177
178	root	1.1	=cut
179
180			sub as_binpack {
181			my ($self) = @_;
182
183			my $binpack = chr $self->{w} - 2;
184
185			my $w = $self->{w};
186
187			my $data = $self->{data};
188
189			# crop away all four borders
190			$data =~ s/^#+\n//;
191			$data =~ s/#+$//;
192			$data =~ s/#$//mg;
193			$data =~ s/^#//mg;
194
195			$data =~ y/\n//d;
196
197			$data =~ /[\@\+]/ or die;
198			my $s = $-[0];
199			(substr $data, $s, 1) =~ y/@+/ ./;
200
201			$data =~ s/\#\#\#/101/g;
202			$data =~ s/\ \ \ /110/g;
203			$data =~ s/\#\ /111/g;
204
205			$data =~ s/\#/000/g;
206			$data =~ s/\ /001/g;
207			$data =~ s/\./010/g;
208			$data =~ s/\*/011/g;
209			$data =~ s/\$/100/g;
210
211			# width, @-offset, data
212
213			pack "wwB*", $w - 2, $s, $data
214			}
215
216			=item @lines = $level->as_lines
217
218	root	1.12	Returns the level as a list of rows, each row is a text representation of
219			the respective level row, e.g.:
220
221			("###", "# #", "###")
222
223	root	1.1	=cut
224
225			sub as_lines {
226			split /\n/, $_[0]{data}
227			}
228
229	root	1.5	=item $line = $level->as_rle
230	root	1.1
231			http://www.sokobano.de/wiki/index.php?title=Level_format
232
233	root	1.12	Example:
234
235			"3#\|# #\|3#"
236
237	root	1.1	=cut
238
239			sub as_rle {
240			my $data = $_[0]{data};
241
242			$data =~ s/ +$//mg;
243			$data =~ y/\n /\|-/;
244			$data =~ s/((.)\2{2,8})/(length $1) . $2/ge;
245
246			$data
247			}
248
249			=item ($x, $y) = $level->start
250
251	root	1.5	Returns (0-based) starting coordinate.
252
253	root	1.1	=cut
254
255			sub start {
256			my ($self) = @_;
257
258			$self->{data} =~ /[\@\+]/ or Carp::croak "level has no starting point";
259			$self->pos2xy ($-[0]);
260			}
261
262			=item $level->hflip
263
264	root	1.10	Mirror horizontally.
265
266	root	1.1	=item $level->vflip
267
268	root	1.10	Mirror vertically.
269
270			=item $level->transpose
271
272			Transpose level (mirror at top-left/bottom-right diagonal).
273	root	1.1
274			=item $level->rotate_90
275
276	root	1.10	Rotate by 90 degrees clockwise.
277
278	root	1.1	=item $level->rotate_180
279
280	root	1.10	Rotate by 180 degrees clockwise.
281
282	root	1.1	=cut
283
284			sub hflip {
285			$_[0]{data} = join "\n", map { scalar reverse $_ } split /\n/, $_[0]{data};
286			}
287
288			sub vflip {
289			$_[0]{data} = join "\n", reverse split /\n/, $_[0]{data};
290			}
291
292			sub transpose {
293			my ($self) = @_;
294
295			# there must be a more elegant way :/
296			my @c;
297
298			for (split /\n/, $self->{data}) {
299			my $i;
300
301			$c[$i++] .= $_ for split //;
302			}
303
304			$self->{data} = join "\n", @c;
305			($self->{w}, $self->{h}) = ($self->{h}, $self->{w})
306			}
307
308			sub rotate_90 {
309			$_[0]->vflip;
310			$_[0]->transpose;
311			}
312
313			sub rotate_180 {
314			$_[0]{data} = reverse $_[0]{data};
315			}
316
317			=item $id = $level->simplify
318
319			Detect playable area, crop to smallest size.
320
321			=cut
322
323			sub simplify {
324			my ($self) = @_;
325
326			# first detect playable area
327			my ($w, $h) = ($self->{w}, $self->{h});
328			my ($x, $y) = $self->start;
329
330			my @data = split /\n/, $self->{data};
331			my @mask = @data;
332
333			y/#/\x00/c, y/#/\x7f/ for @mask;
334
335			my @stack = [$x, $y, 0];
336
337			while (@stack) {
338			my ($x, $y, $l) = @{ pop @stack };
339			my $line = $mask[$y];
340
341			for my $x ($x .. $x + $l) {
342			(reverse substr $line, 0, $x + 1) =~ /\x00+/
343			or next;
344
345			$l = $+[0];
346
347			$x -= $l - 1;
348			(substr $line, $x) =~ /^\x00+/ or die;
349			$l = $+[0];
350
351			substr $mask[$y], $x, $l, "\xff" x $l;
352
353			push @stack, [$x, $y - 1, $l - 1] if $y > 0;
354			push @stack, [$x, $y + 1, $l - 1] if $y < $h - 1;
355			}
356			}
357
358			my $walls = "#" x $w;
359
360			for (0 .. $h - 1) {
361			$data[$_] = ($data[$_] & $mask[$_]) \| ($walls & ~$mask[$_]);
362			}
363
364			# reduce borders
365			pop @data while @data > 2 && $data[-2] eq $walls; # bottom
366			shift @data while $data[1] eq $walls; # top
367
368			for ($self->{data} = join "\n", @data) {
369			s/#$//mg until /[^#]#$/m; # right
370			s/^#//mg until /^#[^#]/m; # left
371			}
372
373			# phew, done
374			}
375
376			=item $id = $level->normalise
377
378	root	1.10	Simplifies the level map and calculates/returns its identity code.
379			.
380	root	1.1	http://www.sourcecode.se/sokoban/level_id.php, assume uppercase and hex.
381
382			=cut
383
384			sub normalise {
385			my ($self) = @_;
386
387			$self->simplify;
388
389			require Digest::MD5;
390
391			my ($best_md5, $best_data) = "\xff" x 9;
392
393			my $chk = sub {
394			my $md5 = substr Digest::MD5::md5 ("$self->{data}\n"), 0, 8;
395			if ($md5 lt $best_md5) {
396			$best_md5 = $md5;
397			$best_data = $self->{data};
398			}
399			};
400
401			$chk->(); $self->hflip;
402			$chk->(); $self->vflip;
403			$chk->(); $self->hflip;
404			$chk->(); $self->rotate_90;
405			$chk->(); $self->hflip;
406			$chk->(); $self->vflip;
407			$chk->(); $self->hflip;
408			$chk->();
409
410			$self->data ($best_data, "text");
411
412			uc unpack "H*", $best_md5
413			}
414
415			=item $levels = Games::Sokoban::load_sokevo $path
416
417			Loads a sokevo snapshot/history file and returns all contained levels as
418			Games::Sokoban objects in an arrayref.
419
420			=cut
421
422			sub load_sokevo($) {
423	root	1.9	open my $fh, "<:crlf", $_[0]
424	root	1.1	or Carp::croak "$_[0]: $!";
425
426			my @levels;
427
428	root	1.9	# skip file header
429			local $/ = "\n\n";
430			scalar <$fh>;
431
432	root	1.1	while (<$fh>) {
433	root	1.9	chomp;
434	root	1.10	my %meta = split /(?:: \|\n)/;
435	root	1.9
436			$_ = <$fh>;
437	root	1.1
438	root	1.9	/^##+\n/ or last;
439	root	1.7
440	root	1.9	# sokevo internally locks some cells
441			y/^%:,;-=?/ #.$* +#/;
442
443	root	1.10	# skip levels without pusher
444			y/@+// or next;
445
446	root	1.9	push @levels, new Games::Sokoban data => $_, meta => \%meta;
447	root	1.1	}
448
449			\@levels
450			}
451
452			1;
453
454			=back
455
456			=head1 AUTHOR
457
458			Marc Lehmann <schmorp@schmorp.de>
459			http://home.schmorp.de/
460
461			=cut
462