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