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 Config
; # 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 # don't forget that runloop will advance the ip next time.
520 $count < 0 and $lbi->move_ip($lbi->get_curip), $ip->dir_reverse;
529 my $ip = $lbi->get_curip;
531 my $kcounter = $ip->spop;
532 $lbi->debug( "repeating next instruction $kcounter times.\n" );
533 $lbi->move_ip($lbi->get_curip);
536 $kcounter == 0 and return;
539 $kcounter < 0 and $lbi->abort( "Attempt to repeat ('k') a negative number of times ($kcounter)" );
541 # Fetch instruction to repeat.
542 my $val = $lbi->storage->get_value( $ip->get_position );
544 # Check if we can repeat the instruction.
545 $val > 0 and $val < 256 and chr($val) =~ /([ ;])/ and
546 $lbi->abort( "Attempt to repeat ('k') a forbidden instruction ('$1')" );
547 $val > 0 and $val < 256 and chr($val) eq "k" and
548 $lbi->abort( "Attempt to repeat ('k') a repeat instruction ('k')" );
550 $lbi->process_ip(0) for (1..$kcounter);
554 =item flow_kill_thread( )
557 sub flow_kill_thread
{
559 $lbi->debug( "end of Instruction Pointer\n" );
560 $lbi->get_curip->set_end('@');
569 $lbi->debug( "end program\n" );
570 $lbi->set_newips( [] );
572 $lbi->get_curip->set_end('q');
573 $lbi->set_retval( $lbi->get_curip->spop );
580 =head2 Stack manipulation
589 $lbi->debug( "popping a value\n" );
590 $lbi->get_curip->spop;
594 =item stack_duplicate( )
597 sub stack_duplicate
{
599 my $ip = $lbi->get_curip;
600 my $value = $ip->spop;
601 $lbi->debug( "duplicating value '$value'\n" );
602 $ip->spush( $value );
603 $ip->spush( $value );
612 my $ ip
= $lbi->get_curip;
613 my ($v1, $v2) = $ip->spop_mult(2);
614 $lbi->debug( "swapping $v1 and $v2\n" );
625 $lbi->debug( "clearing stack\n" );
626 $lbi->get_curip->sclear;
633 =head2 Stack stack manipulation
642 my $ip = $lbi->get_curip;
643 $lbi->debug( "block opening\n" );
646 $ip->ss_create( $ip->spop );
648 # Store current storage offset on SOSS.
649 $ip->soss_push( $ip->get_storage->get_all_components );
651 # Set the new Storage Offset.
652 $lbi->move_ip($lbi->get_curip);
653 $ip->set_storage( $ip->get_position );
655 $lbi->move_ip($lbi->get_curip);
665 my $ip = $lbi->get_curip;
668 $ip->ss_count <= 0 and $ip->dir_reverse, $lbi->debug("no opened block\n"), return;
670 $lbi->debug( "block closing\n" );
672 # Restore Storage offset.
673 $ip->set_storage( $ip->soss_pop_vec );
676 $ip->ss_remove( $ip->spop );
680 =item bloc_transfer( )
685 my $ip = $lbi->get_curip;
687 $ip->ss_count <= 0 and $ip->dir_reverse, $lbi->debug("no SOSS available\n"), return;
689 # Transfering values.
690 $lbi->debug( "transfering values\n" );
691 $ip->ss_transfer( $ip->spop );
698 =head2 Funge-space storage
707 my $ip = $lbi->get_curip;
709 # Fetching coordinates.
710 my ($v) = $ip->spop_vec;
711 $v += $ip->get_storage;
714 my $val = $lbi->storage->get_value( $v );
717 $lbi->debug( "fetching value at $v: pushing $val\n" );
726 my $ip = $lbi->get_curip;
728 # Fetching coordinates.
729 my ($v) = $ip->spop_vec;
730 $v += $ip->get_storage;
734 $lbi->storage->set_value( $v, $val );
736 $lbi->debug( "storing value $val at $v\n" );
743 =head2 Standard Input/Output
747 =item stdio_out_num( )
752 my $ip = $lbi->get_curip;
754 # Fetch value and print it.
756 $lbi->debug( "numeric output: $val\n");
757 print( "$val " ) or $ip->dir_reverse;
761 =item stdio_out_ascii( )
764 sub stdio_out_ascii
{
766 my $ip = $lbi->get_curip;
768 # Fetch value and print it.
771 $lbi->debug( "ascii output: '$chr' (ord=$val)\n");
772 print( $chr ) or $ip->dir_reverse;
776 =item stdio_in_num( )
781 my $ip = $lbi->get_curip;
782 my ($in, $nb) = ('', 0);
785 my $char = $lbi->get_input();
786 $in .= $char if defined $char;
788 ($nb, $overflow) = $in =~ /(-?\d+)(\D*)$/;
789 if((defined($overflow) && length($overflow)) || !defined($char)) {
790 # either we found a non-digit character: $overflow
791 # or else we reached EOF: !$char
792 return $ip->dir_reverse() unless defined $nb;
793 $nb < -2**31 and $nb = -2**31;
794 $nb > 2**31-1 and $nb = 2**31-1;
799 $lbi->set_input( $in );
801 $lbi->debug( "numeric input: pushing $nb\n" );
805 =item stdio_in_ascii( )
810 my $ip = $lbi->get_curip;
811 my $in = $lbi->get_input();
812 return $ip->dir_reverse unless defined $in;
815 $lbi->debug( "ascii input: pushing $ord\n" );
819 =item stdio_in_file( )
824 my $ip = $lbi->get_curip;
827 my $path = $ip->spop_gnirts;
828 my $flag = $ip->spop;
829 my ($vin) = $ip->spop_vec;
830 $vin += $ip->get_storage;
833 $lbi->debug( "input file '$path' at $vin\n" );
834 open F
, "<", $path or $ip->dir_reverse, return;
837 local $/; # slurp mode.
842 # Store the code and the result vector.
843 my ($size) = $flag % 2
844 ?
( $lbi->storage->store_binary( $lines, $vin ) )
845 : ( $lbi->storage->store( $lines, $vin ) );
846 $ip->spush_vec( $size, $vin );
850 =item stdio_out_file( )
855 my $ip = $lbi->get_curip;
858 my $path = $ip->spop_gnirts;
859 my $flag = $ip->spop;
860 my ($vin) = $ip->spop_vec;
861 $vin += $ip->get_storage;
862 my ($size) = $ip->spop_vec;
863 my $data = $lbi->storage->rectangle( $vin, $size );
866 my $vend = $vin + $size;
867 $lbi->debug( "output $vin-$vend to '$path'\n" );
869 # Treat the data chunk as text file?
871 $data =~ s/ +$//mg; # blank lines are now void.
872 $data =~ s/\n+\z/\n/; # final blank lines are stripped.
876 open F
, ">", $path or $ip->dir_reverse, return;
882 =item stdio_sys_exec( )
887 my $ip = $lbi->get_curip;
890 my $path = $ip->spop_gnirts;
891 $lbi->debug( "spawning external command: $path\n" );
893 $ip->spush( $?
== -1 ?
-1 : $?
>> 8 );
900 =head2 System info retrieval
909 my $ip = $lbi->get_curip;
910 my $storage = $lbi->storage;
916 push @cells, 0x01 # 't' is implemented.
917 | 0x02 # 'i' is implemented.
918 | 0x04 # 'o' is implemented.
919 | 0x08 # '=' is implemented.
920 | !0x10; # buffered IO (non getch).
922 # 2. number of bytes per cell.
923 # 32 bytes Funge: 4 bytes.
926 # 3. implementation handprint.
927 my @hand = reverse map { ord } split //, $lbi->get_handprint . chr(0);
931 my $ver = $Language::Befunge
::VERSION
;
935 # 5. ID code for Operating Paradigm.
936 push @cells, 1; # C-language system() call behaviour.
938 # 6. Path separator character.
939 push @cells, ord( $Config{path_sep
} );
941 # 7. Number of dimensions.
942 push @cells, $ip->get_dims;
944 # 8. Unique IP number.
945 push @cells, $ip->get_id;
947 # 9. Concurrent Funge (not implemented).
950 # 10. Position of the curent IP.
951 my @pos = ( $ip->get_position->get_all_components );
954 # 11. Delta of the curent IP.
955 my @delta = ( $ip->get_delta->get_all_components );
956 push @cells, \
@delta;
958 # 12. Storage offset of the curent IP.
959 my @stor = ( $ip->get_storage->get_all_components );
962 # 13. Top-left point.
963 my $min = $storage->min;
964 # FIXME: multiple dims?
965 my @topleft = ( $min->get_component(0), $min->get_component(1) );
966 push @cells, \
@topleft;
968 # 14. Dims of the storage.
969 my $max = $storage->max;
970 # FIXME: multiple dims?
971 my @dims = ( $max->get_component(0) - $min->get_component(0) + 1,
972 $max->get_component(1) - $min->get_component(1) + 1 );
975 # 15/16. Current date/time.
976 my ($s,$m,$h,$dd,$mm,$yy)=localtime;
977 push @cells, $yy*256*256 + $mm*256 + $dd;
978 push @cells, $h*256*256 + $m*256 + $s;
980 # 17. Size of stack stack.
981 push @cells, $ip->ss_count + 1;
983 # 18. Size of each stack in the stack stack.
984 # !!FIXME!! Funge specs just tell to push onto the
985 # stack the size of the stacks, but nothing is
986 # said about how user will retrieve the number of
988 my @sizes = reverse $ip->ss_sizes;
989 push @cells, \
@sizes;
991 # 19. $file + params.
992 my $str = join chr(0), $lbi->get_file, @
{$lbi->get_params}, chr(0);
993 my @cmdline = reverse map { ord } split //, $str;
994 push @cells, \
@cmdline;
997 # 00EULAV=EMAN0EULAV=EMAN
999 $str .= "$_=$ENV{$_}".chr(0) foreach sort keys %ENV;
1001 my @env = reverse map { ord } split //, $str;
1004 # Okay, what to do with those cells.
1006 # Blindly push them onto the stack.
1007 $lbi->debug( "system info: pushing the whole stuff\n" );
1008 foreach my $cell ( reverse @cells ) {
1009 $ip->spush( ref( $cell ) eq "ARRAY" ?
1013 } elsif ( $val <= 20 ) {
1014 # Only push the wanted value.
1015 $lbi->debug( "system info: pushing the ${val}th value\n" );
1016 $ip->spush( ref( $cells[$val-1] ) eq "ARRAY" ?
1017 @
{ $cells[$val-1] } : $cells[$val-1] );
1020 # Pick a given value in the stack and push it.
1021 my $offset = $val - 20;
1022 my $value = $ip->svalue($offset);
1023 $lbi->debug( "system info: picking the ${offset}th value from the stack = $value\n" );
1024 $ip->spush( $value );
1032 =head2 Concurrent Funge
1043 $lbi->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 $lbi->debug( sprintf("unknown extension $lib (0x%x): reversing\n", $fgrprt) );
1093 $lbi->debug( sprintf("extension $lib (0x%x) loaded\n", $fgrprt) );
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 # Unload the library.
1129 if ( defined( $ip->unload($lib) ) ) {
1130 $lbi->debug( sprintf("unloading library $lib (0x%x)\n", $fgrprt) );
1132 # The library wasn't loaded.
1133 $lbi->debug( sprintf("library $lib (0x%x) wasn't loaded\n", $fgrprt) );
1138 =item lib_run_instruction( )
1142 sub lib_run_instruction
{
1144 my $ip = $lbi->get_curip;
1145 my $char = $lbi->storage->get_char( $ip->get_position );
1147 # Maybe a library semantics.
1148 $lbi->debug( "library semantics\n" );
1150 foreach my $obj ( @
{ $ip->get_libs } ) {
1151 # Try the loaded libraries in order.
1152 eval "\$obj->$char(\$lbi)";
1154 $lbi->debug( ref($obj) . "->$char failed: $@" );
1158 # We manage to get a library.
1159 $lbi->debug( "library semantics processed by ".ref($obj)."\n" );
1163 # Non-overloaded capitals default to reverse.
1164 $lbi->debug("no library semantics found: reversing\n");
1178 L<Language::Befunge>
1183 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
1185 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
1188 =head1 COPYRIGHT & LICENSE
1190 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
1192 This program is free software; you can redistribute it and/or modify
1193 it under the same terms as Perl itself.