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