… | |
… | |
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 | |
… | |
… | |
158 | |
161 | |
159 | "$self->{data}\n" |
162 | "$self->{data}\n" |
160 | } |
163 | } |
161 | |
164 | |
162 | =item $binary = $level->as_binpack |
165 | =item $binary = $level->as_binpack |
|
|
166 | |
|
|
167 | 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. |
163 | |
172 | |
164 | =cut |
173 | =cut |
165 | |
174 | |
166 | sub as_binpack { |
175 | sub as_binpack { |
167 | my ($self) = @_; |
176 | my ($self) = @_; |
… | |
… | |
205 | |
214 | |
206 | sub as_lines { |
215 | sub as_lines { |
207 | split /\n/, $_[0]{data} |
216 | split /\n/, $_[0]{data} |
208 | } |
217 | } |
209 | |
218 | |
210 | =item @lines = $level->as_rle |
219 | =item $line = $level->as_rle |
211 | |
220 | |
212 | http://www.sokobano.de/wiki/index.php?title=Level_format |
221 | http://www.sokobano.de/wiki/index.php?title=Level_format |
213 | |
222 | |
214 | =cut |
223 | =cut |
215 | |
224 | |
… | |
… | |
222 | |
231 | |
223 | $data |
232 | $data |
224 | } |
233 | } |
225 | |
234 | |
226 | =item ($x, $y) = $level->start |
235 | =item ($x, $y) = $level->start |
|
|
236 | |
|
|
237 | Returns (0-based) starting coordinate. |
227 | |
238 | |
228 | =cut |
239 | =cut |
229 | |
240 | |
230 | sub start { |
241 | sub start { |
231 | my ($self) = @_; |
242 | my ($self) = @_; |
… | |
… | |
383 | Games::Sokoban objects in an arrayref. |
394 | Games::Sokoban objects in an arrayref. |
384 | |
395 | |
385 | =cut |
396 | =cut |
386 | |
397 | |
387 | sub load_sokevo($) { |
398 | sub load_sokevo($) { |
388 | open my $fh, "<", $_[0] |
399 | open my $fh, "<:crlf", $_[0] |
389 | or Carp::croak "$_[0]: $!"; |
400 | or Carp::croak "$_[0]: $!"; |
390 | |
401 | |
391 | my @levels; |
402 | my @levels; |
392 | |
403 | |
|
|
404 | # skip file header |
|
|
405 | local $/ = "\n\n"; |
|
|
406 | scalar <$fh>; |
|
|
407 | |
393 | while (<$fh>) { |
408 | while (<$fh>) { |
394 | if (/^##+$/) { |
409 | chomp; |
395 | my $data = $_; |
410 | my %meta = split /[:\n]/; |
396 | while (<$fh>) { |
|
|
397 | $data .= $_; |
|
|
398 | last if /^$/; |
|
|
399 | } |
|
|
400 | |
411 | |
|
|
412 | $_ = <$fh>; |
|
|
413 | |
|
|
414 | /^##+\n/ or last; |
|
|
415 | |
|
|
416 | # sokevo internally locks some cells |
|
|
417 | y/^%:,;-=?/ #.$* +#/; |
|
|
418 | |
401 | push @levels, new Games::Sokoban data => $data; |
419 | push @levels, new Games::Sokoban data => $_, meta => \%meta; |
402 | } |
|
|
403 | } |
420 | } |
404 | |
421 | |
405 | \@levels |
422 | \@levels |
406 | } |
423 | } |
407 | |
424 | |