view release on metacpan or  search on metacpan

Sokoban.pm  view on Meta::CPAN

      $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

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