lib/Language/Befunge/Storage/2D/Sparse.pm

   1 #
   2 # This file is part of Language::Befunge.
   3 # Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8 #
   9
  10 package Language::Befunge::Storage::2D::Sparse;
  11
  12 use strict;
  13 use warnings;
  14
  15 use Carp;
  16 use aliased 'Language::Befunge::Vector' => 'LBV';
  17 use Readonly;
  18
  19 use base qw{ Language::Befunge::Storage };
  20
  21 use Class::XSAccessor
  22     accessors => {
  23         _storage => '_storage',
  24         _xmin    => '_xmin',
  25         _xmax    => '_xmax',
  26         _ymin    => '_ymin',
  27         _ymax    => '_ymax',
  28     };
  29
  30 Readonly my $SPACE => ' ';
  31
  32
  33 # -- CONSTRUCTOR
  34
  35 #
  36 # my $storage = LBS::2D::Sparse->new;
  37 #
  38 # Create a new storage.
  39 #
  40 sub new {
  41     my ($class, $dims) = @_;
  42     $dims //= 2;
  43     croak("$class is only useful for 2-dimensional storage.")
  44         unless $dims == 2;
  45     my $self    = {};
  46     bless $self, $class;
  47     $self->clear;
  48     return $self;
  49 }
  50
  51
  52
  53 # -- PUBLIC METHODS
  54
  55 #- storage update
  56
  57 #
  58 # $storage->clear;
  59 #
  60 # Clear the storage.
  61 #
  62 sub clear {
  63     my ($self) = @_;
  64     $self->_xmin(0);
  65     $self->_xmax(0);
  66     $self->_ymin(0);
  67     $self->_ymax(0);
  68     $self->_storage( {} );
  69 }
  70
  71
  72 #
  73 # my $size = $storage->store_binary( $code [, $position] );
  74 #
  75 # Store the given $code at the specified $position (defaulting to the
  76 # origin coordinates).
  77 #
  78 # Return the size of the code inserted, as a vector.
  79 #
  80 # The code is a string, representing a block of Funge code. This is
  81 # binary insertion, that is, EOL sequences are stored in Funge-space
  82 # instead of causing the dimension counters to be resetted and
  83 # incremented.
  84 #
  85 sub store_binary {
  86     my ($self, $code, $position) = @_;
  87
  88     my $offset = $position;
  89     $offset    = LBV->new(0,0) unless defined $offset;
  90     my $x      = $offset->get_component(0);
  91     my $y      = $offset->get_component(1);
  92     my $href   = $self->_storage;
  93
  94     # enlarge min values if needed
  95     $self->_xmin($x) if $self->_xmin > $x;
  96     $self->_ymin($y) if $self->_ymin > $y;
  97
  98     # store data
  99     foreach my $chr ( split //, $code ) {
 100         $href->{"$x,$y"} = ord $chr
 101             unless $chr eq $SPACE; # spaces do not overwrite - cf befunge specs
 102         $x++;
 103     }
 104
 105     # enlarge max values if needed
 106     $x--; # one step too far
 107     $self->_xmax($x) if $self->_xmax < $x;
 108     $self->_ymax($y) if $self->_ymax < $y;
 109
 110     return LBV->new(length $code, 1);
 111 }
 112
 113
 114 #
 115 # my $size = $storage->store( $code [, $position] );
 116 #
 117 # Store the given $code at the specified $position (defaulting to the
 118 # origin coordinates).
 119 #
 120 # Return the size of the code inserted, as a vector.
 121 #
 122 # The code is a string, representing a block of Funge code. Rows are
 123 # separated by newlines.
 124 #
 125 sub store {
 126     my ($self, $code, $position) = @_;
 127
 128     my $offset = $position;
 129     $offset    = LBV->new(0,0) unless defined $offset;
 130     my $dy     = LBV->new(0,1);
 131
 132     # support for any eol convention
 133     $code =~ s/\r\n/\n/g;
 134     $code =~ s/\r/\n/g;
 135     my @lines = split /\n/, $code;
 136
 137     # store data
 138     my $maxlen = 0;
 139     foreach my $line ( @lines ) {
 140         $maxlen = length($line) if $maxlen < length($line);
 141         $self->store_binary( $line, $offset );
 142         $offset += $dy;
 143     }
 144
 145     return LBV->new($maxlen, scalar(@lines));
 146 }
 147
 148
 149 # $storage->set_value( $offset, $value );
 150 #
 151 # Write the supplied $value in the storage at the specified $offset.
 152 #
 153 # /!\ As in Befunge, code and data share the same playfield, the
 154 # number stored can be either an instruction or raw data (or even
 155 # both... Eh, that's Befunge! :o) ).
 156 #
 157 sub set_value {
 158     my ($self, $v, $val) = @_;
 159     my ($x, $y) = $v->get_all_components();
 160
 161     # ensure we can set the value.
 162     $self->_xmin($x) if $self->_xmin > $x;
 163     $self->_xmax($x) if $self->_xmax < $x;
 164     $self->_ymin($y) if $self->_ymin > $y;
 165     $self->_ymax($y) if $self->_ymax < $y;
 166     $self->_storage->{"$x,$y"} = $val;
 167 }
 168
 169
 170
 171 #- data retrieval
 172
 173 #
 174 # my $dims = $storage->get_dims;
 175 #
 176 # Return the dimensionality of the storage.  For this module, the value is
 177 # always 2.
 178 #
 179 sub get_dims { 2 }
 180
 181
 182 #
 183 # my $vmin = $storage->min;
 184 #
 185 # Return a LBV pointing to the lower bounds of the storage.
 186 #
 187 sub min {
 188     my ($self) = @_;
 189     return LBV->new($self->_xmin, $self->_ymin);
 190 }
 191
 192
 193 #
 194 # my $vmax = $storage->max;
 195 #
 196 # Return a LBV pointing to the upper bounds of the storage.
 197 #
 198 sub max {
 199     my ($self) = @_;
 200     return LBV->new($self->_xmax, $self->_ymax);
 201 }
 202
 203
 204 #
 205 # my $val = $storage->get_value( $offset );
 206 #
 207 # Return the number stored in the torus at the specified $offset. If
 208 # the value hasn't yet been set, it defaults to the ordinal value of a
 209 # space (ie, #32).
 210 #
 211 # /!\ As in Befunge, code and data share the same playfield, the
 212 # number returned can be either an instruction or raw data (or even
 213 # both... Eh, that's Befunge! :o) ).
 214 #
 215 sub get_value {
 216     my ($self, $v) = @_;
 217     my ($x, $y) = $v->get_all_components;
 218     my $href    = $self->_storage;
 219     return exists $href->{"$x,$y"}
 220         ? $href->{"$x,$y"}
 221         : 32;
 222 }
 223
 224
 225 #
 226 # my $chr = $storage->get_char( $offset );
 227 #
 228 # Return the character stored in the torus at the specified $offset. If
 229 # the value is not between 0 and 255 (inclusive), get_char will return a
 230 # string that looks like "<np-0x4500>".
 231 #
 232 # /!\ As in Befunge, code and data share the same playfield, the
 233 # character returned can be either an instruction or raw data. No
 234 # guarantee is made that the return value is printable.
 235 #
 236 sub get_char {
 237     my ($self, $v) = @_;
 238     return chr $self->get_value($v);
 239 }
 240
 241
 242 #
 243 # my $str = $storage->rectangle( $pos, $size );
 244 #
 245 # Return a string containing the data/code in the rectangle defined by
 246 # the supplied vectors.
 247 #
 248 sub rectangle {
 249     my ($self, $start, $size) = @_;
 250     my ($x, $y) = $start->get_all_components();
 251     my ($w, $h) =  $size->get_all_components();
 252
 253     # retrieve data
 254     my @lines = ();
 255     foreach my $j ( $y .. $y+$h-1 ) {
 256         my $line = join '', map { $self->get_char( LBV->new($_,$j) ) } $x .. $x+$w-1;
 257         push @lines, $line;
 258     }
 259
 260     return join "\n", @lines;
 261 }
 262
 263
 264 #- misc methods
 265
 266 #
 267 # my $href = $storage->labels_lookup;
 268 #
 269 # Parse the storage to find sequences such as ";:(\w[^\s;])[^;]*;"
 270 # and return a hash reference whose keys are the labels and the values
 271 # an anonymous array with four values: a vector describing the absolute
 272 # position of the character just after the trailing ";", and a
 273 # vector describing the velocity that leads to this label.
 274 #
 275 # This method will only look in the four cardinal directions, and does
 276 # wrap basically like befunge93 (however, this should not be a problem
 277 # since we're only using cardinal directions)
 278 #
 279 # This allow to define some labels in the source code, to be used by
 280 # Inline::Befunge (and maybe some exstensions).
 281 #
 282 sub labels_lookup {
 283     my ($self) = @_;
 284     my $labels = {}; # result
 285
 286     # lexicalled to improve speed
 287     my $xmin = $self->_xmin;
 288     my $xmax = $self->_xmax;
 289     my $ymin = $self->_ymin;
 290     my $ymax = $self->_ymax;
 291
 292     Y: foreach my $y ( $ymin .. $ymax ) {
 293         X: foreach my $x ( $xmin .. $xmax ) {
 294             next X unless $self->get_value(LBV->new($x,$y)) eq ord(';');
 295             # found a semicolon, let's try...
 296             VEC: foreach my $vec ( [1,0], [-1,0], [0,1], [0,-1] ) {
 297                 my ($label, $labx, $laby) = $self->_labels_try( $x, $y, @$vec );
 298                 defined($label) or next VEC;
 299
 300                 # how exciting, we found a label!
 301                 exists $labels->{$label}
 302                     and croak "Help! I found two labels '$label' in the funge space";
 303                 $labels->{$label} = [
 304                     Language::Befunge::Vector->new($labx, $laby),
 305                     Language::Befunge::Vector->new(@$vec)
 306                 ];
 307             }
 308         }
 309     }
 310
 311     return $labels;
 312 }
 313
 314
 315 # -- PRIVATE METHODS
 316
 317 #
 318 # $storage->_labels_try( $x, $y, $dx, $dy )
 319 #
 320 # Try in the specified direction if the funge space matches a label
 321 # definition. Return undef if it wasn't a label definition, or the name
 322 # of the label if it was a valid label.
 323 #
 324 sub _labels_try {
 325     my ($self, $x, $y, $dx, $dy) = @_;
 326     my $comment = '';
 327
 328     my $xmin = $self->_xmin;
 329     my $xmax = $self->_xmax;
 330     my $ymin = $self->_ymin;
 331     my $ymax = $self->_ymax;
 332
 333     # fetch the whole comment stuff.
 334     do {
 335         # calculate the next cell coordinates.
 336         $x += $dx; $y += $dy;
 337         $x = $xmin if $xmax < $x;
 338         $x = $xmax if $xmin > $x;
 339         $y = $ymin if $ymax < $y;
 340         $y = $ymax if $ymin > $y;
 341         my $vec = LBV->new($x,$y);
 342         $comment .= $self->get_char($vec);
 343     } while ( $comment !~ /;.$/ );
 344
 345     # check if the comment matches the pattern.
 346     $comment =~ /^:(\w[^\s;]*)[^;]*;.$/;
 347     return ($1, $x, $y);
 348 }
 349
 350 1;
 351 __END__
 352
 353 =head1 NAME
 354
 355 LBS::2D::Sparse - a 2D storage, using sparse hash
 356
 357
 358 =head1 SYNOPSIS
 359
 360     my $storage = Language::Befunge::Storage::2D::Sparse->new;
 361     $storage->clear;
 362     $storage->store(<<EOF);
 363     12345
 364     67890
 365     EOF
 366
 367
 368 =head1 DESCRIPTION
 369
 370 This class implements a storage as defined in LBS. It makes the
 371 assumption that we're in a 2D Funge space for efficiency reasons.
 372 Therefore, it's only suited for befunge programs.
 373
 374 This storage is sparse, using a private hash with keys such as "$x,$y".
 375 Any value of a non-existing key defaults to 32 (space), as defined by
 376 funge specs.
 377
 378
 379
 380 =head1 PUBLIC METHODS
 381
 382
 383 =head2 Constructor
 384
 385
 386 =over 4
 387
 388 =item my $storage = LBS::2D::Sparse->new;
 389
 390 Create a new LBS object.
 391
 392
 393 =back
 394
 395
 396
 397 =head2 Storage update
 398
 399
 400 =over 4
 401
 402
 403 =item $storage->clear;
 404
 405 Clear the storage.
 406
 407
 408 =item my $size = $storage->store_binary( $code [, $position] );
 409
 410 Store the given C<$code> at the specified C<$position> (defaulting to
 411 the origin coordinates).
 412
 413 Return the size of the code inserted, as a vector.
 414
 415 The code is a string, representing a block of Funge code. This is binary
 416 insertion, that is, EOL sequences are stored in Funge-space instead of
 417 causing the dimension counters to be resetted and incremented.
 418
 419
 420 =item my $size = $storage->store( $code [, $position] );
 421
 422 Store the given $code at the specified $position (defaulting to the
 423 origin coordinates).
 424
 425 Return the size of the code inserted, as a vector.
 426
 427 The code is a string, representing a block of Funge code. Rows are
 428 separated by newlines.
 429
 430
 431 =item $storage->set_value( $offset, $value );
 432
 433 Write the supplied C<$value> in the storage at the specified C<$offset>.
 434
 435 B</!\> As in Befunge, code and data share the same playfield, the number
 436 stored can be either an instruction B<or> raw data (or even both... Eh,
 437 that's Befunge! :o) ).
 438
 439
 440 =back
 441
 442
 443
 444 =head2 Data retrieval
 445
 446
 447 =over 4
 448
 449
 450 =item my $dims = $storage->get_dims;
 451
 452 Return the dimensionality of the storage.  For this module, the value is
 453 always 2.
 454
 455
 456 =item my $vmin = $storage->min;
 457
 458 Return a LBV pointing to the lower bounds of the storage.
 459
 460
 461 =item my $vmax = $storage->max;
 462
 463 Return a LBV pointing to the upper bounds of the storage.
 464
 465
 466 =item my $val = $storage->get_value( $offset );
 467
 468 Return the number stored in the torus at the specified C<$offset>. If
 469 the value hasn't yet been set, it defaults to the ordinal value of a
 470 space (ie, #32).
 471
 472 B</!\> As in Befunge, code and data share the same playfield, the number
 473 returned can be either an instruction B<or> raw data (or even both... Eh,
 474 that's Befunge! :o) ).
 475
 476
 477 =item my $chr = $storage->get_char( $offset )
 478
 479 Return the character stored in the torus at the specified C<$offset>. If
 480 the value is not between 0 and 255 (inclusive), get_char will return a
 481 string that looks like C<< <np-0x4500> >>.
 482
 483 B</!\> As in Befunge, code and data share the same playfield, the
 484 character returned can be either an instruction B<or> raw data. No
 485 guarantee is made that the return value is printable.
 486
 487
 488 =item my $str = $storage->rectangle( $pos, $size );
 489
 490 Return a string containing the data/code in the rectangle defined by
 491 the supplied vectors.
 492
 493
 494 =back
 495
 496
 497 =head2 Miscellaneous methods
 498
 499
 500 =over 4
 501
 502
 503 =item my $href = $storage->labels_lookup;
 504
 505 Parse the storage to find sequences such as C<;:(\w[^\s;])[^;]*;>
 506 and return a hash reference whose keys are the labels and the values
 507 an anonymous array with four values: a vector describing the absolute
 508 position of the character just after the trailing C<;>, and a
 509 vector describing the velocity that leads to this label.
 510
 511 This method will only look in the four cardinal directions, and does
 512 wrap basically like befunge93 (however, this should not be a problem
 513 since we're only using cardinal directions)
 514
 515 This allow to define some labels in the source code, to be used by
 516 C<Inline::Befunge> (and maybe some exstensions).
 517
 518
 519 =begin pod_coverage
 520
 521 =item LBV - alias for Language::Befunge::Vector
 522
 523 =end pod_coverage
 524
 525 =back
 526
 527
 528
 529 =head1 SEE ALSO
 530
 531 L<Language::Befunge>.
 532
 533
 534 =head1 AUTHOR
 535
 536 Jerome Quelin, C<< <jquelin@cpan.org> >>
 537
 538
 539 =head1 COPYRIGHT & LICENSE
 540
 541 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
 542
 543 This program is free software; you can redistribute it and/or modify
 544 it under the same terms as Perl itself.
 545
 546
 547 =cut