| … | |
… | |
| 8 | |
8 | |
| 9 | =head1 DESCRIPTION |
9 | =head1 DESCRIPTION |
| 10 | |
10 | |
| 11 | I needed something like this quickly - if you need better docs, you have to ask. |
11 | I needed something like this quickly - if you need better docs, you have to ask. |
| 12 | |
12 | |
| 13 | Supports xsb (text), rle, sokevo and a small "binpack" format for input and |
13 | Supports xsb (text), rle, sokevo and a small "binpack" format for input |
| 14 | output. |
14 | and output and can normalise levels as well as calculate unique IDs. |
| 15 | |
15 | |
| 16 | =over 4 |
16 | =over 4 |
| 17 | |
17 | |
| 18 | =cut |
18 | =cut |
| 19 | |
19 | |
| … | |
… | |
| 22 | use common::sense; |
22 | use common::sense; |
| 23 | |
23 | |
| 24 | use Carp (); |
24 | use Carp (); |
| 25 | use List::Util (); |
25 | use List::Util (); |
| 26 | |
26 | |
| 27 | our $VERSION = '0.01'; |
27 | our $VERSION = '1.01'; |
| 28 | |
28 | |
| 29 | =item $level = new Games::Sokoban [format => "text|binpack"], [data => "###..."] |
29 | =item $level = new Games::Sokoban [format => "text|rle|binpack"], [data => "###..."] |
| 30 | |
30 | |
| 31 | =cut |
31 | =cut |
| 32 | |
32 | |
| 33 | sub new { |
33 | sub new { |
| 34 | my ($class, %arg) = @_; |
34 | my ($class, %arg) = @_; |
| … | |
… | |
| 58 | sub detect_format($) { |
58 | sub detect_format($) { |
| 59 | my ($data) = @_; |
59 | my ($data) = @_; |
| 60 | |
60 | |
| 61 | return "text" if $data =~ /^[ #\@\*\$\.\+\015\012\-_]+$/; |
61 | return "text" if $data =~ /^[ #\@\*\$\.\+\015\012\-_]+$/; |
| 62 | |
62 | |
| 63 | warn $data;#d# |
|
|
| 64 | return "rle" if $data =~ /^[ #\@\*\$\.\+\015\012\-_|1-9]+$/; |
63 | return "rle" if $data =~ /^[ #\@\*\$\.\+\015\012\-_|1-9]+$/; |
| 65 | exit 5;#d# |
|
|
| 66 | |
64 | |
| 67 | my ($a, $b) = unpack "ww", $data; |
65 | my ($a, $b) = unpack "ww", $data; |
| 68 | return "binpack" if defined $a && defined $b; |
66 | return "binpack" if defined $a && defined $b; |
| 69 | |
67 | |
| 70 | Carp::croak "unable to autodetect sokoban level format"; |
68 | Carp::croak "unable to autodetect sokoban level format"; |
| 71 | } |
69 | } |
| 72 | |
70 | |
| 73 | =item $level->data ([$new_data, [$new_data_format]]]) |
71 | =item $level->data ([$new_data, [$new_data_format]]) |
|
|
72 | |
|
|
73 | Sets the level from the given data. |
| 74 | |
74 | |
| 75 | =cut |
75 | =cut |
| 76 | |
76 | |
| 77 | sub data { |
77 | sub data { |
|
|
78 | if (@_ > 1) { |
| 78 | my ($self, $data, $format) = @_; |
79 | my ($self, $data, $format) = @_; |
| 79 | |
80 | |
| 80 | $format ||= detect_format $data; |
81 | $format ||= detect_format $data; |
| 81 | |
82 | |
| 82 | if ($format eq "text" or $format eq "rle") { |
83 | if ($format eq "text" or $format eq "rle") { |
| 83 | $data =~ y/-_|/ \n/; |
84 | $data =~ y/-_|/ \n/; |
| 84 | $data =~ s/(\d)(.)/$2 x $1/ge; |
85 | $data =~ s/(\d)(.)/$2 x $1/ge; |
| 85 | my @lines = split /[\015\012]+/, $data; |
86 | my @lines = split /[\015\012]+/, $data; |
| 86 | my $w = List::Util::max map length, @lines; |
87 | my $w = List::Util::max map length, @lines; |
| 87 | |
88 | |
| 88 | $_ .= " " x ($w - length) |
89 | $_ .= " " x ($w - length) |
| 89 | for @lines; |
90 | for @lines; |
| 90 | |
91 | |
| 91 | $self->{data} = join "\n", @lines; |
92 | $self->{data} = join "\n", @lines; |
| 92 | |
93 | |
| 93 | } elsif ($format eq "binpack") { |
94 | } elsif ($format eq "binpack") { |
| 94 | (my ($w, $s), $data) = unpack "wwB*", $data; |
95 | (my ($w, $s), $data) = unpack "wwB*", $data; |
| 95 | |
96 | |
| 96 | my @enc = ('#', '$', '.', ' ', ' ', '###', '*', '# '); |
97 | my @enc = ('#', '$', '.', ' ', ' ', '###', '*', '# '); |
| 97 | |
98 | |
| 98 | $data = join "", |
99 | $data = join "", |
| 99 | map $enc[$_], |
100 | map $enc[$_], |
| 100 | unpack "C*", |
101 | unpack "C*", |
| 101 | pack "(b*)*", |
102 | pack "(b*)*", |
| 102 | unpack "(a3)*", $data; |
103 | unpack "(a3)*", $data; |
| 103 | |
104 | |
| 104 | # clip extra chars (max. 2) |
105 | # clip extra chars (max. 2) |
| 105 | my $extra = (length $data) % $w; |
106 | my $extra = (length $data) % $w; |
| 106 | substr $data, -$extra, $extra, "" if $extra; |
107 | substr $data, -$extra, $extra, "" if $extra; |
| 107 | |
108 | |
| 108 | (substr $data, $s, 1) =~ y/ ./@+/; |
109 | (substr $data, $s, 1) =~ y/ ./@+/; |
| 109 | |
110 | |
| 110 | $self->{data} = |
111 | $self->{data} = |
| 111 | join "\n", |
112 | join "\n", |
| 112 | map "#$_#", |
113 | map "#$_#", |
| 113 | "#" x $w, |
114 | "#" x $w, |
| 114 | (unpack "(a$w)*", $data), |
115 | (unpack "(a$w)*", $data), |
| 115 | "#" x $w; |
116 | "#" x $w; |
| 116 | |
117 | |
| 117 | } else { |
118 | } else { |
| 118 | Carp::croak "$format: unsupported sokoban level format requested"; |
119 | Carp::croak "$format: unsupported sokoban level format requested"; |
| 119 | } |
120 | } |
| 120 | |
121 | |
|
|
122 | $self->{format} = $format; |
| 121 | $self->update; |
123 | $self->update; |
|
|
124 | } |
| 122 | |
125 | |
| 123 | ($self->{data}) |
126 | $_[0]{data} |
| 124 | } |
127 | } |
| 125 | |
128 | |
| 126 | sub pos2xy { |
129 | sub pos2xy { |
| 127 | use integer; |
130 | use integer; |
| 128 | |
131 | |
| … | |
… | |
| 149 | } |
152 | } |
| 150 | } |
153 | } |
| 151 | |
154 | |
| 152 | =item $text = $level->as_text |
155 | =item $text = $level->as_text |
| 153 | |
156 | |
|
|
157 | 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 | |
| 154 | =cut |
162 | =cut |
| 155 | |
163 | |
| 156 | sub as_text { |
164 | sub as_text { |
| 157 | my ($self) = @_; |
165 | my ($self) = @_; |
| 158 | |
166 | |
| 159 | "$self->{data}\n" |
167 | "$self->{data}\n" |
| 160 | } |
168 | } |
| 161 | |
169 | |
| 162 | =item $binary = $level->as_binpack |
170 | =item $binary = $level->as_binpack |
|
|
171 | |
|
|
172 | 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. |
| 163 | |
177 | |
| 164 | =cut |
178 | =cut |
| 165 | |
179 | |
| 166 | sub as_binpack { |
180 | sub as_binpack { |
| 167 | my ($self) = @_; |
181 | my ($self) = @_; |
| … | |
… | |
| 199 | pack "wwB*", $w - 2, $s, $data |
213 | pack "wwB*", $w - 2, $s, $data |
| 200 | } |
214 | } |
| 201 | |
215 | |
| 202 | =item @lines = $level->as_lines |
216 | =item @lines = $level->as_lines |
| 203 | |
217 | |
|
|
218 | 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 | |
| 204 | =cut |
223 | =cut |
| 205 | |
224 | |
| 206 | sub as_lines { |
225 | sub as_lines { |
| 207 | split /\n/, $_[0]{data} |
226 | split /\n/, $_[0]{data} |
| 208 | } |
227 | } |
| 209 | |
228 | |
| 210 | =item @lines = $level->as_rle |
229 | =item $line = $level->as_rle |
| 211 | |
230 | |
| 212 | http://www.sokobano.de/wiki/index.php?title=Level_format |
231 | http://www.sokobano.de/wiki/index.php?title=Level_format |
|
|
232 | |
|
|
233 | Example: |
|
|
234 | |
|
|
235 | "3#|# #|3#" |
| 213 | |
236 | |
| 214 | =cut |
237 | =cut |
| 215 | |
238 | |
| 216 | sub as_rle { |
239 | sub as_rle { |
| 217 | my $data = $_[0]{data}; |
240 | my $data = $_[0]{data}; |
| … | |
… | |
| 223 | $data |
246 | $data |
| 224 | } |
247 | } |
| 225 | |
248 | |
| 226 | =item ($x, $y) = $level->start |
249 | =item ($x, $y) = $level->start |
| 227 | |
250 | |
|
|
251 | Returns (0-based) starting coordinate. |
|
|
252 | |
| 228 | =cut |
253 | =cut |
| 229 | |
254 | |
| 230 | sub start { |
255 | sub start { |
| 231 | my ($self) = @_; |
256 | my ($self) = @_; |
| 232 | |
257 | |
| … | |
… | |
| 234 | $self->pos2xy ($-[0]); |
259 | $self->pos2xy ($-[0]); |
| 235 | } |
260 | } |
| 236 | |
261 | |
| 237 | =item $level->hflip |
262 | =item $level->hflip |
| 238 | |
263 | |
|
|
264 | Mirror horizontally. |
|
|
265 | |
| 239 | =item $level->vflip |
266 | =item $level->vflip |
| 240 | |
267 | |
| 241 | =item $level->transpose # topleft to bottomright |
268 | Mirror vertically. |
|
|
269 | |
|
|
270 | =item $level->transpose |
|
|
271 | |
|
|
272 | Transpose level (mirror at top-left/bottom-right diagonal). |
| 242 | |
273 | |
| 243 | =item $level->rotate_90 |
274 | =item $level->rotate_90 |
| 244 | |
275 | |
|
|
276 | Rotate by 90 degrees clockwise. |
|
|
277 | |
| 245 | =item $level->rotate_180 |
278 | =item $level->rotate_180 |
|
|
279 | |
|
|
280 | Rotate by 180 degrees clockwise. |
| 246 | |
281 | |
| 247 | =cut |
282 | =cut |
| 248 | |
283 | |
| 249 | sub hflip { |
284 | sub hflip { |
| 250 | $_[0]{data} = join "\n", map { scalar reverse $_ } split /\n/, $_[0]{data}; |
285 | $_[0]{data} = join "\n", map { scalar reverse $_ } split /\n/, $_[0]{data}; |
| … | |
… | |
| 338 | # phew, done |
373 | # phew, done |
| 339 | } |
374 | } |
| 340 | |
375 | |
| 341 | =item $id = $level->normalise |
376 | =item $id = $level->normalise |
| 342 | |
377 | |
| 343 | normalises the level map and calculates/returns it's identity code |
378 | Simplifies the level map and calculates/returns its identity code. |
| 344 | |
379 | . |
| 345 | http://www.sourcecode.se/sokoban/level_id.php, assume uppercase and hex. |
380 | http://www.sourcecode.se/sokoban/level_id.php, assume uppercase and hex. |
| 346 | |
381 | |
| 347 | =cut |
382 | =cut |
| 348 | |
383 | |
| 349 | sub normalise { |
384 | sub normalise { |
| … | |
… | |
| 383 | Games::Sokoban objects in an arrayref. |
418 | Games::Sokoban objects in an arrayref. |
| 384 | |
419 | |
| 385 | =cut |
420 | =cut |
| 386 | |
421 | |
| 387 | sub load_sokevo($) { |
422 | sub load_sokevo($) { |
| 388 | open my $fh, "<", $_[0] |
423 | open my $fh, "<:crlf", $_[0] |
| 389 | or Carp::croak "$_[0]: $!"; |
424 | or Carp::croak "$_[0]: $!"; |
| 390 | |
425 | |
| 391 | my @levels; |
426 | my @levels; |
| 392 | |
427 | |
|
|
428 | # skip file header |
|
|
429 | local $/ = "\n\n"; |
|
|
430 | scalar <$fh>; |
|
|
431 | |
| 393 | while (<$fh>) { |
432 | while (<$fh>) { |
| 394 | if (/^##+$/) { |
433 | chomp; |
| 395 | my $data = $_; |
434 | my %meta = split /(?:: |\n)/; |
| 396 | while (<$fh>) { |
|
|
| 397 | $data .= $_; |
|
|
| 398 | last if /^$/; |
|
|
| 399 | } |
|
|
| 400 | |
435 | |
|
|
436 | $_ = <$fh>; |
|
|
437 | |
|
|
438 | /^##+\n/ or last; |
|
|
439 | |
|
|
440 | # sokevo internally locks some cells |
|
|
441 | y/^%:,;-=?/ #.$* +#/; |
|
|
442 | |
|
|
443 | # skip levels without pusher |
|
|
444 | y/@+// or next; |
|
|
445 | |
| 401 | push @levels, new Games::Sokoban data => $data; |
446 | push @levels, new Games::Sokoban data => $_, meta => \%meta; |
| 402 | } |
|
|
| 403 | } |
447 | } |
| 404 | |
448 | |
| 405 | \@levels |
449 | \@levels |
| 406 | } |
450 | } |
| 407 | |
451 | |
