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_till( $ip, qr/[^;]/ ); # skip till just before matching ';'
 226             $self->_move_ip_once($ip);           # till matching ';'
 227             $self->_move_ip_once($ip);           # till just after matching ';'
 228         }
 229     } while ( $char eq ' ' );
 230 }
 231
 232
 233 #
 234 # abort( reason )
 235 #
 236 # Abort the interpreter with the given reason, as well as the current
 237 # file and coordinate of the offending instruction.
 238 #
 239 sub abort {
 240     my $self = shift;
 241     my $file = $self->get_file;
 242     my $v = $self->get_curip->get_position;
 243     croak "$file $v: ", @_;
 244 }
 245
 246
 247 #
 248 # debug( LIST )
 249 #
 250 # Issue a warning if the interpreter has DEBUG enabled.
 251 #
 252 sub debug {
 253     my $self = shift;
 254     $self->get_DEBUG or return;
 255     warn @_;
 256 }
 257
 258
 259 #
 260 # set_input( $string )
 261 #
 262 # Preload the input buffer with the given value.
 263 #
 264 sub set_input {
 265     my ($self, $str) = @_;
 266     $self->input($str);
 267 }
 268
 269
 270 #
 271 # get_input(  )
 272 #
 273 # Fetch a character of input from the input buffer, or else, directly
 274 # from stdin.
 275 #
 276
 277 sub get_input {
 278     my $self = shift;
 279     return substr($$self{input}, 0, 1, '') if length $self->input;
 280     my $char;
 281     my $rv = sysread(STDIN, $char, 1);
 282     return $char if length $char;
 283     return undef;
 284 }
 285
 286
 287 # - Code and Data Storage
 288
 289 #
 290 # read_file( filename )
 291 #
 292 # Read a file (given as argument) and store its code.
 293 #
 294 # Side effect: clear the previous code.
 295 #
 296 sub read_file {
 297     my ($self, $file) = @_;
 298
 299     # Fetch the code.
 300     my $code;
 301     open BF, "<$file" or croak "$!";
 302     {
 303         local $/; # slurp mode.
 304         $code = <BF>;
 305     }
 306     close BF;
 307
 308     # Store code.
 309     $self->set_file( $file );
 310     $self->store_code( $code );
 311 }
 312
 313
 314 #
 315 # store_code( code )
 316 #
 317 # Store the given code in the Lahey space.
 318 #
 319 # Side effect: clear the previous code.
 320 #
 321 sub store_code {
 322     my ($self, $code) = @_;
 323     $self->debug( "Storing code\n" );
 324     $self->storage->clear;
 325     $self->storage->store( $code );
 326 }
 327
 328
 329 # - Run methods
 330
 331
 332 #
 333 # run_code( [params]  )
 334 #
 335 # Run the current code. That is, create a new Instruction Pointer and
 336 # move it around the code.
 337 #
 338 # Return the exit code of the program.
 339 #
 340 sub run_code {
 341     my $self = shift;
 342     $self->set_params( [ @_ ] );
 343
 344     # Cosmetics.
 345     $self->debug( "\n-= NEW RUN (".$self->get_file.") =-\n" );
 346
 347     # Create the first Instruction Pointer.
 348     $self->set_ips( [ Language::Befunge::IP->new($$self{dimensions}) ] );
 349     $self->set_retval(0);
 350
 351     # Loop as long as there are IPs.
 352     $self->next_tick while scalar @{ $self->get_ips };
 353
 354     # Return the exit code.
 355     return $self->get_retval;
 356 }
 357
 358
 359 #
 360 # next_tick(  )
 361 #
 362 # Finish the current tick and stop just before the next tick.
 363 #
 364 sub next_tick {
 365     my $self = shift;
 366
 367     # Cosmetics.
 368     $self->debug( "Tick!\n" );
 369
 370     # Process the set of IPs.
 371     $self->set_newips( [] );
 372     $self->process_ip while $self->set_curip( shift @{ $self->get_ips } );
 373
 374     # Copy the new ips.
 375     $self->set_ips( $self->get_newips );
 376 }
 377
 378
 379 #
 380 # process_ip(  )
 381 #
 382 # Process the current ip.
 383 #
 384 sub process_ip {
 385     my ($self, $continue) = @_;
 386     $continue = 1 unless defined $continue;
 387     my $ip = $self->get_curip;
 388
 389     # Fetch values for this IP.
 390     my $v  = $ip->get_position;
 391     my $ord  = $self->storage->get_value( $v );
 392     my $char = $self->storage->get_char( $v );
 393
 394     # Cosmetics.
 395     $self->debug( "#".$ip->get_id.":$v: $char (ord=$ord)  Stack=(@{$ip->get_toss})\n" );
 396
 397     # Check if we are in string-mode.
 398     if ( $ip->get_string_mode ) {
 399         if ( $char eq '"' ) {
 400             # End of string-mode.
 401             $self->debug( "leaving string-mode\n" );
 402             $ip->set_string_mode(0);
 403
 404         } elsif ( $char eq ' ' ) {
 405             # A serie of spaces, to be treated as one space.
 406             $self->debug( "string-mode: pushing char ' '\n" );
 407             $self->_move_ip_till( $ip, qr/ / );
 408             $ip->spush( $ord );
 409
 410         } else {
 411             # A banal character.
 412             $self->debug( "string-mode: pushing char '$char'\n" );
 413             $ip->spush( $ord );
 414         }
 415
 416     } else {
 417         # Not in string-mode.
 418         if ( exists $self->get_ops->{$char} ) {
 419             # Regular instruction.
 420             my $meth = $self->get_ops->{$char};
 421             $meth->($self);
 422
 423         } else {
 424             # Not a regular instruction: reflect.
 425             $self->debug( "the command value $ord (char='$char') is not implemented.\n");
 426             $ip->dir_reverse;
 427         }
 428     }
 429
 430     if ($continue) {
 431         # Tick done for this IP, let's move it and push it in the
 432         # set of non-terminated IPs.
 433         if ( $ip->get_string_mode ) {
 434             $self->_move_ip_once( $self->get_curip );
 435         } else {
 436             $self->move_ip( $self->get_curip );
 437         }
 438         push @{ $self->get_newips }, $ip unless $ip->get_end;
 439     }
 440 }
 441
 442 #-- PRIVATE METHODS
 443
 444
 445 #
 446 # $lbi->_move_ip_once( $ip );
 447 #
 448 # move $ip one step further, according to its velocity. if $ip gets out
 449 # of bounds, then a wrapping is performed (according to current
 450 # interpreter wrapping implementation) on the ip.
 451 #
 452 sub _move_ip_once {
 453     my ($self, $ip) = @_;
 454     my $storage = $self->storage;
 455
 456     # fetch the current position of the ip.
 457     my $v = $ip->get_position;
 458     my $d = $ip->get_delta;
 459
 460     # now, let's move the ip.
 461     $v += $d;
 462
 463     if ( $v->bounds_check($storage->min, $storage->max) ) {
 464         # within bounds - store new position.
 465         $ip->set_position( $v );
 466     } else {
 467         # wrap needed - this will update the position.
 468         $self->_wrapping->wrap( $storage, $ip );
 469     }
 470 }
 471
 472
 473 #
 474 # _move_ip_till( $ip,regex )
 475 #
 476 # Move $ip according to its delta on the storage,  as long as the pointed
 477 # character match the supplied regex (a qr// object).
 478 #
 479 # Example: given the code C<;foobar;> (assuming the IP points on the
 480 # first C<;>) and the regex C<qr/[^;]/>, the IP will move in order to
 481 # point on the C<r>.
 482 #
 483 sub _move_ip_till {
 484     my ($self, $ip, $re) = @_;
 485     my $storage = $self->storage;
 486
 487     my $orig = $ip->get_position;
 488     # moving as long as we did not reach the condition.
 489     while ( $storage->get_char($ip->get_position) =~ $re ) {
 490         $self->_move_ip_once($ip);
 491         $self->abort("infinite loop")
 492         if $ip->get_position == $orig;
 493     }
 494
 495     # we moved one char too far.
 496     $ip->dir_reverse;
 497     $self->_move_ip_once($ip);
 498     $ip->dir_reverse;
 499 }
 500
 501
 502 1;
 503 __END__
 504
 505 =head1 CONSTRUCTOR
 506
 507 =head2 new( [filename, ] [ Key => Value, ... ] )
 508
 509 Create a new Befunge interpreter.  As an optional first argument, you
 510 can pass it a filename to read Funge code from (default: blank
 511 torus).  All other arguments are key=>value pairs.  The following
 512 keys are accepted, with their default values shown:
 513
 514     Dimensions => 2,
 515     Syntax     => 'befunge98',
 516     Storage    => 'laheyspace'
 517
 518 =head1 ACCESSORS
 519
 520 The following is a list of attributes of a Language::Befunge
 521 object. For each of them, a method C<get_foobar> and C<set_foobar>
 522 exists, which does what you can imagine - and if you can't, then i
 523 wonder why you are reading this! :-)
 524
 525 =over 4
 526
 527 =item get_curip() / set_curip()
 528
 529 the current Instruction Pointer processed (a L::B::IP object)
 530
 531 =item get_DEBUG() / set_DEBUG()
 532
 533 wether the interpreter should output debug messages (a boolean)
 534
 535 =item get_dimensions() / set_dimensions()
 536
 537 the number of dimensions this interpreter works in.
 538
 539 =item get_file() / set_file()
 540
 541 the script filename (a string)
 542
 543 =item get_handprint() / set_handprint()
 544
 545 the handprint of the interpreter
 546
 547 =item get_ips() / set_ips()
 548
 549 the current set of IPs travelling in the Lahey space (an array
 550 reference)
 551
 552 =item get_newips() / set_newips()
 553
 554 the set of IPs that B<will> travel in the Lahey space B<after> the
 555 current tick (an array reference)
 556
 557 =item get_ops() / set_ops()
 558
 559 the current supported operations set.
 560
 561 =item get_params() / set_params()
 562
 563 the parameters of the script (an array reference)
 564
 565 =item get_retval() / set_retval()
 566
 567 the current return value of the interpreter (an integer)
 568
 569 =back
 570
 571
 572 =head1 PUBLIC METHODS
 573
 574 =head2 Utilities
 575
 576 =over 4
 577
 578 =item move_ip( $ip [, $regex] )
 579
 580 Move the C<$ip> according to its delta on the storage.
 581
 582 If C<$regex> ( a C<qr//> object ) is specified, then C<$ip> will move as
 583 long as the pointed character match the supplied regex.
 584
 585 Example: given the code C<;foobar;> (assuming the IP points on the
 586 first C<;>) and the regex C<qr/[^;]/>, the IP will move in order to
 587 point on the C<r>.
 588
 589
 590 =item abort( reason )
 591
 592 Abort the interpreter with the given reason, as well as the current
 593 file and coordinate of the offending instruction.
 594
 595
 596 =item debug( LIST )
 597
 598 Issue a warning if the interpreter has DEBUG enabled.
 599
 600
 601 =item set_input( $string )
 602
 603 Preload the input buffer with the given value.
 604
 605
 606 =item get_input(  )
 607
 608 Fetch a character of input from the input buffer, or else, directly
 609 from stdin.
 610
 611
 612 =back
 613
 614
 615
 616 =head2 Code and Data Storage
 617
 618 =over 4
 619
 620 =item read_file( filename )
 621
 622 Read a file (given as argument) and store its code.
 623
 624 Side effect: clear the previous code.
 625
 626
 627 =item store_code( code )
 628
 629 Store the given code in the Lahey space.
 630
 631 Side effect: clear the previous code.
 632
 633
 634 =back
 635
 636
 637
 638 =head2 Run methods
 639
 640 =over 4
 641
 642 =item run_code( [params]  )
 643
 644 Run the current code. That is, create a new Instruction Pointer and
 645 move it around the code.
 646
 647 Return the exit code of the program.
 648
 649
 650 =item next_tick(  )
 651
 652 Finish the current tick and stop just before the next tick.
 653
 654
 655 =item process_ip(  )
 656
 657 Process the current ip.
 658
 659
 660 =back
 661
 662
 663 =head1 TODO
 664
 665 =over 4
 666
 667 =item o
 668
 669 Write standard libraries.
 670
 671 =back
 672
 673
 674 =head1 BUGS
 675
 676 Although this module comes with a full set of tests, maybe there are
 677 subtle bugs - or maybe even I misinterpreted the Funge-98
 678 specs. Please report them to me.
 679
 680 There are some bugs anyway, but they come from the specs:
 681
 682 =over 4
 683
 684 =item o
 685
 686 About the 18th cell pushed by the C<y> instruction: Funge specs just
 687 tell to push onto the stack the size of the stacks, but nothing is
 688 said about how user will retrieve the number of stacks.
 689
 690 =item o
 691
 692 About the load semantics. Once a library is loaded, the interpreter is
 693 to put onto the TOSS the fingerprint of the just-loaded library. But
 694 nothing is said if the fingerprint is bigger than the maximum cell
 695 width (here, 4 bytes). This means that libraries can't have a name
 696 bigger than C<0x80000000>, ie, more than four letters with the first
 697 one smaller than C<P> (C<chr(80)>).
 698
 699 Since perl is not so rigid, one can build libraries with more than
 700 four letters, but perl will issue a warning about non-portability of
 701 numbers greater than C<0xffffffff>.
 702
 703 =back
 704
 705
 706 =head1 ACKNOWLEDGEMENTS
 707
 708 I would like to thank Chris Pressey, creator of Befunge, who gave a
 709 whole new dimension to both coding and obfuscating.
 710
 711
 712 =head1 SEE ALSO
 713
 714 L<Language::Befunge>
 715
 716
 717 =head1 AUTHOR
 718
 719 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 720
 721 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
 722
 723
 724 =head1 COPYRIGHT & LICENSE
 725
 726 Copyright (c) 2001-2008 Jerome Quelin, all rights reserved.
 727
 728 This program is free software; you can redistribute it and/or modify
 729 it under the same terms as Perl itself.
 730
 731
 732 =cut
 733