lib/Language/Befunge/Interpreter.pm

   1 #
   2 # This file is part of Language::Befunge.
   3 # Copyright (c) 2001-2008 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::IP;
  18 use UNIVERSAL::require;
  19
  20 # FIXME: wtf? always use get_/set_ or mutators, but not a mix of them!
  21 use Class::XSAccessor
  22     getters => {
  23         get_dimensions => 'dimensions',
  24         get_file       => 'file',
  25         get_params     => 'params',
  26         get_retval     => 'retval',
  27         get_storage    => 'storage',
  28         get_DEBUG      => 'DEBUG',
  29         get_curip      => 'curip',
  30         get_ips        => 'ips',
  31         get_newips     => 'newips',
  32         get_ops        => 'ops',
  33         get_handprint  => 'handprint',
  34     },
  35     setters => {
  36         set_dimensions => 'dimensions',
  37         set_file       => 'file',
  38         set_params     => 'params',
  39         set_retval     => 'retval',
  40         set_DEBUG      => 'DEBUG',
  41         set_curip      => 'curip',
  42         set_ips        => 'ips',
  43         set_newips     => 'newips',
  44         set_ops        => 'ops',
  45         set_handprint  => 'handprint',
  46     },
  47     accessors => {
  48         input     => 'input',
  49         _wrapping => '_wrapping',
  50     };
  51
  52 # Public variables of the module.
  53 $| = 1;
  54
  55
  56 # -- CONSTRUCTOR
  57
  58
  59 #
  60 # my $interpreter = LBI->new( $opts )
  61 #
  62 # Create a new funge interpreter. One can pass some options as a hash
  63 # reference, with the following keys:
  64 #  - file:     the filename to read funge code from (default: blank storage)
  65 #  - syntax:   the tunings set (default: 'befunge98')
  66 #  - dims:     the number of dimensions
  67 #  - ops:      the Ops subclass used in this interpreter
  68 #  - storage:  the Storage subclass used in this interpreter
  69 #  - wrapping: the Wrapping subclass used in this interpreter
  70 #
  71 # Usually, the "dims", "ops", "storage" and "wrapping" keys are left
  72 # undefined, and are implied by the "syntax" key.
  73 #
  74 # Depending on the value of syntax will change the interpreter
  75 # internals: set of allowed ops, storage implementation, wrapping. The
  76 # following values are recognized for 'syntax' (with in order: the
  77 # number of dimensions, the set of operation loaded, the storage
  78 # implementation and the wrapping implementation):
  79 #
  80 #  - unefunge98: 1, LBO:Unefunge98, LBS:Generic::AoA, LBW:LaheySpace
  81 #  - befunge98:  2, LBO:Befunge98,  LBS:2D:Sparse,    LBW:LaheySpace
  82 #  - trefunge98: 3, LBO:GenericFunge98, LBS:Generic::AoA, LBW:LaheySpace
  83 #  - 4funge98:   4, LBO:GenericFunge98, LBS:Generic::AoA, LBW:LaheySpace
  84 #  - 5funge98:   5, LBO:GenericFunge98, LBS:Generic::AoA, LBW:LaheySpace
  85 #  ...and so on.
  86 #
  87 #
  88 # If none of those values suit your needs, you can pass the value
  89 # 'custom' and in that case you're responsible for also giving
  90 # appropriate values for the keys 'dims', 'ops', 'storage', 'wrapping'.
  91 # Note that those values will be ignored for all syntax values beside
  92 # 'custom'.
  93 #
  94 sub new {
  95     my ($class, $opts) = @_;
  96
  97     $opts //= { dims => 2 };
  98     unless(exists($$opts{syntax})) {
  99         $$opts{dims} //= 2;
 100         croak("If you pass a 'dims' attribute, it must be numeric.")
 101             if $$opts{dims} =~ /\D/;
 102         my %defaults = (
 103             1 => 'unefunge98',
 104             2 => 'befunge98',
 105             3 => 'trefunge98',
 106         );
 107         if(exists($defaults{$$opts{dims}})) {
 108             $$opts{syntax} = $defaults{$$opts{dims}};
 109         } else {
 110             $$opts{syntax} = $$opts{dims} . 'funge98';
 111         }
 112     }
 113
 114     # select the classes to use, depending on the wanted syntax.
 115     my $lbo = 'Language::Befunge::Ops::';
 116     my $lbs = 'Language::Befunge::Storage::';
 117     my $lbw = 'Language::Befunge::Wrapping::';
 118     given ( $opts->{syntax} ) {
 119         when ('unefunge98') {
 120             $opts->{dims}     = 1                     unless defined $opts->{dims};
 121             $opts->{ops}      = $lbo . 'Unefunge98'   unless defined $opts->{ops};
 122             $opts->{storage}  = $lbs . 'Generic::AoA' unless defined $opts->{storage};
 123             $opts->{wrapping} = $lbw . 'LaheySpace'   unless defined $opts->{wrapping};
 124         }
 125         when ('befunge98') {
 126             $opts->{dims}     = 2                     unless defined $opts->{dims};
 127             $opts->{ops}      = $lbo . 'Befunge98'    unless defined $opts->{ops};
 128             $opts->{storage}  = $lbs . '2D::Sparse'   unless defined $opts->{storage};
 129             $opts->{wrapping} = $lbw . 'LaheySpace'   unless defined $opts->{wrapping};
 130         }
 131         when ('trefunge98') {
 132             $opts->{dims}     = 3                       unless defined $opts->{dims};
 133             $opts->{ops}      = $lbo . 'GenericFunge98' unless defined $opts->{ops};
 134             $opts->{storage}  = $lbs . 'Generic::AoA'   unless defined $opts->{storage};
 135             $opts->{wrapping} = $lbw . 'LaheySpace'     unless defined $opts->{wrapping};
 136         }
 137         when (/(\d+)funge98$/) { # accept values like "4funge98"
 138             $opts->{dims}     = $1                      unless defined $opts->{dims};
 139             $opts->{ops}      = $lbo . 'GenericFunge98' unless defined $opts->{ops};
 140             $opts->{storage}  = $lbs . 'Generic::AoA'   unless defined $opts->{storage};
 141             $opts->{wrapping} = $lbw . 'LaheySpace'     unless defined $opts->{wrapping};
 142         }
 143         default { croak "syntax '$opts->{syntax}' not recognized." }
 144     }
 145
 146     # load the classes (through UNIVERSAL::require)
 147     $opts->{ops}->use;
 148     $opts->{storage}->use;
 149     $opts->{wrapping}->use;
 150
 151     # create the object
 152     my $wrapping = $opts->{wrapping}->new;
 153     my $self  = {
 154         dimensions => $opts->{dims},
 155         storage    => $opts->{storage}->new( $opts->{dims}, Wrapping => $wrapping ),
 156         file       => "STDIN",
 157         input      => '',
 158         params     => [],
 159         retval     => 0,
 160         DEBUG      => 0,
 161         curip      => undef,
 162         ops        => $opts->{ops}->get_ops_map,
 163         ips        => [],
 164         newips     => [],
 165         handprint  => 'JQBF', # the official handprint
 166         _wrapping  => $wrapping,
 167       };
 168     bless $self, $class;
 169
 170     # read the file if needed.
 171     defined($opts->{file}) and $self->read_file( $opts->{file} );
 172
 173     # return the object.
 174     return $self;
 175 }
 176
 177
 178
 179
 180 # -- PUBLIC METHODS
 181
 182 # - Utilities
 183
 184
 185 #
 186 # move_ip( $ip )
 187 #
 188 # Move $ip according to its delta on the storage. Spaces and comments
 189 # (enclosed with semi-colons ';') are skipped silently.
 190 #
 191 sub move_ip {
 192     my ($self, $ip) = @_;
 193
 194     my $storage = $self->get_storage;
 195     my $orig = $ip->get_position;
 196     $self->_move_ip_once($ip);
 197     my $char;
 198     MOVE: while (1) {
 199         # sanity check
 200         my $pos = $ip->get_position;
 201         $char = $storage->get_char($pos);
 202
 203         # skip spaces
 204         if ( $char eq ' ' ) {
 205             $self->_move_ip_till( $ip, qr/ / );   # skip all spaces
 206             $self->_move_ip_once($ip);            # skip last space
 207             redo MOVE;
 208         }
 209
 210         # skip comments
 211         if ( $char eq ';' ) {
 212             $self->_move_ip_once($ip);             # skip comment ';'
 213             $self->_move_ip_till( $ip, qr/[^;]/ ); # till just before matching ';'
 214             $self->_move_ip_once($ip);             # till matching ';'
 215             $self->_move_ip_once($ip);             # till just after matching ';'
 216             redo MOVE;
 217         }
 218
 219         last MOVE;
 220     }
 221 }
 222
 223
 224 #
 225 # abort( reason )
 226 #
 227 # Abort the interpreter with the given reason, as well as the current
 228 # file and coordinate of the offending instruction.
 229 #
 230 sub abort {
 231     my $self = shift;
 232     my $file = $self->get_file;
 233     my $v = $self->get_curip->get_position;
 234     croak "$file $v: ", @_;
 235 }
 236
 237
 238 #
 239 # debug( LIST )
 240 #
 241 # Issue a warning if the interpreter has DEBUG enabled.
 242 #
 243 sub debug {
 244     my $self = shift;
 245     $self->get_DEBUG or return;
 246     warn @_;
 247 }
 248
 249
 250 #
 251 # set_input( $string )
 252 #
 253 # Preload the input buffer with the given value.
 254 #
 255 sub set_input {
 256     my ($self, $str) = @_;
 257     $self->input($str);
 258 }
 259
 260
 261 #
 262 # get_input(  )
 263 #
 264 # Fetch a character of input from the input buffer, or else, directly
 265 # from stdin.
 266 #
 267
 268 sub get_input {
 269     my $self = shift;
 270     return substr($$self{input}, 0, 1, '') if length $self->input;
 271     my $char;
 272     my $rv = sysread(STDIN, $char, 1);
 273     return $char if length $char;
 274     return undef;
 275 }
 276
 277
 278 # - Code and Data Storage
 279
 280 #
 281 # read_file( filename )
 282 #
 283 # Read a file (given as argument) and store its code.
 284 #
 285 # Side effect: clear the previous code.
 286 #
 287 sub read_file {
 288     my ($self, $file) = @_;
 289
 290     # Fetch the code.
 291     my $code;
 292     open BF, "<$file" or croak "$!";
 293     {
 294         local $/; # slurp mode.
 295         $code = <BF>;
 296     }
 297     close BF;
 298
 299     # Store code.
 300     $self->set_file( $file );
 301     $self->store_code( $code );
 302 }
 303
 304
 305 #
 306 # store_code( code )
 307 #
 308 # Store the given code in the Lahey space.
 309 #
 310 # Side effect: clear the previous code.
 311 #
 312 sub store_code {
 313     my ($self, $code) = @_;
 314     $self->debug( "Storing code\n" );
 315     $self->get_storage->clear;
 316     $self->get_storage->store( $code );
 317 }
 318
 319
 320 # - Run methods
 321
 322
 323 #
 324 # run_code( [params]  )
 325 #
 326 # Run the current code. That is, create a new Instruction Pointer and
 327 # move it around the code.
 328 #
 329 # Return the exit code of the program.
 330 #
 331 sub run_code {
 332     my $self = shift;
 333     $self->set_params( [ @_ ] );
 334
 335     # Cosmetics.
 336     $self->debug( "\n-= NEW RUN (".$self->get_file.") =-\n" );
 337
 338     # Create the first Instruction Pointer.
 339     $self->set_ips( [ Language::Befunge::IP->new($$self{dimensions}) ] );
 340     $self->set_retval(0);
 341
 342     # Loop as long as there are IPs.
 343     $self->next_tick while scalar @{ $self->get_ips };
 344
 345     # Return the exit code.
 346     return $self->get_retval;
 347 }
 348
 349
 350 #
 351 # next_tick(  )
 352 #
 353 # Finish the current tick and stop just before the next tick.
 354 #
 355 sub next_tick {
 356     my $self = shift;
 357
 358     # Cosmetics.
 359     $self->debug( "Tick!\n" );
 360
 361     # Process the set of IPs.
 362     $self->set_newips( [] );
 363     $self->process_ip while $self->set_curip( shift @{ $self->get_ips } );
 364
 365     # Copy the new ips.
 366     $self->set_ips( $self->get_newips );
 367 }
 368
 369
 370 #
 371 # process_ip(  )
 372 #
 373 # Process the current ip.
 374 #
 375 sub process_ip {
 376     my ($self, $continue) = @_;
 377     $continue = 1 unless defined $continue;
 378     my $ip = $self->get_curip;
 379
 380     # Fetch values for this IP.
 381     my $v  = $ip->get_position;
 382     my $ord  = $self->get_storage->get_value( $v );
 383     my $char = $self->get_storage->get_char( $v );
 384
 385     # Cosmetics.
 386     $self->debug( "#".$ip->get_id.":$v: $char (ord=$ord)  Stack=(@{$ip->get_toss})\n" );
 387
 388     # Check if we are in string-mode.
 389     if ( $ip->get_string_mode ) {
 390         if ( $char eq '"' ) {
 391             # End of string-mode.
 392             $self->debug( "leaving string-mode\n" );
 393             $ip->set_string_mode(0);
 394
 395         } elsif ( $char eq ' ' ) {
 396             # A serie of spaces, to be treated as one space.
 397             $self->debug( "string-mode: pushing char ' '\n" );
 398             $self->_move_ip_till( $ip, qr/ / );
 399             $ip->spush( $ord );
 400
 401         } else {
 402             # A banal character.
 403             $self->debug( "string-mode: pushing char '$char'\n" );
 404             $ip->spush( $ord );
 405         }
 406
 407     } else {
 408         $self->_do_instruction($char);
 409     }
 410
 411     if ($continue) {
 412         # Tick done for this IP, let's move it and push it in the
 413         # set of non-terminated IPs.
 414         if ( $ip->get_string_mode ) {
 415             $self->_move_ip_once( $self->get_curip );
 416         } else {
 417             $self->move_ip( $self->get_curip );
 418         }
 419         push @{ $self->get_newips }, $ip unless $ip->get_end;
 420     }
 421 }
 422
 423 #-- PRIVATE METHODS
 424
 425 #
 426 # $lbi->_do_instruction( $char );
 427 #
 428 # interpret instruction $char according to loaded ops map.
 429 #
 430 sub _do_instruction {
 431     my ($self, $char) = @_;
 432
 433     if ( exists $self->get_ops->{$char} ) {
 434         # regular instruction.
 435         my $meth = $self->get_ops->{$char};
 436         $meth->($self, $char);
 437
 438     } else {
 439         # not a regular instruction: reflect.
 440         my $ord = ord($char);
 441         $self->debug( "the command value $ord (char='$char') is not implemented.\n");
 442         $self->get_curip->dir_reverse;
 443     }
 444 }
 445
 446
 447 #
 448 # $lbi->_move_ip_once( $ip );
 449 #
 450 # move $ip one step further, according to its velocity. if $ip gets out
 451 # of bounds, then a wrapping is performed (according to current
 452 # interpreter wrapping implementation) on the ip.
 453 #
 454 sub _move_ip_once {
 455     my ($self, $ip) = @_;
 456     my $storage = $self->get_storage;
 457
 458     # fetch the current position of the ip.
 459     my $v = $ip->get_position;
 460     my $d = $ip->get_delta;
 461
 462     # now, let's move the ip.
 463     $v += $d;
 464
 465     if ( $v->bounds_check($storage->min, $storage->max) ) {
 466         # within bounds - store new position.
 467         $ip->set_position( $v );
 468     } else {
 469         # wrap needed - this will update the position.
 470         $self->_wrapping->wrap( $storage, $ip );
 471     }
 472 }
 473
 474
 475 #
 476 # _move_ip_till( $ip,regex )
 477 #
 478 # Move $ip according to its delta on the storage,  as long as the pointed
 479 # character match the supplied regex (a qr// object).
 480 #
 481 # Example: given the code C<;foobar;> (assuming the IP points on the
 482 # first C<;>) and the regex C<qr/[^;]/>, the IP will move in order to
 483 # point on the C<r>.
 484 #
 485 sub _move_ip_till {
 486     my ($self, $ip, $re) = @_;
 487     my $storage = $self->get_storage;
 488
 489     my $orig = $ip->get_position;
 490     # moving as long as we did not reach the condition.
 491     while ( $storage->get_char($ip->get_position) =~ $re ) {
 492         $self->_move_ip_once($ip);
 493         $self->abort("infinite loop")
 494         if $ip->get_position == $orig;
 495     }
 496
 497     # we moved one char too far.
 498     $ip->dir_reverse;
 499     $self->_move_ip_once($ip);
 500     $ip->dir_reverse;
 501 }
 502
 503
 504 1;
 505 __END__
 506
 507 =head1 CONSTRUCTOR
 508
 509 =head2 new( [filename, ] [ Key => Value, ... ] )
 510
 511 Create a new Befunge interpreter.  As an optional first argument, you
 512 can pass it a filename to read Funge code from (default: blank
 513 torus).  All other arguments are key=>value pairs.  The following
 514 keys are accepted, with their default values shown:
 515
 516     Dimensions => 2,
 517     Syntax     => 'befunge98',
 518     Storage    => 'laheyspace'
 519
 520 =head1 ACCESSORS
 521
 522 The following is a list of attributes of a Language::Befunge
 523 object. For each of them, a method C<get_foobar> and C<set_foobar>
 524 exists, which does what you can imagine - and if you can't, then i
 525 wonder why you are reading this! :-)
 526
 527 =over 4
 528
 529 =item get_curip() / set_curip()
 530
 531 the current Instruction Pointer processed (a L::B::IP object)
 532
 533 =item get_DEBUG() / set_DEBUG()
 534
 535 wether the interpreter should output debug messages (a boolean)
 536
 537 =item get_dimensions() / set_dimensions()
 538
 539 the number of dimensions this interpreter works in.
 540
 541 =item get_file() / set_file()
 542
 543 the script filename (a string)
 544
 545 =item get_handprint() / set_handprint()
 546
 547 the handprint of the interpreter
 548
 549 =item get_ips() / set_ips()
 550
 551 the current set of IPs travelling in the Lahey space (an array
 552 reference)
 553
 554 =item get_newips() / set_newips()
 555
 556 the set of IPs that B<will> travel in the Lahey space B<after> the
 557 current tick (an array reference)
 558
 559 =item get_ops() / set_ops()
 560
 561 the current supported operations set.
 562
 563 =item get_params() / set_params()
 564
 565 the parameters of the script (an array reference)
 566
 567 =item get_retval() / set_retval()
 568
 569 the current return value of the interpreter (an integer)
 570
 571 =item get_storage()
 572
 573 the C<LB::Storage> object containing the playfield.
 574
 575 =back
 576
 577
 578 =head1 PUBLIC METHODS
 579
 580 =head2 Utilities
 581
 582 =over 4
 583
 584 =item move_ip( $ip [, $regex] )
 585
 586 Move the C<$ip> according to its delta on the storage.
 587
 588 If C<$regex> ( a C<qr//> object ) is specified, then C<$ip> will move as
 589 long as the pointed character match the supplied regex.
 590
 591 Example: given the code C<;foobar;> (assuming the IP points on the
 592 first C<;>) and the regex C<qr/[^;]/>, the IP will move in order to
 593 point on the C<r>.
 594
 595
 596 =item abort( reason )
 597
 598 Abort the interpreter with the given reason, as well as the current
 599 file and coordinate of the offending instruction.
 600
 601
 602 =item debug( LIST )
 603
 604 Issue a warning if the interpreter has DEBUG enabled.
 605
 606
 607 =item set_input( $string )
 608
 609 Preload the input buffer with the given value.
 610
 611
 612 =item get_input(  )
 613
 614 Fetch a character of input from the input buffer, or else, directly
 615 from stdin.
 616
 617
 618 =back
 619
 620
 621
 622 =head2 Code and Data Storage
 623
 624 =over 4
 625
 626 =item read_file( filename )
 627
 628 Read a file (given as argument) and store its code.
 629
 630 Side effect: clear the previous code.
 631
 632
 633 =item store_code( code )
 634
 635 Store the given code in the Lahey space.
 636
 637 Side effect: clear the previous code.
 638
 639
 640 =back
 641
 642
 643
 644 =head2 Run methods
 645
 646 =over 4
 647
 648 =item run_code( [params]  )
 649
 650 Run the current code. That is, create a new Instruction Pointer and
 651 move it around the code.
 652
 653 Return the exit code of the program.
 654
 655
 656 =item next_tick(  )
 657
 658 Finish the current tick and stop just before the next tick.
 659
 660
 661 =item process_ip(  )
 662
 663 Process the current ip.
 664
 665
 666 =back
 667
 668
 669 =head1 TODO
 670
 671 =over 4
 672
 673 =item o
 674
 675 Write standard libraries.
 676
 677 =back
 678
 679
 680 =head1 BUGS
 681
 682 Although this module comes with a full set of tests, maybe there are
 683 subtle bugs - or maybe even I misinterpreted the Funge-98
 684 specs. Please report them to me.
 685
 686 There are some bugs anyway, but they come from the specs:
 687
 688 =over 4
 689
 690 =item o
 691
 692 About the 18th cell pushed by the C<y> instruction: Funge specs just
 693 tell to push onto the stack the size of the stacks, but nothing is
 694 said about how user will retrieve the number of stacks.
 695
 696 =item o
 697
 698 About the load semantics. Once a library is loaded, the interpreter is
 699 to put onto the TOSS the fingerprint of the just-loaded library. But
 700 nothing is said if the fingerprint is bigger than the maximum cell
 701 width (here, 4 bytes). This means that libraries can't have a name
 702 bigger than C<0x80000000>, ie, more than four letters with the first
 703 one smaller than C<P> (C<chr(80)>).
 704
 705 Since perl is not so rigid, one can build libraries with more than
 706 four letters, but perl will issue a warning about non-portability of
 707 numbers greater than C<0xffffffff>.
 708
 709 =back
 710
 711
 712 =head1 ACKNOWLEDGEMENTS
 713
 714 I would like to thank Chris Pressey, creator of Befunge, who gave a
 715 whole new dimension to both coding and obfuscating.
 716
 717
 718 =head1 SEE ALSO
 719
 720 L<Language::Befunge>
 721
 722
 723 =head1 AUTHOR
 724
 725 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 726
 727 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
 728
 729
 730 =head1 COPYRIGHT & LICENSE
 731
 732 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
 733
 734 This program is free software; you can redistribute it and/or modify
 735 it under the same terms as Perl itself.
 736
 737
 738 =cut
 739