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         => { map { $_=>[] } 'A'..'Z' },
  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
 372     my $libs = $self->get_libs;
 373     foreach my $letter ( 'A' .. 'Z' ) {
 374         next unless $lib->can($letter);
 375         push @{ $libs->{$letter} }, $lib;
 376     }
 377 }
 378
 379 sub unload {
 380     my ($self, $lib) = @_;
 381
 382     my $libs = $self->get_libs;
 383     foreach my $letter ( 'A' .. 'Z' ) {
 384         next unless $lib->can($letter);
 385         pop @{ $libs->{$letter} };
 386     }
 387 }
 388
 389 sub extdata {
 390     my $self = shift;
 391     my $lib  = shift;
 392     @_ ? $self->get_data->{$lib} = shift : $self->get_data->{$lib};
 393 }
 394
 395
 396 # -- PRIVATE METHODS
 397
 398 #
 399 # my $id = _get_new_id;
 400 #
 401 # Forge a new IP id, that will distinct it from the other IPs of the program.
 402 #
 403 my $id = 0;
 404 sub _get_new_id {
 405     return $id++;
 406 }
 407
 408 1;
 409 __END__
 410
 411 =head1 NAME
 412
 413 Language::Befunge::IP - an Instruction Pointer for a Befunge-98 program.
 414
 415
 416
 417 =head1 DESCRIPTION
 418
 419 This is the class implementing the Instruction Pointers. An
 420 Instruction Pointer (aka IP) has a stack, and a stack of stacks that
 421 can be manipulated via the methods of the class.
 422
 423 We need a class, since this is a concurrent Befunge, so we can have
 424 more than one IP travelling on the Lahey space.
 425
 426
 427
 428 =head1 CONSTRUCTORS
 429
 430 =head2 my $ip = LB::IP->new( [$dimensions] )
 431
 432 Create a new Instruction Pointer, which operates in a universe of the given
 433 C<$dimensions>. If C<$dimensions> is not specified, it defaults to 2
 434 (befunge world).
 435
 436
 437 =head2 my $clone = $ip->clone()
 438
 439 Clone the current Instruction Pointer with all its stacks, position,
 440 delta, etc. Change its unique ID.
 441
 442
 443
 444 =head1 ACCESSORS
 445
 446 =head2 Attributes
 447
 448 The following is a list of attributes of a Language::Befunge::IP
 449 object. For each of them, a method C<get_foobar> and C<set_foobar>
 450 exists.
 451
 452
 453 =over 4
 454
 455 =item $ip->get_id() / $ip->set_id($id)
 456
 457 The unique ID of the IP (an integer). Don't set the ID yourself.
 458
 459
 460 =item $ip->get_dims()
 461
 462 The number of dimensions this IP operates in (an integer). This is
 463 read-only.
 464
 465
 466 =item $ip->get_position() / $ip->set_position($vec)
 467
 468 The current coordinates of the IP (a C<Language::Befunge::Vector>
 469 object).
 470
 471
 472 =item $ip->get_delta() / $ip->set_delta($vec)
 473
 474 The velocity of the IP (a C<Language::Befunge::Vector> object).
 475
 476
 477 =item $ip->get_storage() / $ip->set_storage($vec)
 478
 479 The coordinates of the storage offset of the IP (a
 480 C<Language::Befunge::Vector> object).
 481
 482
 483 =item $ip->get_data() / $ip->set_data({})
 484
 485 The library private storage space (a hash reference). Don't set this
 486 yourself.
 487 FIXME: not supposed to be accessible
 488
 489
 490 =item $ip->get_string_mode() / set_string_mode($bool)
 491
 492 The string_mode of the IP (a boolean).
 493
 494
 495 =item $ip->get_end() / $ip->set_end($bool)
 496
 497 Whether the IP should be terminated (a boolean).
 498
 499
 500 =item $ip->get_libs() / $ip->set_libs($aref)
 501
 502 The current stack of loaded libraries (an array reference). Don't set
 503 this yourself.
 504 FIXME: not supposed to be accessible
 505
 506
 507 =item $ip->get_ss() / $ip->set_ss($aref)
 508
 509 The stack of stack of the IP (an array reference). Don't set this
 510 yourself.
 511 FIXME: not supposed to be accessible
 512
 513
 514 =item $ip->get_toss() / $ip->set_toss($aref)
 515
 516 The current stack (er, TOSS) of the IP (an array reference). Don't set
 517 this yourself.
 518 FIXME: not supposed to be accessible
 519
 520
 521 =back
 522
 523
 524 =head2 $ip->soss([$])
 525
 526 Get or set the SOSS.
 527
 528
 529
 530 =head1 PUBLIC METHODS
 531
 532 =head2 Internal stack
 533
 534 In this section, I speak about the stack. In fact, this is the TOSS - that
 535 is, the Top Of the Stack Stack.
 536
 537 In Befunge-98, standard stack operations occur transparently on the
 538 TOSS (as if there were only one stack, as in Befunge-93).
 539
 540
 541 =over 4
 542
 543 =item scount(  )
 544
 545 Return the number of elements in the stack.
 546
 547
 548 =item spush( value )
 549
 550 Push a value on top of the stack.
 551
 552
 553 =item spush_vec( vector )
 554
 555 Push a vector on top of the stack. The x coordinate is pushed first.
 556
 557
 558 =item spush_args ( arg, ... )
 559
 560 Push a list of argument on top of the stack (the first argument will
 561 be the deeper one). Convert each argument: a number is pushed as is,
 562 whereas a string is pushed as a 0gnirts.
 563
 564 B</!\> Do B<not> push references or weird arguments: this method
 565 supports only numbers (positive and negative) and strings.
 566
 567
 568 =item spop(  )
 569
 570 Pop a value from the stack. If the stack is empty, no error occurs and
 571 the method acts as if it popped a 0.
 572
 573
 574 =item spop_mult( <count> )
 575
 576 Pop multiple values from the stack. If the stack becomes empty, the
 577 remainder of the returned values will be 0.
 578
 579
 580 =item spop_vec(  )
 581
 582 Pop a vector from the stack. Returns a Vector object.
 583
 584
 585 =item spop_gnirts(  )
 586
 587 Pop a 0gnirts string from the stack.
 588
 589
 590 =item sclear(  )
 591
 592 Clear the stack.
 593
 594
 595 =item svalue( offset )
 596
 597 Return the C<offset>th value of the TOSS, counting from top of the
 598 TOSS. The offset is interpreted as a negative value, that is, a call
 599 with an offset of C<2> or C<-2> would return the second value on top
 600 of the TOSS.
 601
 602
 603 =back
 604
 605
 606 =head2 Stack stack
 607
 608 This section discusses about the stack stack. We can speak here about
 609 TOSS (Top Of Stack Stack) and SOSS (second on stack stack).
 610
 611 =over 4
 612
 613 =item ss_count(  )
 614
 615 Return the number of stacks in the stack stack. This of course does
 616 not include the TOSS itself.
 617
 618
 619
 620 =item ss_create( count )
 621
 622 Push the TOSS on the stack stack and create a new stack, aimed to be
 623 the new TOSS. Once created, transfer C<count> elements from the SOSS
 624 (the former TOSS) to the TOSS. Transfer here means move - and B<not>
 625 copy -, furthermore, order is preserved.
 626
 627 If count is negative, then C<count> zeroes are pushed on the new TOSS.
 628
 629
 630 =item ss_remove( count )
 631
 632 Move C<count> elements from TOSS to SOSS, discard TOSS and make the
 633 SOSS become the new TOSS. Order of elems is preserved.
 634
 635
 636 =item ss_transfer( count )
 637
 638 Transfer C<count> elements from SOSS to TOSS, or from TOSS to SOSS if
 639 C<count> is negative; the transfer is done via pop/push.
 640
 641 The order is not preserved, it is B<reversed>.
 642
 643
 644 =item ss_sizes(  )
 645
 646 Return a list with all the sizes of the stacks in the stack stack
 647 (including the TOSS), from the TOSS to the BOSS.
 648
 649
 650 =item soss_count(  )
 651
 652 Return the number of elements in SOSS.
 653
 654
 655 =item soss_push( value )
 656
 657 Push a value on top of the SOSS.
 658
 659
 660 =item soss_pop_mult( <count> )
 661
 662 Pop multiple values from the SOSS. If the stack becomes empty, the
 663 remainder of the returned values will be 0.
 664
 665
 666 =item soss_push_vec( vector )
 667
 668 Push a vector on top of the SOSS.
 669
 670
 671
 672 =item soss_pop(  )
 673
 674 Pop a value from the SOSS. If the stack is empty, no error occurs and
 675 the method acts as if it popped a 0.
 676
 677
 678 =item soss_pop_vec(  )
 679
 680 Pop a vector from the SOSS. If the stack is empty, no error occurs
 681 and the method acts as if it popped a 0.  returns a Vector.
 682
 683
 684 =item soss_clear(  )
 685
 686 Clear the SOSS.
 687
 688
 689 =back
 690
 691
 692 =head2 Changing direction
 693
 694 =over 4
 695
 696 =item dir_go_east(  )
 697
 698 Implements the C<E<gt>> instruction. Force the IP to travel east.
 699
 700
 701 =item dir_go_west(  )
 702
 703 Implements the C<E<lt>> instruction. Force the IP to travel west.
 704
 705
 706 =item dir_go_north(  )
 707
 708 Implements the C<^> instruction. Force the IP to travel north.
 709
 710 Not valid for Unefunge.
 711
 712
 713 =item dir_go_south(  )
 714
 715 Implements the C<v> instruction. Force the IP to travel south.
 716
 717 Not valid for Unefunge.
 718
 719
 720 =item dir_go_high(  )
 721
 722 Implements the C<h> instruction. Force the IP to travel up.
 723
 724 Not valid for Unefunge or Befunge.
 725
 726
 727 =item dir_go_low(  )
 728
 729 Implements the C<l> instruction. Force the IP to travel down.
 730
 731 Not valid for Unefunge or Befunge.
 732
 733
 734 =item dir_go_away(  )
 735
 736 Implements the C<?> instruction. Cause the IP to travel in a random
 737 cardinal direction (in Befunge's case, one of: north, south, east or
 738 west).
 739
 740
 741 =item dir_turn_left(  )
 742
 743 Implements the C<[> instruction. Rotate by 90 degrees on the left the
 744 delta of the IP which encounters this instruction.
 745
 746 Not valid for Unefunge.  For Trefunge and greater, only affects the
 747 X and Y axes.
 748
 749
 750 =item dir_turn_right(  )
 751
 752 Implements the C<]> instruction. Rotate by 90 degrees on the right the
 753 delta of the IP which encounters this instruction.
 754
 755 Not valid for Unefunge.  For Trefunge and higher dimensions, only
 756 affects the X and Y axes.
 757
 758
 759
 760 =item dir_reverse(  )
 761
 762 Implements the C<r> instruction. Reverse the direction of the IP, that
 763 is, multiply the IP's delta by -1.
 764
 765
 766
 767 =back
 768
 769 =head2 Libraries semantics
 770
 771 =over 4
 772
 773 =item load( obj )
 774
 775 Load the given library semantics. The parameter is an extension object
 776 (a library instance).
 777
 778
 779
 780 =item unload( lib )
 781
 782 Unload the given library semantics. The parameter is the library name.
 783
 784 Return the library name if it was correctly unloaded, undef otherwise.
 785
 786 B</!\> If the library has been loaded twice, this method will only
 787 unload the most recent library. Ie, if an IP has loaded the libraries
 788 ( C<FOO>, C<BAR>, C<FOO>, C<BAZ> ) and one calls C<unload( "FOO" )>,
 789 then the IP will follow the semantics of C<BAZ>, then C<BAR>, then
 790 <FOO> (!).
 791
 792
 793 =item extdata( library, [value] )
 794
 795 Store or fetch a value in a private space. This private space is
 796 reserved for libraries that need to store internal values.
 797
 798 Since in Perl references are plain scalars, one can store a reference
 799 to an array or even a hash.
 800
 801 =back
 802
 803
 804
 805
 806 =head1 SEE ALSO
 807
 808 L<Language::Befunge>.
 809
 810
 811 =head1 AUTHOR
 812
 813 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 814
 815
 816
 817 =head1 COPYRIGHT & LICENSE
 818
 819 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
 820
 821 This program is free software; you can redistribute it and/or modify
 822 it under the same terms as Perl itself.
 823
 824
 825 =cut