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