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 = '0.01';

=item $level = new Games::Sokoban [format => "text|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\-_]+$/;

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

   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]]])

=cut

sub data {
   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->update;

   ($self->{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

=cut

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

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

=item $binary = $level->as_binpack

=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

=cut

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

=item @lines = $level->as_rle

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

=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

=cut

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

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

=item $level->hflip

=item $level->vflip

=item $level->transpose # topleft to bottomright

=item $level->rotate_90

=item $level->rotate_180

=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

normalises the level map and calculates/returns it's 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, "<", $_[0]
      or Carp::croak "$_[0]: $!";

   my @levels;

   while (<$fh>) {
      if (/^##+$/) {
         my $data = $_;
         while (<$fh>) {
            $data .= $_;
            last if /^$/;
         }

         push @levels, new Games::Sokoban data => $data;
      }
   }

   \@levels
}

1;

=back

=head1 AUTHOR

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

=cut

Revision:	1.2
Committed:	Tue May 11 23:20:21 2010 UTC (14 years ago) by root
Branch:	MAIN
Changes since 1.1:	+2 -2 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			our $VERSION = '0.01';
28
29			=item $level = new Games::Sokoban [format => "text\|binpack"], [data => "###..."]
30
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			warn $data;#d#
64			return "rle" if $data =~ /^[ #\@\*\$\.\+\015\012\-_\|1-9]+$/;
65			exit 5;#d#
66
67			my ($a, $b) = unpack "ww", $data;
68			return "binpack" if defined $a && defined $b;
69
70			Carp::croak "unable to autodetect sokoban level format";
71			}
72
73			=item $level->data ([$new_data, [$new_data_format]]])
74
75			=cut
76
77			sub data {
78			my ($self, $data, $format) = @_;
79
80			$format \|\|= detect_format $data;
81
82			if ($format eq "text" or $format eq "rle") {
83			$data =~ y/-_\|/ \n/;
84			$data =~ s/(\d)(.)/$2 x $1/ge;
85			my @lines = split /[\015\012]+/, $data;
86			my $w = List::Util::max map length, @lines;
87
88			$_ .= " " x ($w - length)
89			for @lines;
90
91			$self->{data} = join "\n", @lines;
92
93			} elsif ($format eq "binpack") {
94			(my ($w, $s), $data) = unpack "wwB*", $data;
95
96			my @enc = ('#', '$', '.', ' ', ' ', '###', '*', '# ');
97
98			$data = join "",
99			map $enc[$_],
100			unpack "C*",
101			pack "(b)",
102			unpack "(a3)*", $data;
103
104			# clip extra chars (max. 2)
105			my $extra = (length $data) % $w;
106			substr $data, -$extra, $extra, "" if $extra;
107
108			(substr $data, $s, 1) =~ y/ ./@+/;
109
110			$self->{data} =
111			join "\n",
112			map "#$_#",
113			"#" x $w,
114			(unpack "(a$w)*", $data),
115			"#" x $w;
116
117			} else {
118			Carp::croak "$format: unsupported sokoban level format requested";
119			}
120
121			$self->update;
122
123			($self->{data})
124			}
125
126			sub pos2xy {
127			use integer;
128
129			$_[1] >= 0
130			or Carp::croak "illegal buffer offset";
131
132			(
133			$_[1] % ($_[0]{w} + 1),
134			$_[1] / ($_[0]{w} + 1),
135			)
136			}
137
138			sub update {
139			my ($self) = @_;
140
141			for ($self->{data}) {
142			s/^\n+//;
143			s/\n$//;
144
145			/^[^\n]+/ or die;
146
147			$self->{w} = index $_, "\n";
148			$self->{h} = y/\n// + 1;
149			}
150			}
151
152			=item $text = $level->as_text
153
154			=cut
155
156			sub as_text {
157			my ($self) = @_;
158
159			"$self->{data}\n"
160			}
161
162			=item $binary = $level->as_binpack
163
164			=cut
165
166			sub as_binpack {
167			my ($self) = @_;
168
169			my $binpack = chr $self->{w} - 2;
170
171			my $w = $self->{w};
172
173			my $data = $self->{data};
174
175			# crop away all four borders
176			$data =~ s/^#+\n//;
177			$data =~ s/#+$//;
178			$data =~ s/#$//mg;
179			$data =~ s/^#//mg;
180
181			$data =~ y/\n//d;
182
183			$data =~ /[\@\+]/ or die;
184			my $s = $-[0];
185			(substr $data, $s, 1) =~ y/@+/ ./;
186
187			$data =~ s/\#\#\#/101/g;
188			$data =~ s/\ \ \ /110/g;
189			$data =~ s/\#\ /111/g;
190
191			$data =~ s/\#/000/g;
192			$data =~ s/\ /001/g;
193			$data =~ s/\./010/g;
194			$data =~ s/\*/011/g;
195			$data =~ s/\$/100/g;
196
197			# width, @-offset, data
198
199			pack "wwB*", $w - 2, $s, $data
200			}
201
202			=item @lines = $level->as_lines
203
204			=cut
205
206			sub as_lines {
207			split /\n/, $_[0]{data}
208			}
209
210			=item @lines = $level->as_rle
211
212			http://www.sokobano.de/wiki/index.php?title=Level_format
213
214			=cut
215
216			sub as_rle {
217			my $data = $_[0]{data};
218
219			$data =~ s/ +$//mg;
220			$data =~ y/\n /\|-/;
221			$data =~ s/((.)\2{2,8})/(length $1) . $2/ge;
222
223			$data
224			}
225
226			=item ($x, $y) = $level->start
227
228			=cut
229
230			sub start {
231			my ($self) = @_;
232
233			$self->{data} =~ /[\@\+]/ or Carp::croak "level has no starting point";
234			$self->pos2xy ($-[0]);
235			}
236
237			=item $level->hflip
238
239			=item $level->vflip
240
241			=item $level->transpose # topleft to bottomright
242
243			=item $level->rotate_90
244
245			=item $level->rotate_180
246
247			=cut
248
249			sub hflip {
250			$_[0]{data} = join "\n", map { scalar reverse $_ } split /\n/, $_[0]{data};
251			}
252
253			sub vflip {
254			$_[0]{data} = join "\n", reverse split /\n/, $_[0]{data};
255			}
256
257			sub transpose {
258			my ($self) = @_;
259
260			# there must be a more elegant way :/
261			my @c;
262
263			for (split /\n/, $self->{data}) {
264			my $i;
265
266			$c[$i++] .= $_ for split //;
267			}
268
269			$self->{data} = join "\n", @c;
270			($self->{w}, $self->{h}) = ($self->{h}, $self->{w})
271			}
272
273			sub rotate_90 {
274			$_[0]->vflip;
275			$_[0]->transpose;
276			}
277
278			sub rotate_180 {
279			$_[0]{data} = reverse $_[0]{data};
280			}
281
282			=item $id = $level->simplify
283
284			Detect playable area, crop to smallest size.
285
286			=cut
287
288			sub simplify {
289			my ($self) = @_;
290
291			# first detect playable area
292			my ($w, $h) = ($self->{w}, $self->{h});
293			my ($x, $y) = $self->start;
294
295			my @data = split /\n/, $self->{data};
296			my @mask = @data;
297
298			y/#/\x00/c, y/#/\x7f/ for @mask;
299
300			my @stack = [$x, $y, 0];
301
302			while (@stack) {
303			my ($x, $y, $l) = @{ pop @stack };
304			my $line = $mask[$y];
305
306			for my $x ($x .. $x + $l) {
307			(reverse substr $line, 0, $x + 1) =~ /\x00+/
308			or next;
309
310			$l = $+[0];
311
312			$x -= $l - 1;
313			(substr $line, $x) =~ /^\x00+/ or die;
314			$l = $+[0];
315
316			substr $mask[$y], $x, $l, "\xff" x $l;
317
318			push @stack, [$x, $y - 1, $l - 1] if $y > 0;
319			push @stack, [$x, $y + 1, $l - 1] if $y < $h - 1;
320			}
321			}
322
323			my $walls = "#" x $w;
324
325			for (0 .. $h - 1) {
326			$data[$_] = ($data[$_] & $mask[$_]) \| ($walls & ~$mask[$_]);
327			}
328
329			# reduce borders
330			pop @data while @data > 2 && $data[-2] eq $walls; # bottom
331			shift @data while $data[1] eq $walls; # top
332
333			for ($self->{data} = join "\n", @data) {
334			s/#$//mg until /[^#]#$/m; # right
335			s/^#//mg until /^#[^#]/m; # left
336			}
337
338			# phew, done
339			}
340
341			=item $id = $level->normalise
342
343			normalises the level map and calculates/returns it's identity code
344
345			http://www.sourcecode.se/sokoban/level_id.php, assume uppercase and hex.
346
347			=cut
348
349			sub normalise {
350			my ($self) = @_;
351
352			$self->simplify;
353
354			require Digest::MD5;
355
356			my ($best_md5, $best_data) = "\xff" x 9;
357
358			my $chk = sub {
359			my $md5 = substr Digest::MD5::md5 ("$self->{data}\n"), 0, 8;
360			if ($md5 lt $best_md5) {
361			$best_md5 = $md5;
362			$best_data = $self->{data};
363			}
364			};
365
366			$chk->(); $self->hflip;
367			$chk->(); $self->vflip;
368			$chk->(); $self->hflip;
369			$chk->(); $self->rotate_90;
370			$chk->(); $self->hflip;
371			$chk->(); $self->vflip;
372			$chk->(); $self->hflip;
373			$chk->();
374
375			$self->data ($best_data, "text");
376
377			uc unpack "H*", $best_md5
378			}
379
380			=item $levels = Games::Sokoban::load_sokevo $path
381
382			Loads a sokevo snapshot/history file and returns all contained levels as
383			Games::Sokoban objects in an arrayref.
384
385			=cut
386
387			sub load_sokevo($) {
388			open my $fh, "<", $_[0]
389			or Carp::croak "$_[0]: $!";
390
391			my @levels;
392
393			while (<$fh>) {
394			if (/^##+$/) {
395			my $data = $_;
396			while (<$fh>) {
397			$data .= $_;
398			last if /^$/;
399			}
400
401			push @levels, new Games::Sokoban data => $data;
402			}
403			}
404
405			\@levels
406			}
407
408			1;
409
410			=back
411
412			=head1 AUTHOR
413
414			Marc Lehmann <schmorp@schmorp.de>
415			http://home.schmorp.de/
416
417			=cut
418