lib/Language/Befunge/Interpreter.pm

   1 #
   2 # This file is part of Language::Befunge.
   3 # Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8 #
   9
  10 package Language::Befunge::Interpreter;
  11 use 5.010;
  12
  13 use strict;
  14 use warnings;
  15
  16 use Carp;
  17 use Language::Befunge::Debug;
  18 use Language::Befunge::IP;
  19 use UNIVERSAL::require;
  20
  21 # FIXME: wtf? always use get_/set_ or mutators, but not a mix of them!
  22 use Class::XSAccessor
  23     getters => {
  24         get_dimensions => 'dimensions',
  25         get_file       => 'file',
  26         get_params     => 'params',
  27         get_retval     => 'retval',
  28         get_storage    => 'storage',
  29         get_curip      => 'curip',
  30         get_ips        => 'ips',
  31         get_newips     => 'newips',
  32         get_ops        => 'ops',
  33         get_handprint  => 'handprint',
  34         get_wrapping   => '_wrapping',
  35         _get_input     => '_input',
  36     },
  37     setters => {
  38         set_dimensions => 'dimensions',
  39         set_file       => 'file',
  40         set_params     => 'params',
  41         set_retval     => 'retval',
  42         set_curip      => 'curip',
  43         set_ips        => 'ips',
  44         set_newips     => 'newips',
  45         set_ops        => 'ops',
  46         set_handprint  => 'handprint',
  47         _set_input     => '_input',
  48     };
  49
  50
  51 # Public variables of the module.
  52 $| = 1;
  53
  54
  55 # -- CONSTRUCTOR
  56
  57
  58 #
  59 # my $interpreter = LBI->new( $opts )
  60 #
  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
  69 #
  70 # Usually, the "dims", "ops", "storage" and "wrapping" keys are left
  71 # undefined, and are implied by the "syntax" key.
  72 #
  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):
  78 #
  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
  84 #  ...and so on.
  85 #
  86 #
  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
  91 # 'custom'.
  92 #
  93 sub new {
  94     my ($class, $opts) = @_;
  95
  96     $opts //= { dims => 2 };
  97     unless(exists($$opts{syntax})) {
  98         $$opts{dims} //= 2;
  99         croak("If you pass a 'dims' attribute, it must be numeric.")
 100             if $$opts{dims} =~ /\D/;
 101         my %defaults = (
 102             1 => 'unefunge98',
 103             2 => 'befunge98',
 104             3 => 'trefunge98',
 105         );
 106         if(exists($defaults{$$opts{dims}})) {
 107             $$opts{syntax} = $defaults{$$opts{dims}};
 108         } else {
 109             $$opts{syntax} = $$opts{dims} . 'funge98';
 110         }
 111     }
 112
 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};
 123         }
 124         when ('befunge98') {
 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};
 129         }
 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};
 135         }
 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};
 141         }
 142         default { croak "syntax '$opts->{syntax}' not recognized." }
 143     }
 144
 145     # load the classes (through UNIVERSAL::require)
 146     $opts->{ops}->use;
 147     $opts->{storage}->use;
 148     $opts->{wrapping}->use;
 149
 150     # create the object
 151     my $wrapping = $opts->{wrapping}->new;
 152     my $self  = {
 153         dimensions => $opts->{dims},
 154         storage    => $opts->{storage}->new( $opts->{dims}, Wrapping => $wrapping ),
 155         file       => "STDIN",
 156         _input     => '',
 157         params     => [],
 158         retval     => 0,
 159         curip      => undef,
 160         ops        => $opts->{ops}->get_ops_map,
 161         ips        => [],
 162         newips     => [],
 163         handprint  => 'JQBF', # the official handprint
 164         _wrapping  => $wrapping,
 165       };
 166     bless $self, $class;
 167
 168     # read the file if needed.
 169     defined($opts->{file}) and $self->read_file( $opts->{file} );
 170
 171     # return the object.
 172     return $self;
 173 }
 174
 175
 176
 177
 178 # -- PUBLIC METHODS
 179
 180 # - Utilities
 181
 182
 183 #
 184 # move_ip( $ip )
 185 #
 186 # Move $ip according to its delta on the storage. Spaces and comments
 187 # (enclosed with semi-colons ';') are skipped silently.
 188 #
 189 sub move_ip {
 190     my ($self, $ip) = @_;
 191
 192     my $storage = $self->get_storage;
 193     $self->_move_ip_once($ip);
 194     my $char;
 195     my %seen_before;
 196     MOVE: while (1) {
 197         # sanity check
 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);
 203
 204         # skip spaces
 205         if ( $char eq ' ' ) {
 206             $self->_move_ip_till( $ip, qr/ / );   # skip all spaces
 207             $self->_move_ip_once($ip);            # skip last space
 208             redo MOVE;
 209         }
 210
 211         # skip comments
 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 ';'
 217             redo MOVE;
 218         }
 219
 220         last MOVE;
 221     }
 222 }
 223
 224
 225 #
 226 # abort( reason )
 227 #
 228 # Abort the interpreter with the given reason, as well as the current
 229 # file and coordinate of the offending instruction.
 230 #
 231 sub abort {
 232     my $self = shift;
 233     my $file = $self->get_file;
 234     my $v = $self->get_curip->get_position;
 235     croak "$file $v: ", @_;
 236 }
 237
 238
 239 #
 240 # set_input( $string )
 241 #
 242 # Preload the input buffer with the given value.
 243 #
 244 sub set_input {
 245     my ($self, $str) = @_;
 246     $self->_set_input($str);
 247 }
 248
 249
 250 #
 251 # get_input(  )
 252 #
 253 # Fetch a character of input from the input buffer, or else, directly
 254 # from stdin.
 255 #
 256
 257 sub get_input {
 258     my $self = shift;
 259     return substr($$self{_input}, 0, 1, '') if length $self->_get_input;
 260     my $char;
 261     my $rv = sysread(STDIN, $char, 1);
 262     return $char if length $char;
 263     return undef;
 264 }
 265
 266
 267 # - Code and Data Storage
 268
 269 #
 270 # read_file( filename )
 271 #
 272 # Read a file (given as argument) and store its code.
 273 #
 274 # Side effect: clear the previous code.
 275 #
 276 sub read_file {
 277     my ($self, $file) = @_;
 278
 279     # Fetch the code.
 280     my $code;
 281     open BF, "<$file" or croak "$!";
 282     {
 283         local $/; # slurp mode.
 284         $code = <BF>;
 285     }
 286     close BF;
 287
 288     # Store code.
 289     $self->set_file( $file );
 290     $self->store_code( $code );
 291 }
 292
 293
 294 #
 295 # store_code( code )
 296 #
 297 # Store the given code in the Lahey space.
 298 #
 299 # Side effect: clear the previous code.
 300 #
 301 sub store_code {
 302     my ($self, $code) = @_;
 303     debug( "Storing code\n" );
 304     $self->get_storage->clear;
 305     $self->get_storage->store( $code );
 306 }
 307
 308
 309 # - Run methods
 310
 311
 312 #
 313 # run_code( [params]  )
 314 #
 315 # Run the current code. That is, create a new Instruction Pointer and
 316 # move it around the code.
 317 #
 318 # Return the exit code of the program.
 319 #
 320 sub run_code {
 321     my $self = shift;
 322     $self->set_params( [ @_ ] );
 323
 324     # Cosmetics.
 325     debug( "\n-= NEW RUN (".$self->get_file.") =-\n" );
 326
 327     # Create the first Instruction Pointer.
 328     $self->set_ips( [ Language::Befunge::IP->new($$self{dimensions}) ] );
 329     $self->set_retval(0);
 330
 331     # Loop as long as there are IPs.
 332     $self->next_tick while scalar @{ $self->get_ips };
 333
 334     # Return the exit code.
 335     return $self->get_retval;
 336 }
 337
 338
 339 #
 340 # next_tick(  )
 341 #
 342 # Finish the current tick and stop just before the next tick.
 343 #
 344 sub next_tick {
 345     my $self = shift;
 346
 347     # Cosmetics.
 348     debug( "Tick!\n" );
 349
 350     # Process the set of IPs.
 351     $self->set_newips( [] );
 352     $self->process_ip while $self->set_curip( shift @{ $self->get_ips } );
 353
 354     # Copy the new ips.
 355     $self->set_ips( $self->get_newips );
 356 }
 357
 358
 359 #
 360 # process_ip(  )
 361 #
 362 # Process the current ip.
 363 #
 364 sub process_ip {
 365     my ($self, $continue) = @_;
 366     $continue = 1 unless defined $continue;
 367     my $ip = $self->get_curip;
 368
 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 );
 373
 374     # Cosmetics.
 375     debug( "#".$ip->get_id.":$v: $char (ord=$ord)  Stack=(@{$ip->get_toss})\n" );
 376
 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);
 383
 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/ / );
 388             $ip->spush( $ord );
 389
 390         } else {
 391             # A banal character.
 392             debug( "string-mode: pushing char '$char'\n" );
 393             $ip->spush( $ord );
 394         }
 395
 396     } else {
 397         $self->_do_instruction($char);
 398     }
 399
 400     if ($continue) {
 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 );
 405         } else {
 406             $self->move_ip( $self->get_curip );
 407         }
 408         push @{ $self->get_newips }, $ip unless $ip->get_end;
 409     }
 410 }
 411
 412 #-- PRIVATE METHODS
 413
 414 #
 415 # $lbi->_do_instruction( $char );
 416 #
 417 # interpret instruction $char according to loaded ops map.
 418 #
 419 sub _do_instruction {
 420     my ($self, $char) = @_;
 421
 422     if ( exists $self->get_ops->{$char} ) {
 423         # regular instruction.
 424         my $meth = $self->get_ops->{$char};
 425         $meth->($self, $char);
 426
 427     } else {
 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;
 432     }
 433 }
 434
 435
 436 #
 437 # $lbi->_move_ip_once( $ip );
 438 #
 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.
 442 #
 443 sub _move_ip_once {
 444     my ($self, $ip) = @_;
 445     my $storage = $self->get_storage;
 446
 447     # fetch the current position of the ip.
 448     my $v = $ip->get_position;
 449     my $d = $ip->get_delta;
 450
 451     # now, let's move the ip.
 452     $v += $d;
 453
 454     if ( $v->bounds_check($storage->min, $storage->max) ) {
 455         # within bounds - store new position.
 456         $ip->set_position( $v );
 457     } else {
 458         # wrap needed - this will update the position.
 459         $self->get_wrapping->wrap( $storage, $ip );
 460     }
 461 }
 462
 463
 464 #
 465 # _move_ip_till( $ip,regex )
 466 #
 467 # Move $ip according to its delta on the storage,  as long as the pointed
 468 # character match the supplied regex (a qr// object).
 469 #
 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
 472 # point on the C<r>.
 473 #
 474 sub _move_ip_till {
 475     my ($self, $ip, $re) = @_;
 476     my $storage = $self->get_storage;
 477
 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;
 484     }
 485
 486     # we moved one char too far.
 487     $ip->dir_reverse;
 488     $self->_move_ip_once($ip);
 489     $ip->dir_reverse;
 490 }
 491
 492
 493 1;
 494 __END__
 495
 496 =head1 CONSTRUCTOR
 497
 498 =head2 new( [filename, ] [ Key => Value, ... ] )
 499
 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:
 504
 505     Dimensions => 2,
 506     Syntax     => 'befunge98',
 507     Storage    => 'laheyspace'
 508
 509 =head1 ACCESSORS
 510
 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! :-)
 515
 516 =over 4
 517
 518 =item get_curip() / set_curip()
 519
 520 the current Instruction Pointer processed (a L::B::IP object)
 521
 522 =item get_dimensions() / set_dimensions()
 523
 524 the number of dimensions this interpreter works in.
 525
 526 =item get_file() / set_file()
 527
 528 the script filename (a string)
 529
 530 =item get_handprint() / set_handprint()
 531
 532 the handprint of the interpreter
 533
 534 =item get_ips() / set_ips()
 535
 536 the current set of IPs travelling in the Lahey space (an array
 537 reference)
 538
 539 =item get_newips() / set_newips()
 540
 541 the set of IPs that B<will> travel in the Lahey space B<after> the
 542 current tick (an array reference)
 543
 544 =item get_ops() / set_ops()
 545
 546 the current supported operations set.
 547
 548 =item get_params() / set_params()
 549
 550 the parameters of the script (an array reference)
 551
 552 =item get_retval() / set_retval()
 553
 554 the current return value of the interpreter (an integer)
 555
 556 =item get_storage()
 557
 558 the C<LB::Storage> object containing the playfield.
 559
 560 =item get_wrapping()
 561
 562 the C<LB::Wrapping> object driving wrapping policy. Private.
 563
 564 =back
 565
 566
 567 =head1 PUBLIC METHODS
 568
 569 =head2 Utilities
 570
 571 =over 4
 572
 573 =item move_ip( $ip [, $regex] )
 574
 575 Move the C<$ip> according to its delta on the storage.
 576
 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.
 579
 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
 582 point on the C<r>.
 583
 584
 585 =item abort( reason )
 586
 587 Abort the interpreter with the given reason, as well as the current
 588 file and coordinate of the offending instruction.
 589
 590
 591
 592 =item set_input( $string )
 593
 594 Preload the input buffer with the given value.
 595
 596
 597 =item get_input(  )
 598
 599 Fetch a character of input from the input buffer, or else, directly
 600 from stdin.
 601
 602
 603 =back
 604
 605
 606
 607 =head2 Code and Data Storage
 608
 609 =over 4
 610
 611 =item read_file( filename )
 612
 613 Read a file (given as argument) and store its code.
 614
 615 Side effect: clear the previous code.
 616
 617
 618 =item store_code( code )
 619
 620 Store the given code in the Lahey space.
 621
 622 Side effect: clear the previous code.
 623
 624
 625 =back
 626
 627
 628
 629 =head2 Run methods
 630
 631 =over 4
 632
 633 =item run_code( [params]  )
 634
 635 Run the current code. That is, create a new Instruction Pointer and
 636 move it around the code.
 637
 638 Return the exit code of the program.
 639
 640
 641 =item next_tick(  )
 642
 643 Finish the current tick and stop just before the next tick.
 644
 645
 646 =item process_ip(  )
 647
 648 Process the current ip.
 649
 650
 651 =back
 652
 653
 654 =head1 TODO
 655
 656 =over 4
 657
 658 =item o
 659
 660 Write standard libraries.
 661
 662 =back
 663
 664
 665 =head1 BUGS
 666
 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.
 670
 671 There are some bugs anyway, but they come from the specs:
 672
 673 =over 4
 674
 675 =item o
 676
 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.
 680
 681 =item o
 682
 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)>).
 689
 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>.
 693
 694 =back
 695
 696
 697 =head1 ACKNOWLEDGEMENTS
 698
 699 I would like to thank Chris Pressey, creator of Befunge, who gave a
 700 whole new dimension to both coding and obfuscating.
 701
 702
 703 =head1 SEE ALSO
 704
 705 L<Language::Befunge>
 706
 707
 708 =head1 AUTHOR
 709
 710 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 711
 712 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
 713
 714
 715 =head1 COPYRIGHT & LICENSE
 716
 717 Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
 718
 719 This program is free software; you can redistribute it and/or modify
 720 it under the same terms as Perl itself.
 721
 722
 723 =cut
 724