use warnings; use strict; my %xlate = ( '.?' => \&DoRight, '?.' => \&DoLeft, '..' => \&DoInc, '!!' => \&DoDec, '!.' => \&DoOut, '.!' => \&DoIn, '!?' => \&DoWhile, '?!' => \&DoElihw ); my @tape = 0; # Storage "Tape" my $head = 0; # Read / Write head my $pc = 0; # Program counter my @stack; # Optimise loop handling my $inBuffer; my $debug = shift || 0; my $steps = 0; my $program = join " ", ; $program =~ s/Ook([.?!])\s*Ook([?.!])\s*/$1$2 /gi; my @code = map {$xlate{$_}} split " ", $program; $code[$pc]->() while ($pc < @code); sub debugPrint { return if ! $debug; print $_[0] . ": PC $pc, Stack depth " . @stack . "\n"; die "Instruction count exceeded\n" if ++$steps > $debug; } sub DoRight { debugPrint ("DoRight"); $tape [++$head] ||= undef; ++$pc; } sub DoLeft { debugPrint ("DoLeft"); unshift @tape, 0 unless $head; --$head if $head; ++$pc; } sub DoInc { debugPrint ("DoInc"); if (++$tape [$head] > 255) {$tape [$head] = -255;} ++$pc; } sub DoDec { debugPrint ("DoDec"); if (--$tape [$head] < -255) {$tape [$head] = 255;} ++$pc; } sub DoOut { debugPrint ("DoOut"); print chr ($tape [$head]); ++$pc; } sub DoIn { debugPrint ("DoIn"); if (! $inBuffer) {$inBuffer = ;} $tape [$head] = ord substr $inBuffer, 0, 1, ""; ++$pc; } sub DoWhile { debugPrint ("DoWhile"); if ($tape [$head]) {# Enter the loop push @stack, $pc; ++$pc; return; } # Skip the loop my $nested = 1; # Keeps track of nested loops my $startPc = $pc; do { --$nested if $code [++$pc] == \&DoElihw; ++$nested if $code [$pc] == \&DoWhile; die "Unmatched Ook! Ook? found at instruction $startPc\n" if $pc > @code; } while ($nested); ++$pc; } sub DoElihw { debugPrint ("DoElihw"); die "Unmatched Ook? Ook! found at instruction $pc\n" if ! @stack; $pc = $stack [-1]; pop @stack; }