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