v4.13
[language-befunge.git] / lib / Language / Befunge / IP.pm
blobd029b0d285882d002f198840815bdce66d02ffc9
2 # This file is part of Language::Befunge.
3 # Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
5 # This program is free software; you can redistribute it and/or modify
6 # it under the same terms as Perl itself.
10 package Language::Befunge::IP;
11 require 5.010;
13 use strict;
14 use warnings;
15 use integer;
17 use Carp;
18 use Language::Befunge::Vector;
19 use Storable qw(dclone);
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',
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',
49 # -- CONSTRUCTORS
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' },
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;
74 sub clone {
75 my $self = shift;
76 my $clone = dclone( $self );
77 $clone->set_id( $self->_get_new_id );
78 return $clone;
82 # -- ACCESSORS
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];
93 sub scount {
94 my $self = shift;
95 return scalar @{ $self->get_toss };
98 sub spush {
99 my $self = shift;
100 push @{ $self->get_toss }, @_;
103 sub spush_vec {
104 my ($self) = shift;
105 foreach my $v (@_) {
106 $self->spush($v->get_all_components);
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.
121 sub spop {
122 my $self = shift;
123 my $val = pop @{ $self->get_toss };
124 defined $val or $val = 0;
125 return $val;
128 sub spop_mult {
129 my ($self, $count) = @_;
130 my @rv = reverse map { $self->spop() } (1..$count);
131 return @rv;
134 sub spop_vec {
135 my $self = shift;
136 return Language::Befunge::Vector->new($self->spop_mult($self->get_dims));
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;
151 sub sclear {
152 my $self = shift;
153 $self->set_toss( [] );
156 sub svalue {
157 my ($self, $idx) = @_;
159 $idx = - abs( $idx );
160 return 0 unless exists $self->get_toss->[$idx];
161 return $self->get_toss->[$idx];
164 sub ss_count {
165 my $self = shift;
166 return scalar( @{ $self->get_ss } );
169 sub ss_create {
170 my ( $self, $n ) = @_;
172 my @new_toss;
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;
188 # $n == 0: do nothing
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 );
199 sub ss_remove {
200 my ( $self, $n ) = @_;
202 # Fetch the TOSS.
203 # Remember, the Stack Stack is up->bottom.
204 my $new_toss = shift @{ $self->get_ss };
206 if ( $n < 0 ) {
207 # Remove values.
208 if ( scalar(@$new_toss) >= abs($n) ) {
209 splice @$new_toss, $n;
210 } else {
211 $new_toss = [];
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 } );
223 # $n == 0: do nothing
226 # Store the new TOSS.
227 $self->set_toss( $new_toss );
230 sub ss_transfer {
231 my ($self, $n) = @_;
232 $n == 0 and return;
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;
244 $self->spush( reverse @elems );
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;
257 $self->soss_push( reverse @elems );
262 sub ss_sizes {
263 my $self = shift;
265 my @sizes = ( $self->scount );
267 # Store the size of each stack.
268 foreach my $i ( 1..$self->ss_count ) {
269 push @sizes, scalar @{ $self->get_ss->[$i-1] };
272 return @sizes;
276 sub soss_count {
277 my $self = shift;
278 return scalar( @{ $self->soss } );
281 sub soss_push {
282 my $self = shift;
283 push @{ $self->soss }, @_;
287 sub soss_pop_mult {
288 my ($self, $count) = @_;
289 my @rv = reverse map { $self->soss_pop() } (1..$count);
290 return @rv;
293 sub soss_push_vec {
294 my $self = shift;
295 foreach my $v (@_) {
296 $self->soss_push($v->get_all_components);
300 sub soss_pop {
301 my $self = shift;
302 my $val = pop @{ $self->soss };
303 defined $val or $val = 0;
304 return $val;
307 sub soss_pop_vec {
308 my $self = shift;
309 return Language::Befunge::Vector->new($self->soss_pop_mult($self->get_dims));
312 sub soss_clear {
313 my $self = shift;
314 $self->soss( [] );
319 sub dir_go_east {
320 my $self = shift;
321 $self->get_delta->clear;
322 $self->get_delta->set_component(0, 1);
325 sub dir_go_west {
326 my $self = shift;
327 $self->get_delta->clear;
328 $self->get_delta->set_component(0, -1);
331 sub dir_go_north {
332 my $self = shift;
333 $self->get_delta->clear;
334 $self->get_delta->set_component(1, -1);
337 sub dir_go_south {
338 my $self = shift;
339 $self->get_delta->clear;
340 $self->get_delta->set_component(1, 1);
343 sub dir_go_high {
344 my $self = shift;
345 $self->get_delta->clear;
346 $self->get_delta->set_component(2, 1);
349 sub dir_go_low {
350 my $self = shift;
351 $self->get_delta->clear;
352 $self->get_delta->set_component(2, -1);
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);
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);
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);
380 sub dir_reverse {
381 my $self = shift;
382 $self->set_delta(-$self->get_delta);
385 sub load {
386 my ($self, $lib) = @_;
388 my $libs = $self->get_libs;
389 foreach my $letter ( 'A' .. 'Z' ) {
390 next unless $lib->can($letter);
391 push @{ $libs->{$letter} }, $lib;
395 sub unload {
396 my ($self, $lib) = @_;
398 my $libs = $self->get_libs;
399 foreach my $letter ( 'A' .. 'Z' ) {
400 next unless $lib->can($letter);
401 pop @{ $libs->{$letter} };
405 sub extdata {
406 my $self = shift;
407 my $lib = shift;
408 @_ ? $self->get_data->{$lib} = shift : $self->get_data->{$lib};
412 # -- PRIVATE METHODS
415 # my $id = _get_new_id;
417 # Forge a new IP id, that will distinct it from the other IPs of the program.
419 my $id = 0;
420 sub _get_new_id {
421 return $id++;
425 __END__
427 =head1 NAME
429 Language::Befunge::IP - an Instruction Pointer for a Befunge-98 program.
433 =head1 DESCRIPTION
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.
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.
444 =head1 CONSTRUCTORS
446 =head2 my $ip = LB::IP->new( [$dimensions] )
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).
453 =head2 my $clone = $ip->clone()
455 Clone the current Instruction Pointer with all its stacks, position,
456 delta, etc. Change its unique ID.
460 =head1 ACCESSORS
462 =head2 Attributes
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.
469 =over 4
471 =item $ip->get_id() / $ip->set_id($id)
473 The unique ID of the IP (an integer). Don't set the ID yourself.
476 =item $ip->get_dims()
478 The number of dimensions this IP operates in (an integer). This is
479 read-only.
482 =item $ip->get_position() / $ip->set_position($vec)
484 The current coordinates of the IP (a C<Language::Befunge::Vector>
485 object).
488 =item $ip->get_delta() / $ip->set_delta($vec)
490 The velocity of the IP (a C<Language::Befunge::Vector> object).
493 =item $ip->get_storage() / $ip->set_storage($vec)
495 The coordinates of the storage offset of the IP (a
496 C<Language::Befunge::Vector> object).
499 =item $ip->get_data() / $ip->set_data({})
501 The library private storage space (a hash reference). Don't set this
502 yourself.
503 FIXME: not supposed to be accessible
506 =item $ip->get_string_mode() / set_string_mode($bool)
508 The string_mode of the IP (a boolean).
511 =item $ip->get_end() / $ip->set_end($bool)
513 Whether the IP should be terminated (a boolean).
516 =item $ip->get_libs() / $ip->set_libs($aref)
518 The current stack of loaded libraries (an array reference). Don't set
519 this yourself.
520 FIXME: not supposed to be accessible
523 =item $ip->get_ss() / $ip->set_ss($aref)
525 The stack of stack of the IP (an array reference). Don't set this
526 yourself.
527 FIXME: not supposed to be accessible
530 =item $ip->get_toss() / $ip->set_toss($aref)
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
537 =back
540 =head2 $ip->soss([$])
542 Get or set the SOSS.
546 =head1 PUBLIC METHODS
548 =head2 Internal stack
550 In this section, I speak about the stack. In fact, this is the TOSS - that
551 is, the Top Of the Stack Stack.
553 In Befunge-98, standard stack operations occur transparently on the
554 TOSS (as if there were only one stack, as in Befunge-93).
557 =over 4
559 =item scount( )
561 Return the number of elements in the stack.
564 =item spush( value )
566 Push a value on top of the stack.
569 =item spush_vec( vector )
571 Push a vector on top of the stack. The x coordinate is pushed first.
574 =item spush_args ( arg, ... )
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.
580 B</!\> Do B<not> push references or weird arguments: this method
581 supports only numbers (positive and negative) and strings.
584 =item spop( )
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.
590 =item spop_mult( <count> )
592 Pop multiple values from the stack. If the stack becomes empty, the
593 remainder of the returned values will be 0.
596 =item spop_vec( )
598 Pop a vector from the stack. Returns a Vector object.
601 =item spop_gnirts( )
603 Pop a 0gnirts string from the stack.
606 =item sclear( )
608 Clear the stack.
611 =item svalue( offset )
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.
619 =back
622 =head2 Stack stack
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).
627 =over 4
629 =item ss_count( )
631 Return the number of stacks in the stack stack. This of course does
632 not include the TOSS itself.
636 =item ss_create( count )
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.
643 If count is negative, then C<count> zeroes are pushed on the new TOSS.
646 =item ss_remove( count )
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.
652 =item ss_transfer( count )
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.
657 The order is not preserved, it is B<reversed>.
660 =item ss_sizes( )
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.
666 =item soss_count( )
668 Return the number of elements in SOSS.
671 =item soss_push( value )
673 Push a value on top of the SOSS.
676 =item soss_pop_mult( <count> )
678 Pop multiple values from the SOSS. If the stack becomes empty, the
679 remainder of the returned values will be 0.
682 =item soss_push_vec( vector )
684 Push a vector on top of the SOSS.
688 =item soss_pop( )
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.
694 =item soss_pop_vec( )
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.
700 =item soss_clear( )
702 Clear the SOSS.
705 =back
708 =head2 Changing direction
710 =over 4
712 =item dir_go_east( )
714 Implements the C<E<gt>> instruction. Force the IP to travel east.
717 =item dir_go_west( )
719 Implements the C<E<lt>> instruction. Force the IP to travel west.
722 =item dir_go_north( )
724 Implements the C<^> instruction. Force the IP to travel north.
726 Not valid for Unefunge.
729 =item dir_go_south( )
731 Implements the C<v> instruction. Force the IP to travel south.
733 Not valid for Unefunge.
736 =item dir_go_high( )
738 Implements the C<h> instruction. Force the IP to travel up.
740 Not valid for Unefunge or Befunge.
743 =item dir_go_low( )
745 Implements the C<l> instruction. Force the IP to travel down.
747 Not valid for Unefunge or Befunge.
750 =item dir_go_away( )
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).
757 =item dir_turn_left( )
759 Implements the C<[> instruction. Rotate by 90 degrees on the left the
760 delta of the IP which encounters this instruction.
762 Not valid for Unefunge. For Trefunge and greater, only affects the
763 X and Y axes.
766 =item dir_turn_right( )
768 Implements the C<]> instruction. Rotate by 90 degrees on the right the
769 delta of the IP which encounters this instruction.
771 Not valid for Unefunge. For Trefunge and higher dimensions, only
772 affects the X and Y axes.
776 =item dir_reverse( )
778 Implements the C<r> instruction. Reverse the direction of the IP, that
779 is, multiply the IP's delta by -1.
783 =back
785 =head2 Libraries semantics
787 =over 4
789 =item load( obj )
791 Load the given library semantics. The parameter is an extension object
792 (a library instance).
796 =item unload( lib )
798 Unload the given library semantics. The parameter is the library name.
800 Return the library name if it was correctly unloaded, undef otherwise.
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> (!).
809 =item extdata( library, [value] )
811 Store or fetch a value in a private space. This private space is
812 reserved for libraries that need to store internal values.
814 Since in Perl references are plain scalars, one can store a reference
815 to an array or even a hash.
817 =back
822 =head1 SEE ALSO
824 L<Language::Befunge>.
827 =head1 AUTHOR
829 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
833 =head1 COPYRIGHT & LICENSE
835 Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
837 This program is free software; you can redistribute it and/or modify
838 it under the same terms as Perl itself.
841 =cut