Brainbool interpreter

This is the reference Brainbool interpreter

#!/usr/bin/perl -w

use Getopt::Long;
use strict;
use integer;

Getopt::Long::Configure ("bundling");

my $help =<<EOH;
brainbool.pl - Brainbool interpreter in perl

 usage:
  perl brainbool.pl [ opts ] program
  cat program | perl brainbool.pl [ opts ]

 options:
 -h
 --help    This help

 -i
 --interpret
           The default mode of operation; interprete a brainbool program.
           When combined with --to-brainbool, will interpret the
           resultant program

 -c
 --to-brainbool
 --bb      Convert a brainfuck program to brainbool
           Can be combined with --interpret

 -n
 --input   Convert a stream of characters to a stream of '0's and '1's
           (inputs on STDIN & outputs on STDOUT)
           Can be combined with --to-brainbool if brainfuck source is in
           a file and input stream is on STDIN
           Can be combined with --interpret if brainbool source is in
           a file and input stream is on STDIN
           Brainfuck/Brainbool source can be on STDIN if --bang is used

 -o
 --output  Convert a stream of '0's and '1's to a stream of characters
           (inputs on STDIN & outputs on STDOUT)
           '0' and '1' characters may each be on their own line

 -b
 --bang    Read program on STDIN and stop at the first "!" character.
           Everything following the first "!" is input to the program.
           In --to-brainbool mode, append a "!" after the brainbool program.

 --nl      Separate each character by a newline
           Valid in all modes of operation

 see http://esolangs.org/wiki/Brainbool for more information on Brainbool

 license: Public Domain

EOH

my $bang;
my $brainbool;
my $output;
my $input;
my $nl;
my $debug;

my $source = "";

GetOptions ('help|h' => sub {
             print "$help";
             exit 0; },
            'bang|b' => \$bang,
            'to-brainbool|bb|c' => \$brainbool,
            'output|o' => \$output,
            'input|i' => \$input,
            'nl' => \$nl,
            'debug|d' => \$debug);

if ($brainbool) {
  $source = join(, <>);
  $source =~ s/[^-+\[\]<>,\.]//gs;

  $source =~ s/-/A/g;
  $source =~ s/\+/B/g;
  $source =~ s/\[/C/g;
  $source =~ s/\]/D/g;
  $source =~ s/</E/g;
  $source =~ s/>/F/g;
  $source =~ s/,/G/g;
  $source =~ s/\./H/g;

  while ($source =~ s/AB//g || $source =~ s/BA//g ||
         $source =~ s/EF//g || $source =~ s/FE//g ||
         $source =~ s/AA/IA/g || $source =~ s/AI/IA/g ||
         $source =~ s/BB/JB/g || $source =~ s/BJ/JB/g) { }

  $source =~ s/A/>>>>>>>>>+<<<<<<<<+[>+]<[<]>>>>>>>>>[+]<<<<<<<<</g;
  $source =~ s/B/>[>]+<[+<]>>>>>>>>>[+]<<<<<<<<</g;
  $source =~ s/C/>>>>>>>>>+<<<<<<<<+[>+]<[<]>>>>>>>>>[+<<<<<<<<[>]+<[+<]/g;
  $source =~ s/D/>>>>>>>>>+<<<<<<<<+[>+]<[<]>>>>>>>>>]<[+<]/g;
  $source =~ s/E/<<<<<<<<</g;
  $source =~ s/F/>>>>>>>>>/g;
  $source =~ s/G/>,>,>,>,>,>,>,>,<<<<<<<</g;
  $source =~ s/H/>.>.>.>.>.>.>.>.<<<<<<<</g;
  $source =~ s/I/>>>>>>>>>+<<<<<<<<+[>+]<[<]/g;
  $source =~ s/J/>[>]+<[+<]/g;

  while ($source =~ s/><//g || $source =~ s/<>//g) { }

  $source .= $bang ? "!" : "";

  if ($input) {
    my $ch;
    while (defined($ch = getc())) {
      $source .= reverse(sprintf('%08b', ord($ch)));
    }
  }

  print join(($nl ? "\n" : ""), split(//, $source), "");

  exit 0;
} elsif ($output) {
  my $bits = "";
  while (<>) {
    s/\n//gs;
    $bits .= $_;
    while (length($bits) >= 8) {
      print chr(eval("0b" . reverse(substr($bits, 0, 8, ""))));
    }
  }
  exit 0
} elsif ($input) {
  my $sep = $nl ? "\n" : "";
  while (<>) {
    while (length($_) >= 1) {
      print join($sep, split(//,
        reverse(sprintf('%08b', ord(substr($_, 0, 1, ""))))), "");
    }
  }
  exit 0
}

if ($bang) {
  my $ch;
  while (($ch = getc()) ne "!") {
    die "no \"!\" ever found on STDIN\n" unless defined $ch;
    $source .= $ch;
  }
} else {
  $source = join(, <>);
}

my @bracket;
my @tape = (0);
my $t_ptr = 0;
my @prog;

while (length($source)) {
  my $ch = substr($source, 0, 1, "");
  if ($ch eq ">") {
    push @prog, sub { $t_ptr++; $tape[$t_ptr] = 0 if $t_ptr > $#tape; };
  } elsif ($ch eq "<") {
    push @prog, sub { $t_ptr--; };
  } elsif ($ch eq "+") {
    push @prog, sub { $tape[$t_ptr] = !$tape[$t_ptr]; };
  } elsif ($ch eq ",") {
    push @prog, sub { my $ch = getc();
                      $tape[$t_ptr] = defined($ch) ? $ch + 0 : 0; };
  } elsif ($ch eq ".") {
    push @prog, $debug ?
      sub { print($tape[$t_ptr] ? "1\n" : "0\n"); } :
      sub { print($tape[$t_ptr] ? "1" : "0"); };
  } elsif ($ch eq "[") {
    push @bracket, $#prog+1;
  } elsif ($ch eq "]") {
    do {
      my @p2 = splice @prog, pop(@bracket);
      push @prog,
        sub { @prog = (@p2, shift, @prog) if $tape[$t_ptr] };
    };
  }
}

while (scalar @prog) {
  print join(" ", map { $_ ? 1 : 0 } @tape[0 .. $t_ptr]), "@",
    join(" ", map { $_ ? 1 : 0 } @tape[$t_ptr+1 .. $#tape]), "\n" if $debug;
  my $i = shift @prog;
  $i->($i);
}