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
::Ops
;
16 use File
::Spec
::Functions
qw{ catfile
}; # For the 'y' instruction.
17 use Language
::Befunge
::Debug
;
22 Language::Befunge::Ops - definition of the various operations
27 This module implements the various befunge operations. Not all those
28 operations will be supported by the interpreter though, it will depend
29 on the type of befunge chosen.
38 =item num_push_number( )
40 Push the current number onto the TOSS.
44 my ($lbi, $char) = @_;
47 my $ip = $lbi->get_curip;
48 my $num = hex( $char );
54 debug
( "pushing number '$num'\n" );
65 =item str_enter_string_mode( )
68 sub str_enter_string_mode
{
72 debug
( "entering string mode\n" );
74 # Entering string-mode.
75 $lbi->get_curip->set_string_mode(1);
79 =item str_fetch_char( )
84 my $ip = $lbi->get_curip;
87 $lbi->_move_ip_once($lbi->get_curip);
89 # .. then fetch value and push it.
90 my $ord = $lbi->get_storage->get_value( $ip->get_position );
91 my $chr = $lbi->get_storage->get_char( $ip->get_position );
95 debug
( "pushing value $ord (char='$chr')\n" );
99 =item str_store_char( )
104 my $ip = $lbi->get_curip;
107 $lbi->_move_ip_once($lbi->get_curip);
113 $lbi->get_storage->set_value( $ip->get_position, $val );
114 my $chr = $lbi->get_storage->get_char( $ip->get_position );
117 debug
( "storing value $val (char='$chr')\n" );
124 =head2 Mathematical operations
128 =item math_addition( )
133 my $ip = $lbi->get_curip;
136 my ($v1, $v2) = $ip->spop_mult(2);
137 debug
( "adding: $v1+$v2\n" );
140 # Checking over/underflow.
141 $res > 2**31-1 and $lbi->abort( "program overflow while performing addition" );
142 $res < -2**31 and $lbi->abort( "program underflow while performing addition" );
149 =item math_substraction( )
152 sub math_substraction
{
154 my $ip = $lbi->get_curip;
157 my ($v1, $v2) = $ip->spop_mult(2);
158 debug
( "substracting: $v1-$v2\n" );
161 # checking over/underflow.
162 $res > 2**31-1 and $lbi->abort( "program overflow while performing substraction" );
163 $res < -2**31 and $lbi->abort( "program underflow while performing substraction" );
170 =item math_multiplication( )
173 sub math_multiplication
{
175 my $ip = $lbi->get_curip;
178 my ($v1, $v2) = $ip->spop_mult(2);
179 debug
( "multiplicating: $v1*$v2\n" );
182 # checking over/underflow.
183 $res > 2**31-1 and $lbi->abort( "program overflow while performing multiplication" );
184 $res < -2**31 and $lbi->abort( "program underflow while performing multiplication" );
191 =item math_division( )
196 my $ip = $lbi->get_curip;
199 my ($v1, $v2) = $ip->spop_mult(2);
200 debug
( "dividing: $v1/$v2\n" );
201 my $res = $v2 == 0 ?
0 : int($v1 / $v2);
203 # Can't do over/underflow with integer division.
210 =item math_remainder( )
215 my $ip = $lbi->get_curip;
218 my ($v1, $v2) = $ip->spop_mult(2);
219 debug
( "remainder: $v1%$v2\n" );
220 my $res = $v2 == 0 ?
0 : int($v1 % $v2);
222 # Can't do over/underflow with integer remainder.
232 =head2 Direction changing
241 debug
( "going east\n" );
242 $lbi->get_curip->dir_go_east;
251 debug
( "going west\n" );
252 $lbi->get_curip->dir_go_west;
256 =item dir_go_north( )
261 debug
( "going north\n" );
262 $lbi->get_curip->dir_go_north;
266 =item dir_go_south( )
271 debug
( "going south\n" );
272 $lbi->get_curip->dir_go_south;
281 debug
( "going high\n" );
282 $lbi->get_curip->dir_go_high;
291 debug
( "going low\n" );
292 $lbi->get_curip->dir_go_low;
301 debug
( "going away!\n" );
302 $lbi->get_curip->dir_go_away;
306 =item dir_turn_left( )
308 Turning left, like a car (the specs speak about a bicycle, but perl
309 is _so_ fast that we can speak about cars ;) ).
314 debug
( "turning on the left\n" );
315 $lbi->get_curip->dir_turn_left;
319 =item dir_turn_right( )
321 Turning right, like a car (the specs speak about a bicycle, but perl
322 is _so_ fast that we can speak about cars ;) ).
327 debug
( "turning on the right\n" );
328 $lbi->get_curip->dir_turn_right;
337 debug
( "180 deg!\n" );
338 $lbi->get_curip->dir_reverse;
342 =item dir_set_delta( )
344 Hmm, the user seems to know where he wants to go. Let's trust him/her.
349 my $ip = $lbi->get_curip;
350 my ($new_d) = $ip->spop_vec;
351 debug
( "setting delta to $new_d\n" );
352 $ip->set_delta( $new_d );
359 =head2 Decision making
368 my $ip = $lbi->get_curip;
371 my $val = $ip->spop ?
0 : 1;
374 debug
( "logical not: pushing $val\n" );
383 my $ip = $lbi->get_curip;
386 my ($v1, $v2) = $ip->spop_mult(2);
387 debug
( "comparing $v1 vs $v2\n" );
388 $ip->spush( ($v1 > $v2) ?
1 : 0 );
392 =item decis_horiz_if( )
397 my $ip = $lbi->get_curip;
401 $val ?
$ip->dir_go_west : $ip->dir_go_east;
402 debug
( "horizontal if: going " . ( $val ?
"west\n" : "east\n" ) );
406 =item decis_vert_if( )
411 my $ip = $lbi->get_curip;
415 $val ?
$ip->dir_go_north : $ip->dir_go_south;
416 debug
( "vertical if: going " . ( $val ?
"north\n" : "south\n" ) );
425 my $ip = $lbi->get_curip;
429 $val ?
$ip->dir_go_low : $ip->dir_go_high;
430 debug
( "z if: going " . ( $val ?
"low\n" : "high\n" ) );
439 my $ip = $lbi->get_curip;
442 my ($v1, $v2) = $ip->spop_mult(2);
443 debug
( "comparing $v1 with $v2: straight forward!\n"), return if $v1 == $v2;
453 debug
( "comparing $v1 with $v2: turning: $dir\n" );
466 A serie of spaces is to be treated as B<one> NO-OP.
471 my $ip = $lbi->get_curip;
472 $lbi->_move_ip_till($ip, qr/ /);
473 $lbi->move_ip($lbi->get_curip);
475 my $char = $lbi->get_storage->get_char($ip->get_position);
476 $lbi->_do_instruction($char);
489 =item flow_comments( )
491 Bypass comments in B<zero> tick.
496 my $ip = $lbi->get_curip;
498 $lbi->_move_ip_once($ip); # skip comment ';'
499 $lbi->_move_ip_till( $ip, qr/[^;]/ ); # till just before matching ';'
500 $lbi->_move_ip_once($ip); # till matching ';'
501 $lbi->_move_ip_once($ip); # till just after matching ';'
503 my $char = $lbi->get_storage->get_char($ip->get_position);
504 $lbi->_do_instruction($char);
508 =item flow_trampoline( )
511 sub flow_trampoline
{
513 $lbi->_move_ip_once($lbi->get_curip);
514 debug
( "trampoline! (skipping next instruction)\n" );
518 =item flow_jump_to( )
523 my $ip = $lbi->get_curip;
524 my $count = $ip->spop;
525 debug
( "skipping $count instructions\n" );
526 $count == 0 and return;
527 $count < 0 and $ip->dir_reverse; # We can move backward.
528 $lbi->_move_ip_once($lbi->get_curip) for (1..abs($count));
529 $count < 0 and $ip->dir_reverse;
538 my $ip = $lbi->get_curip;
539 my $pos = $ip->get_position;
541 my $kcounter = $ip->spop;
542 debug
( "repeating next instruction $kcounter times.\n" );
544 # fetch instruction to repeat
545 $lbi->move_ip($lbi->get_curip);
546 my $char = $lbi->get_storage->get_char($ip->get_position);
548 $char eq 'k' and return; # k cannot be itself repeated
549 $kcounter == 0 and return; # nothing to repeat
550 $kcounter < 0 and return; # oops, error
552 # reset position back to where k is, and repeat instruction
553 $ip->set_position($pos);
554 $lbi->_do_instruction($char) for (1..$kcounter);
558 =item flow_kill_thread( )
561 sub flow_kill_thread
{
563 debug
( "end of Instruction Pointer\n" );
564 $lbi->get_curip->set_end('@');
573 debug
( "end program\n" );
574 $lbi->set_newips( [] );
576 $lbi->get_curip->set_end('q');
577 $lbi->set_retval( $lbi->get_curip->spop );
584 =head2 Stack manipulation
593 debug
( "popping a value\n" );
594 $lbi->get_curip->spop;
598 =item stack_duplicate( )
601 sub stack_duplicate
{
603 my $ip = $lbi->get_curip;
604 my $value = $ip->spop;
605 debug
( "duplicating value '$value'\n" );
606 $ip->spush( $value );
607 $ip->spush( $value );
616 my $ ip
= $lbi->get_curip;
617 my ($v1, $v2) = $ip->spop_mult(2);
618 debug
( "swapping $v1 and $v2\n" );
629 debug
( "clearing stack\n" );
630 $lbi->get_curip->sclear;
637 =head2 Stack stack manipulation
646 my $ip = $lbi->get_curip;
647 debug
( "block opening\n" );
650 $ip->ss_create( $ip->spop );
652 # Store current storage offset on SOSS.
653 $ip->soss_push( $ip->get_storage->get_all_components );
655 # Set the new Storage Offset.
656 $lbi->_move_ip_once($lbi->get_curip);
657 $ip->set_storage( $ip->get_position );
659 $lbi->_move_ip_once($lbi->get_curip);
669 my $ip = $lbi->get_curip;
672 $ip->ss_count <= 0 and $ip->dir_reverse, debug
("no opened block\n"), return;
674 debug
( "block closing\n" );
676 # Restore Storage offset.
677 $ip->set_storage( $ip->soss_pop_vec );
680 $ip->ss_remove( $ip->spop );
684 =item bloc_transfer( )
689 my $ip = $lbi->get_curip;
691 $ip->ss_count <= 0 and $ip->dir_reverse, debug
("no SOSS available\n"), return;
693 # Transfering values.
694 debug
( "transfering values\n" );
695 $ip->ss_transfer( $ip->spop );
702 =head2 Funge-space storage
711 my $ip = $lbi->get_curip;
713 # Fetching coordinates.
714 my ($v) = $ip->spop_vec;
715 $v += $ip->get_storage;
718 my $val = $lbi->get_storage->get_value( $v );
721 debug
( "fetching value at $v: pushing $val\n" );
730 my $ip = $lbi->get_curip;
732 # Fetching coordinates.
733 my ($v) = $ip->spop_vec;
734 $v += $ip->get_storage;
738 $lbi->get_storage->set_value( $v, $val );
740 debug
( "storing value $val at $v\n" );
747 =head2 Standard Input/Output
751 =item stdio_out_num( )
756 my $ip = $lbi->get_curip;
758 # Fetch value and print it.
760 debug
( "numeric output: $val\n");
761 print( "$val " ) or $ip->dir_reverse;
765 =item stdio_out_ascii( )
768 sub stdio_out_ascii
{
770 my $ip = $lbi->get_curip;
772 # Fetch value and print it.
775 debug
( "ascii output: '$chr' (ord=$val)\n");
776 print( $chr ) or $ip->dir_reverse;
780 =item stdio_in_num( )
785 my $ip = $lbi->get_curip;
786 my ($in, $nb) = ('', 0);
789 my $char = $lbi->get_input();
790 $in .= $char if defined $char;
792 ($nb, $overflow) = $in =~ /(-?\d+)(\D*)$/;
793 if((defined($overflow) && length($overflow)) || !defined($char)) {
794 # either we found a non-digit character: $overflow
795 # or else we reached EOF: !$char
796 return $ip->dir_reverse() unless defined $nb;
797 $nb < -2**31 and $nb = -2**31;
798 $nb > 2**31-1 and $nb = 2**31-1;
803 $lbi->set_input( $in );
805 debug
( "numeric input: pushing $nb\n" );
809 =item stdio_in_ascii( )
814 my $ip = $lbi->get_curip;
815 my $in = $lbi->get_input();
816 return $ip->dir_reverse unless defined $in;
819 debug
( "ascii input: pushing $ord\n" );
823 =item stdio_in_file( )
828 my $ip = $lbi->get_curip;
831 my $path = $ip->spop_gnirts;
832 my $flag = $ip->spop;
833 my ($vin) = $ip->spop_vec;
834 $vin += $ip->get_storage;
837 debug
( "input file '$path' at $vin\n" );
838 open F
, "<", $path or $ip->dir_reverse, return;
841 local $/; # slurp mode.
846 # Store the code and the result vector.
847 my ($size) = $flag % 2
848 ?
( $lbi->get_storage->store_binary( $lines, $vin ) )
849 : ( $lbi->get_storage->store( $lines, $vin ) );
850 $ip->spush_vec( $size, $vin );
854 =item stdio_out_file( )
859 my $ip = $lbi->get_curip;
862 my $path = $ip->spop_gnirts;
863 my $flag = $ip->spop;
864 my ($vin) = $ip->spop_vec;
865 $vin += $ip->get_storage;
866 my ($size) = $ip->spop_vec;
867 my $data = $lbi->get_storage->rectangle( $vin, $size );
870 my $vend = $vin + $size;
871 debug
( "output $vin-$vend to '$path'\n" );
873 # Treat the data chunk as text file?
875 $data =~ s/ +$//mg; # blank lines are now void.
876 $data =~ s/\n+\z/\n/; # final blank lines are stripped.
880 open F
, ">", $path or $ip->dir_reverse, return;
886 =item stdio_sys_exec( )
891 my $ip = $lbi->get_curip;
894 my $path = $ip->spop_gnirts;
895 debug
( "spawning external command: $path\n" );
897 $ip->spush( $?
== -1 ?
-1 : $?
>> 8 );
904 =head2 System info retrieval
913 my $ip = $lbi->get_curip;
914 my $storage = $lbi->get_storage;
920 push @infos, 0x01 # 't' is implemented.
921 | 0x02 # 'i' is implemented.
922 | 0x04 # 'o' is implemented.
923 | 0x08 # '=' is implemented.
924 | !0x10; # buffered IO (non getch).
926 # 2. number of bytes per cell.
927 # 32 bytes Funge: 4 bytes.
930 # 3. implementation handprint.
932 $handprint = $handprint * 256 + ord($_) for split //, $lbi->get_handprint;
933 push @infos, $handprint;
936 my $ver = $Language::Befunge
::VERSION
;
940 # 5. ID code for Operating Paradigm.
941 push @infos, 1; # C-language system() call behaviour.
943 # 6. Path separator character.
944 push @infos, ord( catfile
('','') );
946 # 7. Number of dimensions.
947 push @infos, $ip->get_dims;
949 # 8. Unique IP number.
950 push @infos, $ip->get_id;
952 # 9. Unique team number for the IP (NetFunge, not implemented).
955 # 10. Position of the curent IP.
956 my @pos = ( $ip->get_position->get_all_components );
959 # 11. Delta of the curent IP.
960 my @delta = ( $ip->get_delta->get_all_components );
961 push @infos, \
@delta;
963 # 12. Storage offset of the curent IP.
964 my @stor = ( $ip->get_storage->get_all_components );
967 # 13. Top-left point.
968 my $min = $storage->min;
969 # FIXME: multiple dims?
970 my @topleft = ( $min->get_component(0), $min->get_component(1) );
971 push @infos, \
@topleft;
973 # 14. Dims of the storage.
974 my $max = $storage->max;
975 # FIXME: multiple dims?
976 my @dims = ( $max->get_component(0) - $min->get_component(0),
977 $max->get_component(1) - $min->get_component(1) );
980 # 15/16. Current date/time.
981 my ($s,$m,$h,$dd,$mm,$yy)=localtime;
982 push @infos, $yy*256*256 + ($mm+1)*256 + $dd;
983 push @infos, $h*256*256 + $m*256 + $s;
985 # 17. Size of stack stack.
986 push @infos, $ip->ss_count + 1;
988 # 18. Size of each stack in the stack stack.
989 # note: the number of stack is given by previous value.
990 my @sizes = reverse $ip->ss_sizes;
991 push @infos, \
@sizes;
993 # 19. $file + params.
994 my $str = join chr(0), $lbi->get_file, @
{$lbi->get_params}, chr(0)x2
;
995 my @cmdline = reverse map { ord } split //, $str;
996 push @infos, \
@cmdline;
999 # 00EULAV=EMAN0EULAV=EMAN
1001 $str .= "$_=$ENV{$_}".chr(0) foreach sort keys %ENV;
1003 my @env = reverse map { ord } split //, $str;
1006 my @cells = map { ref($_) eq 'ARRAY' ?
(@
$_) : ($_) } reverse @infos;
1008 # Okay, what to do with those cells.
1010 # Blindly push them onto the stack.
1011 debug
( "system info: pushing the whole stuff\n" );
1014 } elsif ( $val <= scalar(@cells) ) {
1015 # Only push the wanted value.
1016 debug
( "system info: pushing the ${val}th value\n" );
1017 $ip->spush( $cells[$#cells-$val+1] );
1020 # Pick a given value in the stack and push it.
1021 my $offset = $val - $#cells - 1;
1022 my $value = $ip->svalue($offset);
1023 debug
( "system info: picking the ${offset}th value from the stack = $value\n" );
1024 $ip->spush( $value );
1032 =head2 Concurrent Funge
1043 debug
( "spawning new IP\n" );
1045 # Cloning and storing new IP.
1046 my $newip = $lbi->get_curip->clone;
1047 $newip->dir_reverse;
1048 $lbi->move_ip($newip);
1049 push @
{ $lbi->get_newips }, $newip;
1056 =head2 Library semantics
1065 my $ip = $lbi->get_curip;
1067 # Fetching fingerprint.
1068 my $count = $ip->spop;
1070 while ( $count-- > 0 ) {
1071 my $val = $ip->spop;
1072 $lbi->abort( "Attempt to build a fingerprint with a negative number" )
1074 $fgrprt = $fgrprt * 256 + $val;
1077 # Transform the fingerprint into a library name.
1079 my $finger = $fgrprt;
1080 while ( $finger > 0 ) {
1081 my $c = $finger % 0x100;
1083 $finger = int ( $finger / 0x100 );
1085 $lib = "Language::Befunge::lib::" . reverse $lib;
1087 # Checking if library exists.
1088 eval "require $lib";
1090 debug
( sprintf("unknown extension $lib (0x%x): reversing\n", $fgrprt) );
1093 debug
( sprintf("extension $lib (0x%x) loaded\n", $fgrprt) );
1094 my $obj = $lib->new;
1096 $ip->spush( $fgrprt, 1 );
1106 my $ip = $lbi->get_curip;
1108 # Fetching fingerprint.
1109 my $count = $ip->spop;
1111 while ( $count-- > 0 ) {
1112 my $val = $ip->spop;
1113 $lbi->abort( "Attempt to build a fingerprint with a negative number" )
1115 $fgrprt = $fgrprt * 256 + $val;
1118 # Transform the fingerprint into a library name.
1120 my $finger = $fgrprt;
1121 while ( $finger > 0 ) {
1122 my $c = $finger % 0x100;
1124 $finger = int ( $finger / 0x100 );
1126 $lib = "Language::Befunge::lib::" . reverse $lib;
1128 # Checking if library exists.
1129 eval "require $lib";
1131 debug
( sprintf("unknown extension $lib (0x%x): reversing\n", $fgrprt) );
1134 # Unload the library.
1135 debug
( sprintf("unloading library $lib (0x%x)\n", $fgrprt) );
1140 =item lib_run_instruction( )
1144 sub lib_run_instruction
{
1146 my $ip = $lbi->get_curip;
1147 my $char = $lbi->get_storage->get_char( $ip->get_position );
1149 # Maybe a library semantics.
1150 debug
( "library semantics\n" );
1151 my $stack = $ip->get_libs->{$char};
1153 if ( scalar @
$stack ) {
1154 my $obj = $stack->[-1];
1155 debug
( "library semantics processed by ".ref($obj)."\n" );
1156 $obj->$char( $lbi );
1158 # Non-overloaded capitals default to reverse.
1159 debug
("no library semantics found: reversing\n");
1174 L<Language::Befunge>
1179 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
1181 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
1184 =head1 COPYRIGHT & LICENSE
1186 Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
1188 This program is free software; you can redistribute it and/or modify
1189 it under the same terms as Perl itself.