2 # This file is part of Language::Befunge.
3 # Copyright (c) 2001-2008 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.
21 Language::Befunge::Ops - definition of the various operations
26 This module implements the various befunge operations. Not all those
27 operations will be supported by the interpreter though, it will depend
28 on the type of befunge chosen.
37 =item num_push_number( )
39 Push the current number onto the TOSS.
46 my $ip = $lbi->get_curip;
47 my $num = hex( chr( $lbi->storage->get_value( $ip->get_position ) ) );
53 $lbi->debug( "pushing number '$num'\n" );
64 =item str_enter_string_mode( )
67 sub str_enter_string_mode
{
71 $lbi->debug( "entering string mode\n" );
73 # Entering string-mode.
74 $lbi->get_curip->set_string_mode(1);
78 =item str_fetch_char( )
83 my $ip = $lbi->get_curip;
86 $lbi->move_ip($lbi->get_curip);
88 # .. then fetch value and push it.
89 my $ord = $lbi->storage->get_value( $ip->get_position );
90 my $chr = $lbi->storage->get_char( $ip->get_position );
94 $lbi->debug( "pushing value $ord (char='$chr')\n" );
98 =item str_store_char( )
103 my $ip = $lbi->get_curip;
106 $lbi->move_ip($lbi->get_curip);
112 $lbi->storage->set_value( $ip->get_position, $val );
113 my $chr = $lbi->storage->get_char( $ip->get_position );
116 $lbi->debug( "storing value $val (char='$chr')\n" );
123 =head2 Mathematical operations
127 =item math_addition( )
132 my $ip = $lbi->get_curip;
135 my ($v1, $v2) = $ip->spop_mult(2);
136 $lbi->debug( "adding: $v1+$v2\n" );
139 # Checking over/underflow.
140 $res > 2**31-1 and $lbi->abort( "program overflow while performing addition" );
141 $res < -2**31 and $lbi->abort( "program underflow while performing addition" );
148 =item math_substraction( )
151 sub math_substraction
{
153 my $ip = $lbi->get_curip;
156 my ($v1, $v2) = $ip->spop_mult(2);
157 $lbi->debug( "substracting: $v1-$v2\n" );
160 # checking over/underflow.
161 $res > 2**31-1 and $lbi->abort( "program overflow while performing substraction" );
162 $res < -2**31 and $lbi->abort( "program underflow while performing substraction" );
169 =item math_multiplication( )
172 sub math_multiplication
{
174 my $ip = $lbi->get_curip;
177 my ($v1, $v2) = $ip->spop_mult(2);
178 $lbi->debug( "multiplicating: $v1*$v2\n" );
181 # checking over/underflow.
182 $res > 2**31-1 and $lbi->abort( "program overflow while performing multiplication" );
183 $res < -2**31 and $lbi->abort( "program underflow while performing multiplication" );
190 =item math_division( )
195 my $ip = $lbi->get_curip;
198 my ($v1, $v2) = $ip->spop_mult(2);
199 $lbi->debug( "dividing: $v1/$v2\n" );
200 my $res = $v2 == 0 ?
0 : int($v1 / $v2);
202 # Can't do over/underflow with integer division.
209 =item math_remainder( )
214 my $ip = $lbi->get_curip;
217 my ($v1, $v2) = $ip->spop_mult(2);
218 $lbi->debug( "remainder: $v1%$v2\n" );
219 my $res = $v2 == 0 ?
0 : int($v1 % $v2);
221 # Can't do over/underflow with integer remainder.
231 =head2 Direction changing
240 $lbi->debug( "going east\n" );
241 $lbi->get_curip->dir_go_east;
250 $lbi->debug( "going west\n" );
251 $lbi->get_curip->dir_go_west;
255 =item dir_go_north( )
260 $lbi->debug( "going north\n" );
261 $lbi->get_curip->dir_go_north;
265 =item dir_go_south( )
270 $lbi->debug( "going south\n" );
271 $lbi->get_curip->dir_go_south;
280 $lbi->debug( "going high\n" );
281 $lbi->get_curip->dir_go_high;
290 $lbi->debug( "going low\n" );
291 $lbi->get_curip->dir_go_low;
300 $lbi->debug( "going away!\n" );
301 $lbi->get_curip->dir_go_away;
305 =item dir_turn_left( )
307 Turning left, like a car (the specs speak about a bicycle, but perl
308 is _so_ fast that we can speak about cars ;) ).
313 $lbi->debug( "turning on the left\n" );
314 $lbi->get_curip->dir_turn_left;
318 =item dir_turn_right( )
320 Turning right, like a car (the specs speak about a bicycle, but perl
321 is _so_ fast that we can speak about cars ;) ).
326 $lbi->debug( "turning on the right\n" );
327 $lbi->get_curip->dir_turn_right;
336 $lbi->debug( "180 deg!\n" );
337 $lbi->get_curip->dir_reverse;
341 =item dir_set_delta( )
343 Hmm, the user seems to know where he wants to go. Let's trust him/her.
348 my $ip = $lbi->get_curip;
349 my ($new_d) = $ip->spop_vec;
350 $lbi->debug( "setting delta to $new_d\n" );
351 $ip->set_delta( $new_d );
358 =head2 Decision making
367 my $ip = $lbi->get_curip;
370 my $val = $ip->spop ?
0 : 1;
373 $lbi->debug( "logical not: pushing $val\n" );
382 my $ip = $lbi->get_curip;
385 my ($v1, $v2) = $ip->spop_mult(2);
386 $lbi->debug( "comparing $v1 vs $v2\n" );
387 $ip->spush( ($v1 > $v2) ?
1 : 0 );
391 =item decis_horiz_if( )
396 my $ip = $lbi->get_curip;
400 $val ?
$ip->dir_go_west : $ip->dir_go_east;
401 $lbi->debug( "horizontal if: going " . ( $val ?
"west\n" : "east\n" ) );
405 =item decis_vert_if( )
410 my $ip = $lbi->get_curip;
414 $val ?
$ip->dir_go_north : $ip->dir_go_south;
415 $lbi->debug( "vertical if: going " . ( $val ?
"north\n" : "south\n" ) );
424 my $ip = $lbi->get_curip;
428 $val ?
$ip->dir_go_low : $ip->dir_go_high;
429 $lbi->debug( "z if: going " . ( $val ?
"low\n" : "high\n" ) );
438 my $ip = $lbi->get_curip;
441 my ($v1, $v2) = $ip->spop_mult(2);
442 $lbi->debug( "comparing $v1 with $v2: straight forward!\n"), return if $v1 == $v2;
452 $lbi->debug( "comparing $v1 with $v2: turning: $dir\n" );
465 A serie of spaces is to be treated as B<one> NO-OP.
470 $lbi->move_ip( $lbi->get_curip, qr/ / );
471 $lbi->debug( "slurping serie of spaces\n" );
480 $lbi->debug( "no-op\n" );
484 =item flow_comments( )
486 Bypass comments in one tick.
491 $lbi->move_ip($lbi->get_curip);
492 $lbi->move_ip($lbi->get_curip, qr/[^;]/);
493 $lbi->move_ip($lbi->get_curip);
494 $lbi->debug( "skipping comments\n" );
498 =item flow_trampoline( )
501 sub flow_trampoline
{
503 $lbi->move_ip($lbi->get_curip);
504 $lbi->debug( "trampoline! (skipping next instruction)\n" );
508 =item flow_jump_to( )
513 my $ip = $lbi->get_curip;
514 my $count = $ip->spop;
515 $lbi->debug( "skipping $count instructions\n" );
516 $count == 0 and return;
517 $count < 0 and $ip->dir_reverse; # We can move backward.
518 $lbi->move_ip($lbi->get_curip) for (1..abs($count));
519 $count < 0 and $ip->dir_reverse;
528 my $ip = $lbi->get_curip;
530 my $kcounter = $ip->spop;
531 $lbi->debug( "repeating next instruction $kcounter times.\n" );
532 $lbi->move_ip($lbi->get_curip);
535 $kcounter == 0 and return;
538 $kcounter < 0 and $lbi->abort( "Attempt to repeat ('k') a negative number of times ($kcounter)" );
540 # Fetch instruction to repeat.
541 my $val = $lbi->storage->get_value( $ip->get_position );
543 # Check if we can repeat the instruction.
544 $val > 0 and $val < 256 and chr($val) =~ /([ ;k])/ and return;
546 $lbi->process_ip(0) for (1..$kcounter);
550 =item flow_kill_thread( )
553 sub flow_kill_thread
{
555 $lbi->debug( "end of Instruction Pointer\n" );
556 $lbi->get_curip->set_end('@');
565 $lbi->debug( "end program\n" );
566 $lbi->set_newips( [] );
568 $lbi->get_curip->set_end('q');
569 $lbi->set_retval( $lbi->get_curip->spop );
576 =head2 Stack manipulation
585 $lbi->debug( "popping a value\n" );
586 $lbi->get_curip->spop;
590 =item stack_duplicate( )
593 sub stack_duplicate
{
595 my $ip = $lbi->get_curip;
596 my $value = $ip->spop;
597 $lbi->debug( "duplicating value '$value'\n" );
598 $ip->spush( $value );
599 $ip->spush( $value );
608 my $ ip
= $lbi->get_curip;
609 my ($v1, $v2) = $ip->spop_mult(2);
610 $lbi->debug( "swapping $v1 and $v2\n" );
621 $lbi->debug( "clearing stack\n" );
622 $lbi->get_curip->sclear;
629 =head2 Stack stack manipulation
638 my $ip = $lbi->get_curip;
639 $lbi->debug( "block opening\n" );
642 $ip->ss_create( $ip->spop );
644 # Store current storage offset on SOSS.
645 $ip->soss_push( $ip->get_storage->get_all_components );
647 # Set the new Storage Offset.
648 $lbi->move_ip($lbi->get_curip);
649 $ip->set_storage( $ip->get_position );
651 $lbi->move_ip($lbi->get_curip);
661 my $ip = $lbi->get_curip;
664 $ip->ss_count <= 0 and $ip->dir_reverse, $lbi->debug("no opened block\n"), return;
666 $lbi->debug( "block closing\n" );
668 # Restore Storage offset.
669 $ip->set_storage( $ip->soss_pop_vec );
672 $ip->ss_remove( $ip->spop );
676 =item bloc_transfer( )
681 my $ip = $lbi->get_curip;
683 $ip->ss_count <= 0 and $ip->dir_reverse, $lbi->debug("no SOSS available\n"), return;
685 # Transfering values.
686 $lbi->debug( "transfering values\n" );
687 $ip->ss_transfer( $ip->spop );
694 =head2 Funge-space storage
703 my $ip = $lbi->get_curip;
705 # Fetching coordinates.
706 my ($v) = $ip->spop_vec;
707 $v += $ip->get_storage;
710 my $val = $lbi->storage->get_value( $v );
713 $lbi->debug( "fetching value at $v: pushing $val\n" );
722 my $ip = $lbi->get_curip;
724 # Fetching coordinates.
725 my ($v) = $ip->spop_vec;
726 $v += $ip->get_storage;
730 $lbi->storage->set_value( $v, $val );
732 $lbi->debug( "storing value $val at $v\n" );
739 =head2 Standard Input/Output
743 =item stdio_out_num( )
748 my $ip = $lbi->get_curip;
750 # Fetch value and print it.
752 $lbi->debug( "numeric output: $val\n");
753 print( "$val " ) or $ip->dir_reverse;
757 =item stdio_out_ascii( )
760 sub stdio_out_ascii
{
762 my $ip = $lbi->get_curip;
764 # Fetch value and print it.
767 $lbi->debug( "ascii output: '$chr' (ord=$val)\n");
768 print( $chr ) or $ip->dir_reverse;
772 =item stdio_in_num( )
777 my $ip = $lbi->get_curip;
778 my ($in, $nb) = ('', 0);
781 my $char = $lbi->get_input();
782 $in .= $char if defined $char;
784 ($nb, $overflow) = $in =~ /(-?\d+)(\D*)$/;
785 if((defined($overflow) && length($overflow)) || !defined($char)) {
786 # either we found a non-digit character: $overflow
787 # or else we reached EOF: !$char
788 return $ip->dir_reverse() unless defined $nb;
789 $nb < -2**31 and $nb = -2**31;
790 $nb > 2**31-1 and $nb = 2**31-1;
795 $lbi->set_input( $in );
797 $lbi->debug( "numeric input: pushing $nb\n" );
801 =item stdio_in_ascii( )
806 my $ip = $lbi->get_curip;
807 my $in = $lbi->get_input();
808 return $ip->dir_reverse unless defined $in;
811 $lbi->debug( "ascii input: pushing $ord\n" );
815 =item stdio_in_file( )
820 my $ip = $lbi->get_curip;
823 my $path = $ip->spop_gnirts;
824 my $flag = $ip->spop;
825 my ($vin) = $ip->spop_vec;
826 $vin += $ip->get_storage;
829 $lbi->debug( "input file '$path' at $vin\n" );
830 open F
, "<", $path or $ip->dir_reverse, return;
833 local $/; # slurp mode.
838 # Store the code and the result vector.
839 my ($size) = $flag % 2
840 ?
( $lbi->storage->store_binary( $lines, $vin ) )
841 : ( $lbi->storage->store( $lines, $vin ) );
842 $ip->spush_vec( $size, $vin );
846 =item stdio_out_file( )
851 my $ip = $lbi->get_curip;
854 my $path = $ip->spop_gnirts;
855 my $flag = $ip->spop;
856 my ($vin) = $ip->spop_vec;
857 $vin += $ip->get_storage;
858 my ($size) = $ip->spop_vec;
859 my $data = $lbi->storage->rectangle( $vin, $size );
862 my $vend = $vin + $size;
863 $lbi->debug( "output $vin-$vend to '$path'\n" );
865 # Treat the data chunk as text file?
867 $data =~ s/ +$//mg; # blank lines are now void.
868 $data =~ s/\n+\z/\n/; # final blank lines are stripped.
872 open F
, ">", $path or $ip->dir_reverse, return;
878 =item stdio_sys_exec( )
883 my $ip = $lbi->get_curip;
886 my $path = $ip->spop_gnirts;
887 $lbi->debug( "spawning external command: $path\n" );
889 $ip->spush( $?
== -1 ?
-1 : $?
>> 8 );
896 =head2 System info retrieval
905 my $ip = $lbi->get_curip;
906 my $storage = $lbi->storage;
912 push @cells, 0x01 # 't' is implemented.
913 | 0x02 # 'i' is implemented.
914 | 0x04 # 'o' is implemented.
915 | 0x08 # '=' is implemented.
916 | !0x10; # buffered IO (non getch).
918 # 2. number of bytes per cell.
919 # 32 bytes Funge: 4 bytes.
922 # 3. implementation handprint.
924 $handprint = $handprint * 256 + ord($_) for split //, $lbi->get_handprint;
925 push @cells, $handprint;
928 my $ver = $Language::Befunge
::VERSION
;
932 # 5. ID code for Operating Paradigm.
933 push @cells, 1; # C-language system() call behaviour.
935 # 6. Path separator character.
936 push @cells, ord( catfile
('','') );
938 # 7. Number of dimensions.
939 push @cells, $ip->get_dims;
941 # 8. Unique IP number.
942 push @cells, $ip->get_id;
944 # 9. Unique team number for the IP (NetFunge, not implemented).
947 # 10. Position of the curent IP.
948 my @pos = ( $ip->get_position->get_all_components );
951 # 11. Delta of the curent IP.
952 my @delta = ( $ip->get_delta->get_all_components );
953 push @cells, \
@delta;
955 # 12. Storage offset of the curent IP.
956 my @stor = ( $ip->get_storage->get_all_components );
959 # 13. Top-left point.
960 my $min = $storage->min;
961 # FIXME: multiple dims?
962 my @topleft = ( $min->get_component(0), $min->get_component(1) );
963 push @cells, \
@topleft;
965 # 14. Dims of the storage.
966 my $max = $storage->max;
967 # FIXME: multiple dims?
968 my @dims = ( $max->get_component(0) - $min->get_component(0),
969 $max->get_component(1) - $min->get_component(1) );
972 # 15/16. Current date/time.
973 my ($s,$m,$h,$dd,$mm,$yy)=localtime;
974 push @cells, $yy*256*256 + $mm*256 + $dd;
975 push @cells, $h*256*256 + $m*256 + $s;
977 # 17. Size of stack stack.
978 push @cells, $ip->ss_count + 1;
980 # 18. Size of each stack in the stack stack.
981 # !!FIXME!! Funge specs just tell to push onto the
982 # stack the size of the stacks, but nothing is
983 # said about how user will retrieve the number of
985 my @sizes = reverse $ip->ss_sizes;
986 push @cells, \
@sizes;
988 # 19. $file + params.
989 my $str = join chr(0), $lbi->get_file, @
{$lbi->get_params}, chr(0)x2
;
990 my @cmdline = reverse map { ord } split //, $str;
991 push @cells, \
@cmdline;
994 # 00EULAV=EMAN0EULAV=EMAN
996 $str .= "$_=$ENV{$_}".chr(0) foreach sort keys %ENV;
998 my @env = reverse map { ord } split //, $str;
1001 # Okay, what to do with those cells.
1003 # Blindly push them onto the stack.
1004 $lbi->debug( "system info: pushing the whole stuff\n" );
1005 foreach my $cell ( reverse @cells ) {
1006 $ip->spush( ref( $cell ) eq "ARRAY" ?
1010 } elsif ( $val <= 20 ) {
1011 # Only push the wanted value.
1012 $lbi->debug( "system info: pushing the ${val}th value\n" );
1013 $ip->spush( ref( $cells[$val-1] ) eq "ARRAY" ?
1014 @
{ $cells[$val-1] } : $cells[$val-1] );
1017 # Pick a given value in the stack and push it.
1018 my $offset = $val - 20;
1019 my $value = $ip->svalue($offset);
1020 $lbi->debug( "system info: picking the ${offset}th value from the stack = $value\n" );
1021 $ip->spush( $value );
1029 =head2 Concurrent Funge
1040 $lbi->debug( "spawning new IP\n" );
1042 # Cloning and storing new IP.
1043 my $newip = $lbi->get_curip->clone;
1044 $newip->dir_reverse;
1045 $lbi->move_ip($newip);
1046 push @
{ $lbi->get_newips }, $newip;
1053 =head2 Library semantics
1062 my $ip = $lbi->get_curip;
1064 # Fetching fingerprint.
1065 my $count = $ip->spop;
1067 while ( $count-- > 0 ) {
1068 my $val = $ip->spop;
1069 $lbi->abort( "Attempt to build a fingerprint with a negative number" )
1071 $fgrprt = $fgrprt * 256 + $val;
1074 # Transform the fingerprint into a library name.
1076 my $finger = $fgrprt;
1077 while ( $finger > 0 ) {
1078 my $c = $finger % 0x100;
1080 $finger = int ( $finger / 0x100 );
1082 $lib = "Language::Befunge::lib::" . reverse $lib;
1084 # Checking if library exists.
1085 eval "require $lib";
1087 $lbi->debug( sprintf("unknown extension $lib (0x%x): reversing\n", $fgrprt) );
1090 $lbi->debug( sprintf("extension $lib (0x%x) loaded\n", $fgrprt) );
1093 $ip->spush( $fgrprt, 1 );
1103 my $ip = $lbi->get_curip;
1105 # Fetching fingerprint.
1106 my $count = $ip->spop;
1108 while ( $count-- > 0 ) {
1109 my $val = $ip->spop;
1110 $lbi->abort( "Attempt to build a fingerprint with a negative number" )
1112 $fgrprt = $fgrprt * 256 + $val;
1115 # Transform the fingerprint into a library name.
1117 my $finger = $fgrprt;
1118 while ( $finger > 0 ) {
1119 my $c = $finger % 0x100;
1121 $finger = int ( $finger / 0x100 );
1123 $lib = "Language::Befunge::lib::" . reverse $lib;
1125 # Unload the library.
1126 if ( defined( $ip->unload($lib) ) ) {
1127 $lbi->debug( sprintf("unloading library $lib (0x%x)\n", $fgrprt) );
1129 # The library wasn't loaded.
1130 $lbi->debug( sprintf("library $lib (0x%x) wasn't loaded\n", $fgrprt) );
1135 =item lib_run_instruction( )
1139 sub lib_run_instruction
{
1141 my $ip = $lbi->get_curip;
1142 my $char = $lbi->storage->get_char( $ip->get_position );
1144 # Maybe a library semantics.
1145 $lbi->debug( "library semantics\n" );
1147 foreach my $obj ( @
{ $ip->get_libs } ) {
1148 # Try the loaded libraries in order.
1149 eval "\$obj->$char(\$lbi)";
1151 $lbi->debug( ref($obj) . "->$char failed: $@" );
1155 # We manage to get a library.
1156 $lbi->debug( "library semantics processed by ".ref($obj)."\n" );
1160 # Non-overloaded capitals default to reverse.
1161 $lbi->debug("no library semantics found: reversing\n");
1175 L<Language::Befunge>
1180 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
1182 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
1185 =head1 COPYRIGHT & LICENSE
1187 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
1189 This program is free software; you can redistribute it and/or modify
1190 it under the same terms as Perl itself.