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.10 |
our $VERSION = '1.0'; |
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 |
|
|
=cut |
158 |
|
|
|
159 |
|
|
sub as_text { |
160 |
|
|
my ($self) = @_; |
161 |
|
|
|
162 |
|
|
"$self->{data}\n" |
163 |
|
|
} |
164 |
|
|
|
165 |
|
|
=item $binary = $level->as_binpack |
166 |
|
|
|
167 |
root |
1.8 |
Binpack is a very compact binary format (usually 17% of the size of an xsb |
168 |
|
|
file), that is still reasonably easy to encode/decode. |
169 |
|
|
|
170 |
|
|
It only tries to store simplified levels with full fidelity - other levels |
171 |
|
|
can be slightly changed outside the playable area. |
172 |
|
|
|
173 |
root |
1.1 |
=cut |
174 |
|
|
|
175 |
|
|
sub as_binpack { |
176 |
|
|
my ($self) = @_; |
177 |
|
|
|
178 |
|
|
my $binpack = chr $self->{w} - 2; |
179 |
|
|
|
180 |
|
|
my $w = $self->{w}; |
181 |
|
|
|
182 |
|
|
my $data = $self->{data}; |
183 |
|
|
|
184 |
|
|
# crop away all four borders |
185 |
|
|
$data =~ s/^#+\n//; |
186 |
|
|
$data =~ s/#+$//; |
187 |
|
|
$data =~ s/#$//mg; |
188 |
|
|
$data =~ s/^#//mg; |
189 |
|
|
|
190 |
|
|
$data =~ y/\n//d; |
191 |
|
|
|
192 |
|
|
$data =~ /[\@\+]/ or die; |
193 |
|
|
my $s = $-[0]; |
194 |
|
|
(substr $data, $s, 1) =~ y/@+/ ./; |
195 |
|
|
|
196 |
|
|
$data =~ s/\#\#\#/101/g; |
197 |
|
|
$data =~ s/\ \ \ /110/g; |
198 |
|
|
$data =~ s/\#\ /111/g; |
199 |
|
|
|
200 |
|
|
$data =~ s/\#/000/g; |
201 |
|
|
$data =~ s/\ /001/g; |
202 |
|
|
$data =~ s/\./010/g; |
203 |
|
|
$data =~ s/\*/011/g; |
204 |
|
|
$data =~ s/\$/100/g; |
205 |
|
|
|
206 |
|
|
# width, @-offset, data |
207 |
|
|
|
208 |
|
|
pack "wwB*", $w - 2, $s, $data |
209 |
|
|
} |
210 |
|
|
|
211 |
|
|
=item @lines = $level->as_lines |
212 |
|
|
|
213 |
|
|
=cut |
214 |
|
|
|
215 |
|
|
sub as_lines { |
216 |
|
|
split /\n/, $_[0]{data} |
217 |
|
|
} |
218 |
|
|
|
219 |
root |
1.5 |
=item $line = $level->as_rle |
220 |
root |
1.1 |
|
221 |
|
|
http://www.sokobano.de/wiki/index.php?title=Level_format |
222 |
|
|
|
223 |
|
|
=cut |
224 |
|
|
|
225 |
|
|
sub as_rle { |
226 |
|
|
my $data = $_[0]{data}; |
227 |
|
|
|
228 |
|
|
$data =~ s/ +$//mg; |
229 |
|
|
$data =~ y/\n /|-/; |
230 |
|
|
$data =~ s/((.)\2{2,8})/(length $1) . $2/ge; |
231 |
|
|
|
232 |
|
|
$data |
233 |
|
|
} |
234 |
|
|
|
235 |
|
|
=item ($x, $y) = $level->start |
236 |
|
|
|
237 |
root |
1.5 |
Returns (0-based) starting coordinate. |
238 |
|
|
|
239 |
root |
1.1 |
=cut |
240 |
|
|
|
241 |
|
|
sub start { |
242 |
|
|
my ($self) = @_; |
243 |
|
|
|
244 |
|
|
$self->{data} =~ /[\@\+]/ or Carp::croak "level has no starting point"; |
245 |
|
|
$self->pos2xy ($-[0]); |
246 |
|
|
} |
247 |
|
|
|
248 |
|
|
=item $level->hflip |
249 |
|
|
|
250 |
root |
1.10 |
Mirror horizontally. |
251 |
|
|
|
252 |
root |
1.1 |
=item $level->vflip |
253 |
|
|
|
254 |
root |
1.10 |
Mirror vertically. |
255 |
|
|
|
256 |
|
|
=item $level->transpose |
257 |
|
|
|
258 |
|
|
Transpose level (mirror at top-left/bottom-right diagonal). |
259 |
root |
1.1 |
|
260 |
|
|
=item $level->rotate_90 |
261 |
|
|
|
262 |
root |
1.10 |
Rotate by 90 degrees clockwise. |
263 |
|
|
|
264 |
root |
1.1 |
=item $level->rotate_180 |
265 |
|
|
|
266 |
root |
1.10 |
Rotate by 180 degrees clockwise. |
267 |
|
|
|
268 |
root |
1.1 |
=cut |
269 |
|
|
|
270 |
|
|
sub hflip { |
271 |
|
|
$_[0]{data} = join "\n", map { scalar reverse $_ } split /\n/, $_[0]{data}; |
272 |
|
|
} |
273 |
|
|
|
274 |
|
|
sub vflip { |
275 |
|
|
$_[0]{data} = join "\n", reverse split /\n/, $_[0]{data}; |
276 |
|
|
} |
277 |
|
|
|
278 |
|
|
sub transpose { |
279 |
|
|
my ($self) = @_; |
280 |
|
|
|
281 |
|
|
# there must be a more elegant way :/ |
282 |
|
|
my @c; |
283 |
|
|
|
284 |
|
|
for (split /\n/, $self->{data}) { |
285 |
|
|
my $i; |
286 |
|
|
|
287 |
|
|
$c[$i++] .= $_ for split //; |
288 |
|
|
} |
289 |
|
|
|
290 |
|
|
$self->{data} = join "\n", @c; |
291 |
|
|
($self->{w}, $self->{h}) = ($self->{h}, $self->{w}) |
292 |
|
|
} |
293 |
|
|
|
294 |
|
|
sub rotate_90 { |
295 |
|
|
$_[0]->vflip; |
296 |
|
|
$_[0]->transpose; |
297 |
|
|
} |
298 |
|
|
|
299 |
|
|
sub rotate_180 { |
300 |
|
|
$_[0]{data} = reverse $_[0]{data}; |
301 |
|
|
} |
302 |
|
|
|
303 |
|
|
=item $id = $level->simplify |
304 |
|
|
|
305 |
|
|
Detect playable area, crop to smallest size. |
306 |
|
|
|
307 |
|
|
=cut |
308 |
|
|
|
309 |
|
|
sub simplify { |
310 |
|
|
my ($self) = @_; |
311 |
|
|
|
312 |
|
|
# first detect playable area |
313 |
|
|
my ($w, $h) = ($self->{w}, $self->{h}); |
314 |
|
|
my ($x, $y) = $self->start; |
315 |
|
|
|
316 |
|
|
my @data = split /\n/, $self->{data}; |
317 |
|
|
my @mask = @data; |
318 |
|
|
|
319 |
|
|
y/#/\x00/c, y/#/\x7f/ for @mask; |
320 |
|
|
|
321 |
|
|
my @stack = [$x, $y, 0]; |
322 |
|
|
|
323 |
|
|
while (@stack) { |
324 |
|
|
my ($x, $y, $l) = @{ pop @stack }; |
325 |
|
|
my $line = $mask[$y]; |
326 |
|
|
|
327 |
|
|
for my $x ($x .. $x + $l) { |
328 |
|
|
(reverse substr $line, 0, $x + 1) =~ /\x00+/ |
329 |
|
|
or next; |
330 |
|
|
|
331 |
|
|
$l = $+[0]; |
332 |
|
|
|
333 |
|
|
$x -= $l - 1; |
334 |
|
|
(substr $line, $x) =~ /^\x00+/ or die; |
335 |
|
|
$l = $+[0]; |
336 |
|
|
|
337 |
|
|
substr $mask[$y], $x, $l, "\xff" x $l; |
338 |
|
|
|
339 |
|
|
push @stack, [$x, $y - 1, $l - 1] if $y > 0; |
340 |
|
|
push @stack, [$x, $y + 1, $l - 1] if $y < $h - 1; |
341 |
|
|
} |
342 |
|
|
} |
343 |
|
|
|
344 |
|
|
my $walls = "#" x $w; |
345 |
|
|
|
346 |
|
|
for (0 .. $h - 1) { |
347 |
|
|
$data[$_] = ($data[$_] & $mask[$_]) | ($walls & ~$mask[$_]); |
348 |
|
|
} |
349 |
|
|
|
350 |
|
|
# reduce borders |
351 |
|
|
pop @data while @data > 2 && $data[-2] eq $walls; # bottom |
352 |
|
|
shift @data while $data[1] eq $walls; # top |
353 |
|
|
|
354 |
|
|
for ($self->{data} = join "\n", @data) { |
355 |
|
|
s/#$//mg until /[^#]#$/m; # right |
356 |
|
|
s/^#//mg until /^#[^#]/m; # left |
357 |
|
|
} |
358 |
|
|
|
359 |
|
|
# phew, done |
360 |
|
|
} |
361 |
|
|
|
362 |
|
|
=item $id = $level->normalise |
363 |
|
|
|
364 |
root |
1.10 |
Simplifies the level map and calculates/returns its identity code. |
365 |
|
|
. |
366 |
root |
1.1 |
http://www.sourcecode.se/sokoban/level_id.php, assume uppercase and hex. |
367 |
|
|
|
368 |
|
|
=cut |
369 |
|
|
|
370 |
|
|
sub normalise { |
371 |
|
|
my ($self) = @_; |
372 |
|
|
|
373 |
|
|
$self->simplify; |
374 |
|
|
|
375 |
|
|
require Digest::MD5; |
376 |
|
|
|
377 |
|
|
my ($best_md5, $best_data) = "\xff" x 9; |
378 |
|
|
|
379 |
|
|
my $chk = sub { |
380 |
|
|
my $md5 = substr Digest::MD5::md5 ("$self->{data}\n"), 0, 8; |
381 |
|
|
if ($md5 lt $best_md5) { |
382 |
|
|
$best_md5 = $md5; |
383 |
|
|
$best_data = $self->{data}; |
384 |
|
|
} |
385 |
|
|
}; |
386 |
|
|
|
387 |
|
|
$chk->(); $self->hflip; |
388 |
|
|
$chk->(); $self->vflip; |
389 |
|
|
$chk->(); $self->hflip; |
390 |
|
|
$chk->(); $self->rotate_90; |
391 |
|
|
$chk->(); $self->hflip; |
392 |
|
|
$chk->(); $self->vflip; |
393 |
|
|
$chk->(); $self->hflip; |
394 |
|
|
$chk->(); |
395 |
|
|
|
396 |
|
|
$self->data ($best_data, "text"); |
397 |
|
|
|
398 |
|
|
uc unpack "H*", $best_md5 |
399 |
|
|
} |
400 |
|
|
|
401 |
|
|
=item $levels = Games::Sokoban::load_sokevo $path |
402 |
|
|
|
403 |
|
|
Loads a sokevo snapshot/history file and returns all contained levels as |
404 |
|
|
Games::Sokoban objects in an arrayref. |
405 |
|
|
|
406 |
|
|
=cut |
407 |
|
|
|
408 |
|
|
sub load_sokevo($) { |
409 |
root |
1.9 |
open my $fh, "<:crlf", $_[0] |
410 |
root |
1.1 |
or Carp::croak "$_[0]: $!"; |
411 |
|
|
|
412 |
|
|
my @levels; |
413 |
|
|
|
414 |
root |
1.9 |
# skip file header |
415 |
|
|
local $/ = "\n\n"; |
416 |
|
|
scalar <$fh>; |
417 |
|
|
|
418 |
root |
1.1 |
while (<$fh>) { |
419 |
root |
1.9 |
chomp; |
420 |
root |
1.10 |
my %meta = split /(?:: |\n)/; |
421 |
root |
1.9 |
|
422 |
|
|
$_ = <$fh>; |
423 |
root |
1.1 |
|
424 |
root |
1.9 |
/^##+\n/ or last; |
425 |
root |
1.7 |
|
426 |
root |
1.9 |
# sokevo internally locks some cells |
427 |
|
|
y/^%:,;-=?/ #.$* +#/; |
428 |
|
|
|
429 |
root |
1.10 |
# skip levels without pusher |
430 |
|
|
y/@+// or next; |
431 |
|
|
|
432 |
root |
1.9 |
push @levels, new Games::Sokoban data => $_, meta => \%meta; |
433 |
root |
1.1 |
} |
434 |
|
|
|
435 |
|
|
\@levels |
436 |
|
|
} |
437 |
|
|
|
438 |
|
|
1; |
439 |
|
|
|
440 |
|
|
=back |
441 |
|
|
|
442 |
|
|
=head1 AUTHOR |
443 |
|
|
|
444 |
|
|
Marc Lehmann <schmorp@schmorp.de> |
445 |
|
|
http://home.schmorp.de/ |
446 |
|
|
|
447 |
|
|
=cut |
448 |
|
|
|