lib/Language/Befunge/IP.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::IP;
  11 require 5.010;
  12
  13 use strict;
  14 use warnings;
  15 use integer;
  16
  17 use Carp;
  18 use Language::Befunge::Vector;
  19 use Storable qw(dclone);
  20
  21
  22
  23 # -- CONSTRUCTORS
  24
  25 sub new {
  26     my ($class, $dims) = @_;
  27     $dims = 2 unless defined $dims;
  28     my $self  =
  29       { id           => 0,
  30         dims         => $dims,
  31         toss         => [],
  32         ss           => [],
  33         position     => Language::Befunge::Vector->new_zeroes($dims),
  34         delta        => Language::Befunge::Vector->new_zeroes($dims),
  35         storage      => Language::Befunge::Vector->new_zeroes($dims),
  36         string_mode  => 0,
  37         end          => 0,
  38         data         => {},
  39         libs         => { map { $_=>[] } 'A'..'Z' },
  40       };
  41     # go right by default
  42     $self->{delta}->set_component(0, 1);
  43     bless $self, $class;
  44     $self->set_id( $self->_get_new_id );
  45     return $self;
  46 }
  47
  48 sub clone {
  49     my $self = shift;
  50     my $clone = dclone( $self );
  51     $clone->set_id( $self->_get_new_id );
  52     return $clone;
  53 }
  54
  55
  56 # -- ACCESSORS
  57
  58 BEGIN {
  59     my @setters = qw{ position data delta end id libs ss storage string_mode toss };
  60     my @getters = ( qw{ dims }, @setters );
  61     require Class::XSAccessor;
  62     Class::XSAccessor->import(
  63         getters   => { map { ( "get_$_" => $_ ) } @getters },
  64         setters   => { map { ( "set_$_" => $_ ) } @setters },
  65     );
  66 }
  67
  68
  69
  70 sub soss {
  71     my $self = shift;
  72     # Remember, the Stack Stack is up->bottom.
  73     @_ and $self->get_ss->[0] = shift;
  74     return $self->get_ss->[0];
  75 }
  76
  77
  78 sub scount {
  79     my $self = shift;
  80     return scalar @{ $self->get_toss };
  81 }
  82
  83 sub spush {
  84     my $self = shift;
  85     push @{ $self->get_toss }, @_;
  86 }
  87
  88 sub spush_vec {
  89     my ($self) = shift;
  90     foreach my $v (@_) {
  91         $self->spush($v->get_all_components);
  92     }
  93 }
  94
  95 sub spush_args {
  96     my $self = shift;
  97     foreach my $arg ( @_ ) {
  98         $self->spush
  99           ( ($arg =~ /^-?\d+$/) ?
 100               $arg                                    # A number.
 101             : reverse map {ord} split //, $arg.chr(0) # A string.
 102           );
 103     }
 104 }
 105
 106 sub spop {
 107     my $self = shift;
 108     my $val = pop @{ $self->get_toss };
 109     defined $val or $val = 0;
 110     return $val;
 111 }
 112
 113 sub spop_mult {
 114     my ($self, $count) = @_;
 115     my @rv = reverse map { $self->spop() } (1..$count);
 116     return @rv;
 117 }
 118
 119 sub spop_vec {
 120     my $self = shift;
 121     return Language::Befunge::Vector->new($self->spop_mult($self->get_dims));
 122 }
 123
 124 sub spop_gnirts {
 125     my $self = shift;
 126     my ($val, $str);
 127     do {
 128         $val = pop @{ $self->get_toss };
 129         defined $val or $val = 0;
 130         $str .= chr($val);
 131     } while( $val != 0 );
 132     chop $str; # Remove trailing \0.
 133     return $str;
 134 }
 135
 136 sub sclear {
 137     my $self = shift;
 138     $self->set_toss( [] );
 139 }
 140
 141 sub svalue {
 142     my ($self, $idx) = @_;
 143
 144     $idx = - abs( $idx );
 145     return 0 unless exists $self->get_toss->[$idx];
 146     return $self->get_toss->[$idx];
 147 }
 148
 149 sub ss_count {
 150     my $self = shift;
 151     return scalar( @{ $self->get_ss } );
 152 }
 153
 154 sub ss_create {
 155     my ( $self, $n ) = @_;
 156
 157     my @new_toss;
 158
 159     if ( $n < 0 ) {
 160         # Push zeroes on *current* toss (to-be soss).
 161         $self->spush( (0) x abs($n) );
 162     } elsif ( $n > 0 ) {
 163         my $c = $n - $self->scount;
 164         if ( $c <= 0 ) {
 165             # Transfer elements.
 166             @new_toss = splice @{ $self->get_toss }, -$n;
 167         } else {
 168             # Transfer elems and fill with zeroes.
 169             @new_toss = ( (0) x $c, @{ $self->get_toss } );
 170             $self->sclear;
 171         }
 172     }
 173     # $n == 0: do nothing
 174
 175
 176     # Push the former TOSS on the stack stack and copy reference to
 177     # the new TOSS.
 178     # For commodity reasons, the Stack Stack is oriented up->bottom
 179     # (that is, a push is an unshift, and a pop is a shift).
 180     unshift @{ $self->get_ss }, $self->get_toss;
 181     $self->set_toss( \@new_toss );
 182 }
 183
 184 sub ss_remove {
 185     my ( $self, $n ) = @_;
 186
 187     # Fetch the TOSS.
 188     # Remember, the Stack Stack is up->bottom.
 189     my $new_toss = shift @{ $self->get_ss };
 190
 191     if ( $n < 0 ) {
 192         # Remove values.
 193         if ( scalar(@$new_toss) >= abs($n) ) {
 194             splice @$new_toss, $n;
 195         } else {
 196             $new_toss = [];
 197         }
 198     } elsif ( $n > 0 ) {
 199         my $c = $n - $self->scount;
 200         if ( $c <= 0 ) {
 201             # Transfer elements.
 202             push @$new_toss, splice( @{ $self->get_toss }, -$n );
 203         } else {
 204             # Transfer elems and fill with zeroes.
 205             push @$new_toss, ( (0) x $c, @{ $self->get_toss } );
 206         }
 207     }
 208     # $n == 0: do nothing
 209
 210
 211     # Store the new TOSS.
 212     $self->set_toss( $new_toss );
 213 }
 214
 215 sub ss_transfer {
 216     my ($self, $n) = @_;
 217     $n == 0 and return;
 218
 219     if ( $n > 0 ) {
 220         # Transfer from SOSS to TOSS.
 221         my $c = $n - $self->soss_count;
 222         my @elems;
 223         if ( $c <= 0 ) {
 224             @elems = splice @{ $self->soss }, -$n;
 225         } else {
 226             @elems = ( (0) x $c, @{ $self->soss } );
 227             $self->soss_clear;
 228         }
 229         $self->spush( reverse @elems );
 230
 231     } else {
 232         $n = -$n;
 233         # Transfer from TOSS to SOSS.
 234         my $c = $n - $self->scount;
 235         my @elems;
 236         if ( $c <= 0 ) {
 237             @elems = splice @{ $self->get_toss }, -$n;
 238         } else {
 239             @elems = ( (0) x $c, @{ $self->get_toss } );
 240             $self->sclear;
 241         }
 242         $self->soss_push( reverse @elems );
 243
 244     }
 245 }
 246
 247 sub ss_sizes {
 248     my $self = shift;
 249
 250     my @sizes = ( $self->scount );
 251
 252     # Store the size of each stack.
 253     foreach my $i ( 1..$self->ss_count ) {
 254         push @sizes, scalar @{ $self->get_ss->[$i-1] };
 255     }
 256
 257     return @sizes;
 258 }
 259
 260
 261 sub soss_count {
 262     my $self = shift;
 263     return scalar( @{ $self->soss } );
 264 }
 265
 266 sub soss_push {
 267     my $self = shift;
 268     push @{ $self->soss }, @_;
 269 }
 270
 271
 272 sub soss_pop_mult {
 273     my ($self, $count) = @_;
 274     my @rv = reverse map { $self->soss_pop() } (1..$count);
 275     return @rv;
 276 }
 277
 278 sub soss_push_vec {
 279     my $self = shift;
 280     foreach my $v (@_) {
 281         $self->soss_push($v->get_all_components);
 282     }
 283 }
 284
 285 sub soss_pop {
 286     my $self = shift;
 287     my $val = pop @{ $self->soss };
 288     defined $val or $val = 0;
 289     return $val;
 290 }
 291
 292 sub soss_pop_vec {
 293     my $self = shift;
 294     return Language::Befunge::Vector->new($self->soss_pop_mult($self->get_dims));
 295 }
 296
 297 sub soss_clear {
 298     my $self = shift;
 299     $self->soss( [] );
 300 }
 301
 302
 303
 304 sub dir_go_east {
 305     my $self = shift;
 306     $self->get_delta->clear;
 307     $self->get_delta->set_component(0, 1);
 308 }
 309
 310 sub dir_go_west {
 311     my $self = shift;
 312     $self->get_delta->clear;
 313     $self->get_delta->set_component(0, -1);
 314 }
 315
 316 sub dir_go_north {
 317     my $self = shift;
 318     $self->get_delta->clear;
 319     $self->get_delta->set_component(1, -1);
 320 }
 321
 322 sub dir_go_south {
 323     my $self = shift;
 324     $self->get_delta->clear;
 325     $self->get_delta->set_component(1, 1);
 326 }
 327
 328 sub dir_go_high {
 329     my $self = shift;
 330     $self->get_delta->clear;
 331     $self->get_delta->set_component(2, 1);
 332 }
 333
 334 sub dir_go_low {
 335     my $self = shift;
 336     $self->get_delta->clear;
 337     $self->get_delta->set_component(2, -1);
 338 }
 339
 340 sub dir_go_away {
 341     my $self = shift;
 342     my $nd = $self->get_dims;
 343     my $dim = (0..$nd-1)[int(rand $nd)];
 344     $self->get_delta->clear;
 345     my $value = (-1, 1)[int(rand 2)];
 346     $self->get_delta->set_component($dim, $value);
 347 }
 348
 349 sub dir_turn_left {
 350     my $self = shift;
 351     my $old_dx = $self->get_delta->get_component(0);
 352     my $old_dy = $self->get_delta->get_component(1);
 353     $self->get_delta->set_component(0, 0 + $old_dy);
 354     $self->get_delta->set_component(1, 0 + $old_dx * -1);
 355 }
 356
 357 sub dir_turn_right {
 358     my $self = shift;
 359     my $old_dx = $self->get_delta->get_component(0);
 360     my $old_dy = $self->get_delta->get_component(1);
 361     $self->get_delta->set_component(0, 0 + $old_dy * -1);
 362     $self->get_delta->set_component(1, 0 + $old_dx);
 363 }
 364
 365 sub dir_reverse {
 366     my $self = shift;
 367     $self->set_delta(-$self->get_delta);
 368 }
 369
 370 sub load {
 371     my ($self, $lib) = @_;
 372
 373     my $libs = $self->get_libs;
 374     foreach my $letter ( 'A' .. 'Z' ) {
 375         next unless $lib->can($letter);
 376         push @{ $libs->{$letter} }, $lib;
 377     }
 378 }
 379
 380 sub unload {
 381     my ($self, $lib) = @_;
 382
 383     my $libs = $self->get_libs;
 384     foreach my $letter ( 'A' .. 'Z' ) {
 385         next unless $lib->can($letter);
 386         pop @{ $libs->{$letter} };
 387     }
 388 }
 389
 390 sub extdata {
 391     my $self = shift;
 392     my $lib  = shift;
 393     @_ ? $self->get_data->{$lib} = shift : $self->get_data->{$lib};
 394 }
 395
 396
 397 # -- PRIVATE METHODS
 398
 399 #
 400 # my $id = _get_new_id;
 401 #
 402 # Forge a new IP id, that will distinct it from the other IPs of the program.
 403 #
 404 my $id = 0;
 405 sub _get_new_id {
 406     return $id++;
 407 }
 408
 409 1;
 410 __END__
 411
 412 =head1 NAME
 413
 414 Language::Befunge::IP - an Instruction Pointer for a Befunge-98 program.
 415
 416
 417
 418 =head1 DESCRIPTION
 419
 420 This is the class implementing the Instruction Pointers. An
 421 Instruction Pointer (aka IP) has a stack, and a stack of stacks that
 422 can be manipulated via the methods of the class.
 423
 424 We need a class, since this is a concurrent Befunge, so we can have
 425 more than one IP travelling on the Lahey space.
 426
 427
 428
 429 =head1 CONSTRUCTORS
 430
 431 =head2 my $ip = LB::IP->new( [$dimensions] )
 432
 433 Create a new Instruction Pointer, which operates in a universe of the given
 434 C<$dimensions>. If C<$dimensions> is not specified, it defaults to 2
 435 (befunge world).
 436
 437
 438 =head2 my $clone = $ip->clone()
 439
 440 Clone the current Instruction Pointer with all its stacks, position,
 441 delta, etc. Change its unique ID.
 442
 443
 444
 445 =head1 ACCESSORS
 446
 447 =head2 Attributes
 448
 449 The following is a list of attributes of a Language::Befunge::IP
 450 object. For each of them, a method C<get_foobar> and C<set_foobar>
 451 exists.
 452
 453
 454 =over 4
 455
 456 =item $ip->get_id() / $ip->set_id($id)
 457
 458 The unique ID of the IP (an integer). Don't set the ID yourself.
 459
 460
 461 =item $ip->get_dims()
 462
 463 The number of dimensions this IP operates in (an integer). This is
 464 read-only.
 465
 466
 467 =item $ip->get_position() / $ip->set_position($vec)
 468
 469 The current coordinates of the IP (a C<Language::Befunge::Vector>
 470 object).
 471
 472
 473 =item $ip->get_delta() / $ip->set_delta($vec)
 474
 475 The velocity of the IP (a C<Language::Befunge::Vector> object).
 476
 477
 478 =item $ip->get_storage() / $ip->set_storage($vec)
 479
 480 The coordinates of the storage offset of the IP (a
 481 C<Language::Befunge::Vector> object).
 482
 483
 484 =item $ip->get_data() / $ip->set_data({})
 485
 486 The library private storage space (a hash reference). Don't set this
 487 yourself.
 488 FIXME: not supposed to be accessible
 489
 490
 491 =item $ip->get_string_mode() / set_string_mode($bool)
 492
 493 The string_mode of the IP (a boolean).
 494
 495
 496 =item $ip->get_end() / $ip->set_end($bool)
 497
 498 Whether the IP should be terminated (a boolean).
 499
 500
 501 =item $ip->get_libs() / $ip->set_libs($aref)
 502
 503 The current stack of loaded libraries (an array reference). Don't set
 504 this yourself.
 505 FIXME: not supposed to be accessible
 506
 507
 508 =item $ip->get_ss() / $ip->set_ss($aref)
 509
 510 The stack of stack of the IP (an array reference). Don't set this
 511 yourself.
 512 FIXME: not supposed to be accessible
 513
 514
 515 =item $ip->get_toss() / $ip->set_toss($aref)
 516
 517 The current stack (er, TOSS) of the IP (an array reference). Don't set
 518 this yourself.
 519 FIXME: not supposed to be accessible
 520
 521
 522 =back
 523
 524
 525 =head2 $ip->soss([$])
 526
 527 Get or set the SOSS.
 528
 529
 530
 531 =head1 PUBLIC METHODS
 532
 533 =head2 Internal stack
 534
 535 In this section, I speak about the stack. In fact, this is the TOSS - that
 536 is, the Top Of the Stack Stack.
 537
 538 In Befunge-98, standard stack operations occur transparently on the
 539 TOSS (as if there were only one stack, as in Befunge-93).
 540
 541
 542 =over 4
 543
 544 =item scount(  )
 545
 546 Return the number of elements in the stack.
 547
 548
 549 =item spush( value )
 550
 551 Push a value on top of the stack.
 552
 553
 554 =item spush_vec( vector )
 555
 556 Push a vector on top of the stack. The x coordinate is pushed first.
 557
 558
 559 =item spush_args ( arg, ... )
 560
 561 Push a list of argument on top of the stack (the first argument will
 562 be the deeper one). Convert each argument: a number is pushed as is,
 563 whereas a string is pushed as a 0gnirts.
 564
 565 B</!\> Do B<not> push references or weird arguments: this method
 566 supports only numbers (positive and negative) and strings.
 567
 568
 569 =item spop(  )
 570
 571 Pop a value from the stack. If the stack is empty, no error occurs and
 572 the method acts as if it popped a 0.
 573
 574
 575 =item spop_mult( <count> )
 576
 577 Pop multiple values from the stack. If the stack becomes empty, the
 578 remainder of the returned values will be 0.
 579
 580
 581 =item spop_vec(  )
 582
 583 Pop a vector from the stack. Returns a Vector object.
 584
 585
 586 =item spop_gnirts(  )
 587
 588 Pop a 0gnirts string from the stack.
 589
 590
 591 =item sclear(  )
 592
 593 Clear the stack.
 594
 595
 596 =item svalue( offset )
 597
 598 Return the C<offset>th value of the TOSS, counting from top of the
 599 TOSS. The offset is interpreted as a negative value, that is, a call
 600 with an offset of C<2> or C<-2> would return the second value on top
 601 of the TOSS.
 602
 603
 604 =back
 605
 606
 607 =head2 Stack stack
 608
 609 This section discusses about the stack stack. We can speak here about
 610 TOSS (Top Of Stack Stack) and SOSS (second on stack stack).
 611
 612 =over 4
 613
 614 =item ss_count(  )
 615
 616 Return the number of stacks in the stack stack. This of course does
 617 not include the TOSS itself.
 618
 619
 620
 621 =item ss_create( count )
 622
 623 Push the TOSS on the stack stack and create a new stack, aimed to be
 624 the new TOSS. Once created, transfer C<count> elements from the SOSS
 625 (the former TOSS) to the TOSS. Transfer here means move - and B<not>
 626 copy -, furthermore, order is preserved.
 627
 628 If count is negative, then C<count> zeroes are pushed on the new TOSS.
 629
 630
 631 =item ss_remove( count )
 632
 633 Move C<count> elements from TOSS to SOSS, discard TOSS and make the
 634 SOSS become the new TOSS. Order of elems is preserved.
 635
 636
 637 =item ss_transfer( count )
 638
 639 Transfer C<count> elements from SOSS to TOSS, or from TOSS to SOSS if
 640 C<count> is negative; the transfer is done via pop/push.
 641
 642 The order is not preserved, it is B<reversed>.
 643
 644
 645 =item ss_sizes(  )
 646
 647 Return a list with all the sizes of the stacks in the stack stack
 648 (including the TOSS), from the TOSS to the BOSS.
 649
 650
 651 =item soss_count(  )
 652
 653 Return the number of elements in SOSS.
 654
 655
 656 =item soss_push( value )
 657
 658 Push a value on top of the SOSS.
 659
 660
 661 =item soss_pop_mult( <count> )
 662
 663 Pop multiple values from the SOSS. If the stack becomes empty, the
 664 remainder of the returned values will be 0.
 665
 666
 667 =item soss_push_vec( vector )
 668
 669 Push a vector on top of the SOSS.
 670
 671
 672
 673 =item soss_pop(  )
 674
 675 Pop a value from the SOSS. If the stack is empty, no error occurs and
 676 the method acts as if it popped a 0.
 677
 678
 679 =item soss_pop_vec(  )
 680
 681 Pop a vector from the SOSS. If the stack is empty, no error occurs
 682 and the method acts as if it popped a 0.  returns a Vector.
 683
 684
 685 =item soss_clear(  )
 686
 687 Clear the SOSS.
 688
 689
 690 =back
 691
 692
 693 =head2 Changing direction
 694
 695 =over 4
 696
 697 =item dir_go_east(  )
 698
 699 Implements the C<E<gt>> instruction. Force the IP to travel east.
 700
 701
 702 =item dir_go_west(  )
 703
 704 Implements the C<E<lt>> instruction. Force the IP to travel west.
 705
 706
 707 =item dir_go_north(  )
 708
 709 Implements the C<^> instruction. Force the IP to travel north.
 710
 711 Not valid for Unefunge.
 712
 713
 714 =item dir_go_south(  )
 715
 716 Implements the C<v> instruction. Force the IP to travel south.
 717
 718 Not valid for Unefunge.
 719
 720
 721 =item dir_go_high(  )
 722
 723 Implements the C<h> instruction. Force the IP to travel up.
 724
 725 Not valid for Unefunge or Befunge.
 726
 727
 728 =item dir_go_low(  )
 729
 730 Implements the C<l> instruction. Force the IP to travel down.
 731
 732 Not valid for Unefunge or Befunge.
 733
 734
 735 =item dir_go_away(  )
 736
 737 Implements the C<?> instruction. Cause the IP to travel in a random
 738 cardinal direction (in Befunge's case, one of: north, south, east or
 739 west).
 740
 741
 742 =item dir_turn_left(  )
 743
 744 Implements the C<[> instruction. Rotate by 90 degrees on the left the
 745 delta of the IP which encounters this instruction.
 746
 747 Not valid for Unefunge.  For Trefunge and greater, only affects the
 748 X and Y axes.
 749
 750
 751 =item dir_turn_right(  )
 752
 753 Implements the C<]> instruction. Rotate by 90 degrees on the right the
 754 delta of the IP which encounters this instruction.
 755
 756 Not valid for Unefunge.  For Trefunge and higher dimensions, only
 757 affects the X and Y axes.
 758
 759
 760
 761 =item dir_reverse(  )
 762
 763 Implements the C<r> instruction. Reverse the direction of the IP, that
 764 is, multiply the IP's delta by -1.
 765
 766
 767
 768 =back
 769
 770 =head2 Libraries semantics
 771
 772 =over 4
 773
 774 =item load( obj )
 775
 776 Load the given library semantics. The parameter is an extension object
 777 (a library instance).
 778
 779
 780
 781 =item unload( lib )
 782
 783 Unload the given library semantics. The parameter is the library name.
 784
 785 Return the library name if it was correctly unloaded, undef otherwise.
 786
 787 B</!\> If the library has been loaded twice, this method will only
 788 unload the most recent library. Ie, if an IP has loaded the libraries
 789 ( C<FOO>, C<BAR>, C<FOO>, C<BAZ> ) and one calls C<unload( "FOO" )>,
 790 then the IP will follow the semantics of C<BAZ>, then C<BAR>, then
 791 <FOO> (!).
 792
 793
 794 =item extdata( library, [value] )
 795
 796 Store or fetch a value in a private space. This private space is
 797 reserved for libraries that need to store internal values.
 798
 799 Since in Perl references are plain scalars, one can store a reference
 800 to an array or even a hash.
 801
 802 =back
 803
 804
 805
 806
 807 =head1 SEE ALSO
 808
 809 L<Language::Befunge>.
 810
 811
 812 =head1 AUTHOR
 813
 814 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 815
 816
 817
 818 =head1 COPYRIGHT & LICENSE
 819
 820 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
 821
 822 This program is free software; you can redistribute it and/or modify
 823 it under the same terms as Perl itself.
 824
 825
 826 =cut