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
::Interpreter
;
17 use Language
::Befunge
::Debug
;
18 use Language
::Befunge
::IP
;
19 use UNIVERSAL
::require;
21 # FIXME: wtf? always use get_/set_ or mutators, but not a mix of them!
24 get_dimensions
=> 'dimensions',
26 get_params
=> 'params',
27 get_retval
=> 'retval',
28 get_storage
=> 'storage',
31 get_newips
=> 'newips',
33 get_handprint
=> 'handprint',
34 get_wrapping
=> '_wrapping',
35 _get_input
=> '_input',
38 set_dimensions
=> 'dimensions',
40 set_params
=> 'params',
41 set_retval
=> 'retval',
44 set_newips
=> 'newips',
46 set_handprint
=> 'handprint',
47 _set_input
=> '_input',
51 # Public variables of the module.
59 # my $interpreter = LBI->new( $opts )
61 # Create a new funge interpreter. One can pass some options as a hash
62 # reference, with the following keys:
63 # - file: the filename to read funge code from (default: blank storage)
64 # - syntax: the tunings set (default: 'befunge98')
65 # - dims: the number of dimensions
66 # - ops: the Ops subclass used in this interpreter
67 # - storage: the Storage subclass used in this interpreter
68 # - wrapping: the Wrapping subclass used in this interpreter
70 # Usually, the "dims", "ops", "storage" and "wrapping" keys are left
71 # undefined, and are implied by the "syntax" key.
73 # Depending on the value of syntax will change the interpreter
74 # internals: set of allowed ops, storage implementation, wrapping. The
75 # following values are recognized for 'syntax' (with in order: the
76 # number of dimensions, the set of operation loaded, the storage
77 # implementation and the wrapping implementation):
79 # - unefunge98: 1, LBO:Unefunge98, LBS:Generic::AoA, LBW:LaheySpace
80 # - befunge98: 2, LBO:Befunge98, LBS:2D:Sparse, LBW:LaheySpace
81 # - trefunge98: 3, LBO:GenericFunge98, LBS:Generic::AoA, LBW:LaheySpace
82 # - 4funge98: 4, LBO:GenericFunge98, LBS:Generic::AoA, LBW:LaheySpace
83 # - 5funge98: 5, LBO:GenericFunge98, LBS:Generic::AoA, LBW:LaheySpace
87 # If none of those values suit your needs, you can pass the value
88 # 'custom' and in that case you're responsible for also giving
89 # appropriate values for the keys 'dims', 'ops', 'storage', 'wrapping'.
90 # Note that those values will be ignored for all syntax values beside
94 my ($class, $opts) = @_;
96 $opts //= { dims
=> 2 };
97 unless(exists($$opts{syntax
})) {
99 croak
("If you pass a 'dims' attribute, it must be numeric.")
100 if $$opts{dims
} =~ /\D/;
106 if(exists($defaults{$$opts{dims
}})) {
107 $$opts{syntax
} = $defaults{$$opts{dims
}};
109 $$opts{syntax
} = $$opts{dims
} . 'funge98';
113 # select the classes to use, depending on the wanted syntax.
114 my $lbo = 'Language::Befunge::Ops::';
115 my $lbs = 'Language::Befunge::Storage::';
116 my $lbw = 'Language::Befunge::Wrapping::';
117 given ( $opts->{syntax
} ) {
118 when ('unefunge98') {
119 $opts->{dims
} = 1 unless defined $opts->{dims
};
120 $opts->{ops
} = $lbo . 'Unefunge98' unless defined $opts->{ops
};
121 $opts->{storage
} = $lbs . 'Generic::AoA' unless defined $opts->{storage
};
122 $opts->{wrapping
} = $lbw . 'LaheySpace' unless defined $opts->{wrapping
};
125 $opts->{dims
} = 2 unless defined $opts->{dims
};
126 $opts->{ops
} = $lbo . 'Befunge98' unless defined $opts->{ops
};
127 $opts->{storage
} = $lbs . '2D::Sparse' unless defined $opts->{storage
};
128 $opts->{wrapping
} = $lbw . 'LaheySpace' unless defined $opts->{wrapping
};
130 when ('trefunge98') {
131 $opts->{dims
} = 3 unless defined $opts->{dims
};
132 $opts->{ops
} = $lbo . 'GenericFunge98' unless defined $opts->{ops
};
133 $opts->{storage
} = $lbs . 'Generic::AoA' unless defined $opts->{storage
};
134 $opts->{wrapping
} = $lbw . 'LaheySpace' unless defined $opts->{wrapping
};
136 when (/(\d+)funge98$/) { # accept values like "4funge98"
137 $opts->{dims
} = $1 unless defined $opts->{dims
};
138 $opts->{ops
} = $lbo . 'GenericFunge98' unless defined $opts->{ops
};
139 $opts->{storage
} = $lbs . 'Generic::AoA' unless defined $opts->{storage
};
140 $opts->{wrapping
} = $lbw . 'LaheySpace' unless defined $opts->{wrapping
};
142 default { croak
"syntax '$opts->{syntax}' not recognized." }
145 # load the classes (through UNIVERSAL::require)
147 $opts->{storage
}->use;
148 $opts->{wrapping
}->use;
151 my $wrapping = $opts->{wrapping
}->new;
153 dimensions
=> $opts->{dims
},
154 storage
=> $opts->{storage
}->new( $opts->{dims
}, Wrapping
=> $wrapping ),
160 ops
=> $opts->{ops
}->get_ops_map,
163 handprint
=> 'JQBF', # the official handprint
164 _wrapping
=> $wrapping,
168 # read the file if needed.
169 defined($opts->{file
}) and $self->read_file( $opts->{file
} );
186 # Move $ip according to its delta on the storage. Spaces and comments
187 # (enclosed with semi-colons ';') are skipped silently.
190 my ($self, $ip) = @_;
192 my $storage = $self->get_storage;
193 $self->_move_ip_once($ip);
198 my $pos = $ip->get_position;
199 $self->abort("infinite loop")
200 if exists($seen_before{$pos});
201 $seen_before{$pos} = 1;
202 $char = $storage->get_char($pos);
205 if ( $char eq ' ' ) {
206 $self->_move_ip_till( $ip, qr/ / ); # skip all spaces
207 $self->_move_ip_once($ip); # skip last space
212 if ( $char eq ';' ) {
213 $self->_move_ip_once($ip); # skip comment ';'
214 $self->_move_ip_till( $ip, qr/[^;]/ ); # till just before matching ';'
215 $self->_move_ip_once($ip); # till matching ';'
216 $self->_move_ip_once($ip); # till just after matching ';'
228 # Abort the interpreter with the given reason, as well as the current
229 # file and coordinate of the offending instruction.
233 my $file = $self->get_file;
234 my $v = $self->get_curip->get_position;
235 croak
"$file $v: ", @_;
240 # set_input( $string )
242 # Preload the input buffer with the given value.
245 my ($self, $str) = @_;
246 $self->_set_input($str);
253 # Fetch a character of input from the input buffer, or else, directly
259 return substr($$self{_input
}, 0, 1, '') if length $self->_get_input;
261 my $rv = sysread(STDIN
, $char, 1);
262 return $char if length $char;
267 # - Code and Data Storage
270 # read_file( filename )
272 # Read a file (given as argument) and store its code.
274 # Side effect: clear the previous code.
277 my ($self, $file) = @_;
281 open BF
, "<$file" or croak
"$!";
283 local $/; # slurp mode.
289 $self->set_file( $file );
290 $self->store_code( $code );
297 # Store the given code in the Lahey space.
299 # Side effect: clear the previous code.
302 my ($self, $code) = @_;
303 debug
( "Storing code\n" );
304 $self->get_storage->clear;
305 $self->get_storage->store( $code );
313 # run_code( [params] )
315 # Run the current code. That is, create a new Instruction Pointer and
316 # move it around the code.
318 # Return the exit code of the program.
322 $self->set_params( [ @_ ] );
325 debug
( "\n-= NEW RUN (".$self->get_file.") =-\n" );
327 # Create the first Instruction Pointer.
328 $self->set_ips( [ Language
::Befunge
::IP
->new($$self{dimensions
}) ] );
329 $self->set_retval(0);
331 # Loop as long as there are IPs.
332 $self->next_tick while scalar @
{ $self->get_ips };
334 # Return the exit code.
335 return $self->get_retval;
342 # Finish the current tick and stop just before the next tick.
350 # Process the set of IPs.
351 $self->set_newips( [] );
352 $self->process_ip while $self->set_curip( shift @
{ $self->get_ips } );
355 $self->set_ips( $self->get_newips );
362 # Process the current ip.
365 my ($self, $continue) = @_;
366 $continue = 1 unless defined $continue;
367 my $ip = $self->get_curip;
369 # Fetch values for this IP.
370 my $v = $ip->get_position;
371 my $ord = $self->get_storage->get_value( $v );
372 my $char = $self->get_storage->get_char( $v );
375 debug
( "#".$ip->get_id.":$v: $char (ord=$ord) Stack=(@{$ip->get_toss})\n" );
377 # Check if we are in string-mode.
378 if ( $ip->get_string_mode ) {
379 if ( $char eq '"' ) {
380 # End of string-mode.
381 debug
( "leaving string-mode\n" );
382 $ip->set_string_mode(0);
384 } elsif ( $char eq ' ' ) {
385 # A serie of spaces, to be treated as one space.
386 debug
( "string-mode: pushing char ' '\n" );
387 $self->_move_ip_till( $ip, qr/ / );
392 debug
( "string-mode: pushing char '$char'\n" );
397 $self->_do_instruction($char);
401 # Tick done for this IP, let's move it and push it in the
402 # set of non-terminated IPs.
403 if ( $ip->get_string_mode ) {
404 $self->_move_ip_once( $self->get_curip );
406 $self->move_ip( $self->get_curip );
408 push @
{ $self->get_newips }, $ip unless $ip->get_end;
415 # $lbi->_do_instruction( $char );
417 # interpret instruction $char according to loaded ops map.
419 sub _do_instruction
{
420 my ($self, $char) = @_;
422 if ( exists $self->get_ops->{$char} ) {
423 # regular instruction.
424 my $meth = $self->get_ops->{$char};
425 $meth->($self, $char);
428 # not a regular instruction: reflect.
429 my $ord = ord($char);
430 debug
( "the command value $ord (char='$char') is not implemented.\n");
431 $self->get_curip->dir_reverse;
437 # $lbi->_move_ip_once( $ip );
439 # move $ip one step further, according to its velocity. if $ip gets out
440 # of bounds, then a wrapping is performed (according to current
441 # interpreter wrapping implementation) on the ip.
444 my ($self, $ip) = @_;
445 my $storage = $self->get_storage;
447 # fetch the current position of the ip.
448 my $v = $ip->get_position;
449 my $d = $ip->get_delta;
451 # now, let's move the ip.
454 if ( $v->bounds_check($storage->min, $storage->max) ) {
455 # within bounds - store new position.
456 $ip->set_position( $v );
458 # wrap needed - this will update the position.
459 $self->get_wrapping->wrap( $storage, $ip );
465 # _move_ip_till( $ip,regex )
467 # Move $ip according to its delta on the storage, as long as the pointed
468 # character match the supplied regex (a qr// object).
470 # Example: given the code C<;foobar;> (assuming the IP points on the
471 # first C<;>) and the regex C<qr/[^;]/>, the IP will move in order to
475 my ($self, $ip, $re) = @_;
476 my $storage = $self->get_storage;
478 my $orig = $ip->get_position;
479 # moving as long as we did not reach the condition.
480 while ( $storage->get_char($ip->get_position) =~ $re ) {
481 $self->_move_ip_once($ip);
482 $self->abort("infinite loop")
483 if $ip->get_position == $orig;
486 # we moved one char too far.
488 $self->_move_ip_once($ip);
498 =head2 new( [filename, ] [ Key => Value, ... ] )
500 Create a new Befunge interpreter. As an optional first argument, you
501 can pass it a filename to read Funge code from (default: blank
502 torus). All other arguments are key=>value pairs. The following
503 keys are accepted, with their default values shown:
506 Syntax => 'befunge98',
507 Storage => 'laheyspace'
511 The following is a list of attributes of a Language::Befunge
512 object. For each of them, a method C<get_foobar> and C<set_foobar>
513 exists, which does what you can imagine - and if you can't, then i
514 wonder why you are reading this! :-)
518 =item get_curip() / set_curip()
520 the current Instruction Pointer processed (a L::B::IP object)
522 =item get_dimensions() / set_dimensions()
524 the number of dimensions this interpreter works in.
526 =item get_file() / set_file()
528 the script filename (a string)
530 =item get_handprint() / set_handprint()
532 the handprint of the interpreter
534 =item get_ips() / set_ips()
536 the current set of IPs travelling in the Lahey space (an array
539 =item get_newips() / set_newips()
541 the set of IPs that B<will> travel in the Lahey space B<after> the
542 current tick (an array reference)
544 =item get_ops() / set_ops()
546 the current supported operations set.
548 =item get_params() / set_params()
550 the parameters of the script (an array reference)
552 =item get_retval() / set_retval()
554 the current return value of the interpreter (an integer)
558 the C<LB::Storage> object containing the playfield.
562 the C<LB::Wrapping> object driving wrapping policy. Private.
567 =head1 PUBLIC METHODS
573 =item move_ip( $ip [, $regex] )
575 Move the C<$ip> according to its delta on the storage.
577 If C<$regex> ( a C<qr//> object ) is specified, then C<$ip> will move as
578 long as the pointed character match the supplied regex.
580 Example: given the code C<;foobar;> (assuming the IP points on the
581 first C<;>) and the regex C<qr/[^;]/>, the IP will move in order to
585 =item abort( reason )
587 Abort the interpreter with the given reason, as well as the current
588 file and coordinate of the offending instruction.
592 =item set_input( $string )
594 Preload the input buffer with the given value.
599 Fetch a character of input from the input buffer, or else, directly
607 =head2 Code and Data Storage
611 =item read_file( filename )
613 Read a file (given as argument) and store its code.
615 Side effect: clear the previous code.
618 =item store_code( code )
620 Store the given code in the Lahey space.
622 Side effect: clear the previous code.
633 =item run_code( [params] )
635 Run the current code. That is, create a new Instruction Pointer and
636 move it around the code.
638 Return the exit code of the program.
643 Finish the current tick and stop just before the next tick.
648 Process the current ip.
660 Write standard libraries.
667 Although this module comes with a full set of tests, maybe there are
668 subtle bugs - or maybe even I misinterpreted the Funge-98
669 specs. Please report them to me.
671 There are some bugs anyway, but they come from the specs:
677 About the 18th cell pushed by the C<y> instruction: Funge specs just
678 tell to push onto the stack the size of the stacks, but nothing is
679 said about how user will retrieve the number of stacks.
683 About the load semantics. Once a library is loaded, the interpreter is
684 to put onto the TOSS the fingerprint of the just-loaded library. But
685 nothing is said if the fingerprint is bigger than the maximum cell
686 width (here, 4 bytes). This means that libraries can't have a name
687 bigger than C<0x80000000>, ie, more than four letters with the first
688 one smaller than C<P> (C<chr(80)>).
690 Since perl is not so rigid, one can build libraries with more than
691 four letters, but perl will issue a warning about non-portability of
692 numbers greater than C<0xffffffff>.
697 =head1 ACKNOWLEDGEMENTS
699 I would like to thank Chris Pressey, creator of Befunge, who gave a
700 whole new dimension to both coding and obfuscating.
710 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
712 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
715 =head1 COPYRIGHT & LICENSE
717 Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
719 This program is free software; you can redistribute it and/or modify
720 it under the same terms as Perl itself.