use strict;
use warnings;
use 5.10.0;
use Carp;

my %code;
my %vars;
my %funcs;
my %arrays;
my %fors;
my @strs;    # We store string constants here to ease parsing
my $firstLine;
my $lastLine;
my $parseLine;
my $idMatch = qr/([A-Z]\d?\$?)/i;
my $parenRegex;
my $outCursor   = 0;
my %breakPoints = ();
my %tracing;

my $sourceFile = $ARGV[0] // 'StarTrek.bas';

open my $fIn, '<', $sourceFile or die "Can't open '$sourceFile': $!\n"
+;

srand 1;
++$|;
$parenRegex = qr{\(([^()]+ | (??{$parenRegex}))+\)}x;

while (<$fIn>) {
    chomp;
    next if /^#/;

    my ($lineNum, $line) = /^(\d+)\s+(.*)/;
    my $partNum = 0;

    croak "Bad line format: '$_' \@ $.\n" if !defined $line;

    # Parse out string constants so the line splitter doesn't get conf
+used
    # by strings containing colons
    while ($line =~ /"([^"]*)"/) {
        my $strNum = @strs;
        my $str    = $1;

        push @strs, $str;
        $line =~ s/"\Q$str\E"/s$strNum/;
    }

    for my $part (split ':', $line) {
        my $suffix = $partNum ? sprintf "-%02d", $partNum : '';
        my $lineId = $lineNum . $suffix;

        $code{$lastLine}{nextLine} = $lineId if $lastLine;
        $code{$lineId}{line}       = $part;
        $firstLine = $lineId
            if $lineId =~ /^\d+$/ && (!defined $firstLine || $lineId <
+ $firstLine);
        $lastLine = $lineId;
        ++$partNum;
    }
}

Dispatch($firstLine);


sub Dispatch {
    my ($currLine, $finishLine) = @_;

    while (!$finishLine || $currLine ne $finishLine) {
        croak "Bad \$currLine" if !defined $currLine;

        my $line     = $code{$currLine}{line};
        my $nextLine = $code{$currLine}{nextLine};

        $DB::single = 1 if !defined $line;
        $currLine   = Parse($currLine, $line, $nextLine);

        return if !defined $currLine;
    }
}


sub Parse {
    my ($currLine, $line, $nextLine) = @_;

    $DB::single = 1 if !defined $line;
    $parseLine  = $currLine;

    HandleTrace($currLine, $line);
    ParseTrace($currLine, $line);
    HandleBreak($currLine);

    if ($line =~ /^BREAK\s*(.*)/i) {
        my $breakValue = $1;

        if ($breakValue =~ /^(-?\d+)$/) {
            $breakPoints{$currLine} = $breakValue >= 1 ? $breakValue :
+ 0;
        } elsif (length $breakValue) {
            $breakPoints{$currLine} = lc $breakValue;
        } else {
            $breakPoints{$nextLine} = 1;
        }

        return $nextLine;
    } elsif ($line =~ /^DEF\s+(FN\w)\(([^)]+)\)=(.+)/i) {
        DoDef($currLine, $1, $2, $3);
    } elsif ($line =~ /^DIM/i) {
        # Nothing to do here. Perl sizes the arrays dynamically
    } elsif ($line =~ /^END/i) {
        exit;
    } elsif ($line =~ /^FOR\s*$idMatch=([^:]+)TO((?:(?!STEP).)+)(?:STE
+P(.*))?/i) {
        DoFor($currLine, uc $1, $2, $3, $4);
    } elsif ($line =~ /^GO\s*SUB\s*(\d+)/i) {
        Dispatch($1);
        return $nextLine;
    } elsif ($line =~ /^GO\s*TO\s*(\d+)/i) {
        return $1;
    } elsif ($line =~ /^IF\s*(.+?)\s*THEN\s*(.*)/i) {
        return DoIf($currLine, $1, $2);
    } elsif ($line =~ /^INPUT/i) {
        DoInput($currLine, $line);
    } elsif ($line =~ /^NEXT\s*$idMatch/i) {
        $nextLine = DoNext($currLine, uc $1);
    } elsif ($line =~ /^ON(.+?)GO(TO|SUB)\s*(.*)/i) {
        my $nextFullLine = GetNextFullLine($currLine);
        my ($value, $type, $tail) = ($1, $2, $3);
        my $selValue = Evaluate($currLine, $value);
        my @targets  = FindParams($tail);
        my $badValue = !defined $selValue || $selValue > @targets || $
+selValue < 1;
        my $target   = $badValue ? $nextFullLine : $targets[$selValue 
+- 1];

        $type = 'TO' if $badValue;
        print "> $currLine ON $value($selValue) GO$type $target\n"
            if $tracing{all};
        return $target if $type eq 'TO';

        Dispatch($targets[$selValue - 1]);
    } elsif ($line =~ /^PRINT\s*(.*)/i) {
        DoPrint($currLine, $1);
    } elsif ($line =~ /^REM/i) {
        # nothing to do here but make sure we skip the entire line
        return GetNextFullLine($currLine);
    } elsif ($line =~ /^RETURN/i) {
        return;
    } elsif ($line =~ /^STOP/i) {
        print "STOP\n";
        exit;
    } elsif ($line =~ /^TRACE(|FOR\w|VARS|ALL)\b/i) {
        ParseTrace($currLine, $line);
    } elsif ($line =~ /^$idMatch\s*=\s*(.*)/) {
        DoAssign($currLine, uc $1, $2);
    } elsif ($line =~ /^$idMatch\(([^)]+)\)\s*=\s*(.*)/) {
        DoArrayAssign($currLine, uc $1, $2, $3);
    } else {
        croak "Can't handle '$line' @ $currLine";
    }

    return $nextLine;
}


sub HandleBreak {
    my ($context) = @_;

    return if !exists $breakPoints{$context};

    my $result = eval {
        my $type = ref $breakPoints{$context};

        if ($type eq 'CODE') {
            my @result = $breakPoints{$context}->();

            return            if !@result;
            return $result[0] if @result == 1;

            while (@result) {
                my ($line, $value) = splice @result, 0, 2;

                $breakPoints{$line} = $value;
            }

            return;
        }

        return $breakPoints{$context};
    };

    return if !$result;

    delete $breakPoints{$context};
    $DB::single = 1;
}


sub ParseTrace {
    my ($currLine, $line) = @_;

    if ($line =~ /^TRACE\s*OFF/i) {
        $tracing{lines} = 0;
    } elsif ($line =~ /^TRACE\s*ON/i) {
        $tracing{lines} = 1;
    } elsif ($line =~ /^TRACEALL\s*OFF/i) {
        $tracing{all} = 0;
    } elsif ($line =~ /^TRACEALL\s*ON/i) {
        $tracing{all} = 1;
    } elsif ($line =~ /^TRACEVARS\s*OFF/i) {
        $tracing{vars} = 0;
    } elsif ($line =~ /^TRACEVARS\s*ON/i) {
        $tracing{vars} = 1;
    }
    if ($line =~ /^TRACEFOR([A-Z])\s*OFF/i) {
        $tracing{"FOR$1"} = 0;
    } elsif ($line =~ /^TRACEFOR([A-Z])\s*ON/i) {
        $tracing{"FOR$1"} = 1;
    }
}


sub HandleTrace {
    my ($currLine, $line) = @_;

    print "> $currLine: $line\n" if $tracing{lines} || $tracing{all};
}


sub DoArrayAssign {
    my ($currLine, $id, $index, $value) = @_;
    $value = Evaluate($currLine, $value);

    HandleBreak('[]=');

    my $access = ArrayAccessStr($currLine, $id, $index);
    my $str    = $access . '= $value';
    eval $str;

    print "   $id($index): ", eval($access), "\n"
        if $tracing{vars} || $tracing{all};
    return;
}


sub ArrayAccessStr {
    my ($currLine, $id, $index) = @_;
    my @indexes = FindParams($index);

    HandleBreak('[]');
    $_ // croak "Bad index in '$index' @ $currLine\n" for @indexes;
    @indexes = map {Evaluate($currLine, $_)} @indexes;
    return '$arrays{$id}[' . join('][', @indexes) . ']';
}


sub DoAssign {
    my ($currLine, $id, $tail) = @_;

    HandleBreak('=');
    $tail =~ s/s(\d+)/'"' . $strs[$1] . '"'/ge if $id =~ /\$/;
    $vars{$id} = Evaluate($currLine, $tail);
    print "   $id: $vars{$id}\n" if $tracing{vars} || $tracing{all};
}


sub DoDef {
    my ($currLine, $fnName, $param, $def) = @_;

    $funcs{$fnName}{expr}  = $def;
    $funcs{$fnName}{param} = $param;
}


sub DoFor {
    my ($currLine, $id, $from, $to, $step) = @_;

    HandleBreak('for');

    if (!exists $fors{$id} || $fors{$id}{forLine} ne $currLine) {
        # Entering the for loop
        $step ||= 1;
        $vars{$id}          = Evaluate($currLine, $from);
        $fors{$id}{step}    = Evaluate($currLine, $step);
        $fors{$id}{end}     = Evaluate($currLine, $to);
        $fors{$id}{forLine} = $currLine;
        print
            "> $currLine: FOR $id: $vars{$id} TO $fors{$id}{end} STEP 
+$fors{$id}{step}\n"
            if $tracing{"FOR$id"} || $tracing{all};
    }

    print "> $currLine: FOR $id = $vars{$id}\n"
        if $tracing{"FOR$id"} || $tracing{all};
}


sub DoIf {
    my ($currLine, $exp, $tail) = @_;
    my $nextFullLine = GetNextFullLine($currLine);

    HandleBreak('if');

    my $value = Evaluate($currLine, $exp);

    return $nextFullLine if !$value;

    # value is true so process the THEN part and any following
    # statements on the line.
    return $tail if $tail =~ /^\s*\d/;

    my $nextLine = $code{$currLine}{nextLine};

    return Parse($currLine, $tail, $nextLine);
}


sub DoInput {
    my ($currLine, $line) = @_;

    $line =~ s/s(\d+)/'"' . $strs[$1] . '"'/ge;

    my ($prompt, $tail) = $line =~ /^\s*INPUT\s*(?:"([^"]*)";)?(.*)/i;

    print "$prompt? " if $prompt;

    my @iVars     = FindParams($tail);
    my @iVarsCopy = @iVars;

    do {
        my $input = uc <STDIN>;

        return if !defined $input;
        chomp $input;

        while (@iVars && length $input) {
            my $param;

            $param = $1 if $input =~ s/^("[^"]*"|[^,]*),?//;
            $param =~ s/^"(.*)"/$1/;
            $vars{uc shift @iVars} = $param;
        }

        print "?? " if @iVars;
    } while @iVars;

    if ($tracing{vars} || $tracing{all}) {
        print "$currLine INPUT: \n";
        print "  $_ = '$vars{$_}'\n" for map {uc} @iVarsCopy;
    }
}


sub DoNext {
    my ($currLine, $id) = @_;
    my $lineEntry = $code{$currLine};

    croak "For '$id' isn't active \@ $currLine" if !exists $fors{$id};

    # for loop is active
    $vars{$id} += $fors{$id}{step};

    if ($fors{$id}{step} > 0) {
        return $fors{$id}{forLine} if $vars{$id} <= $fors{$id}{end};
    } else {
        return $fors{$id}{forLine} if $vars{$id} >= $fors{$id}{end};
    }

    delete $tracing{"FOR$1"} if $tracing{"FOR$1"};
    delete $fors{$id};
    return $code{$currLine}{nextLine};
}


sub DoPrint {
    my ($currLine, $tail) = @_;

    if (!length $tail) {
        print "\n";
        $outCursor = 0;
        return;
    }

    # Process parenthesis before splitting print tail into parts
    my @paren_contents;
    $tail =~
        s{($parenRegex)}{push(@paren_contents, $1);"[p$#paren_contents
+]"}eg;

    my @parts = split /(;|,)/, $tail;
    my $str   = "";

    # restore parens
    s{\[p(\d+)\]}{($paren_contents[$1])}eg for @parts;

    for my $part (@parts) {
        next if $part eq ';';

        if ($part eq ',') {
            my $mod = length($str) % 14;
            $str .= ' ' x (14 - $mod) if $mod;
            next;
        }

        if ($part =~ /^\s*s(\d+)/) {
            $str .= $strs[$1];
            next;
        }

        my $value = Evaluate($currLine, $part);

        $DB::single = 1                                  if !defined $
+value;
        croak "Bad print expression '$part' @ $currLine" if !defined $
+value;

        if ($value =~ /^"(.*)"$/) {
            $str .= $1;
            next;
        }

        $str .= ' ' if $value >= 0;
        $str .= $value;
        $str .= ' ';
    }

    print $str;
    $outCursor += length $str;

    return if $parts[-1] =~ /;|,/;

    print "\n";
    $outCursor = 0;
}


sub Evaluate {
    my ($currLine, $exp) = @_;

    croak "Bad expression @ $currLine" if !defined $exp;

    $exp =~ s/^\s+|\s+$//g;    # Strip leading and trailing white spac
+e

    # If parentheses surround the entire expression, get rid of them.
    $exp = substr($exp, 1, -1) while $exp =~ /\A($parenRegex)\z/;

    return $exp if $exp =~ /^[+-]?[0-9.]+(?:[eE][+-]?\d*)?$/; # Number
    return $exp if $exp =~ /^"[^"]*"$/; # String
    return qq{"$strs[$1]"} if $exp =~ /^s(\d+)$/; # Cached string

    # Replace stuff in parentheses with its value.
    my @paren_contents;
    $exp =~ s{($parenRegex)}{push(@paren_contents, $1);"[p$#paren_cont
+ents]"}eg;

    if ($exp =~ m{^\s*$idMatch\[p(\d+)\]$}) {
        my $id       = uc $1;
        my $paramStr = $2;

        $paren_contents[$paramStr] =~ s/^\((.*)\)$/$1/;

        my $str    = ArrayAccessStr($currLine, $id, $paren_contents[$p
+aramStr]);
        my $result = eval $str;

        $result = qq{"$result"} if $id =~ /\$/;
        return $result;
    }

    if ($exp =~ m{^(\w+\$?)\[p(\d+)\]$}) {
        my $funcStr  = $1;
        my $paramStr = $2;
        my $result = EvalFunc($currLine, $funcStr, $paren_contents[$pa
+ramStr]);

        $exp =~ s/\Q$funcStr\E\[p$paramStr\]/$result/;
        return Evaluate($currLine, $exp);
    }

    # Scan for operators in order of increasing precedence, preferring
+ the
    # rightmost. Left to right binding is enforced by the order of pro
+cessing
    # left and right terms of the detected operator.
    # Recursive evaluation of left and right terms ensures correct pro
+cessing
    # precedence
    if (    $exp !~ m{^(.+?)(OR)(.+)}
        and $exp !~ m{^(.+?)(AND)(.+)}
        and $exp !~ m{^([^<>=]+)(<>|<=|>=|>|<|=)(.+)}
        and $exp !~ m{^([^+]+)([+])(.+)}
        and $exp !~ m{^(-?[^-]+)([-])([^+-]+)(.*)}
        and $exp !~ m{^([^*]+)([*])(.+)}
        and $exp !~ m{^([^/]+)([/])([^/*]+)(.*)}
        and $exp !~ m{^([^^]+)(\^)(.+)}
        and $exp !~ m{^(\s*)(NOT)(.+)}
    ) {
        return $vars{uc $exp}        if exists $vars{uc $exp};
        return $fors{uc $exp}{value} if exists $fors{uc $exp};
        $DB::single = 1;
        croak "Can't handle expression: '$exp' @ $currLine";
    }

    my ($op, $lhs, $rhs, $tail) = ($2, $1, $3, $4);
    my $isBoolResult = $op =~ /<|=|>|NOT/;

    $op = lc $op;
    $op = '!=' if $op eq '<>';
    $op = '**' if $op eq '^';
    $op = '==' if $op eq '=';
    s{\[p(\d+)\]}{($paren_contents[$1])}eg for $lhs, $rhs;

    HandleBreak($op);
    $_ = Evaluate($currLine, $_) || 0 for $lhs, $rhs;

    croak "Bad expression @ $currLine"
        if !defined $lhs || !defined $rhs || !defined $op;

    my $strOp = grep {/"|\$/} $lhs, $rhs;

    $op = {
        '+'  => '.',
        '!=' => 'ne',
        '==' => 'eq',
        '<'  => 'lt',
        '>'  => 'gt',
        '<=' => 'le',
        '>=' => 'ge',
        }->{$op}
        if $strOp;

    my $result = eval "$lhs $op $rhs";

    if ($op =~ m{[-/]} && defined $tail && length $tail) {
        # Special case handling of - and / so that rhs operand is eval
+uated
        # correctly.
        return Evaluate($currLine, "$result$tail");
    }

    $result = qq{"$result"} if $op eq '.';
    $result = 0 if $isBoolResult && (!defined $result || !length $resu
+lt);
    print "  $result = $lhs $op $rhs\n" if $tracing{all};
    return $result;
}


sub EvalFunc {
    my ($currLine, $fName, $param) = @_;

    HandleBreak(lc $fName);
    $param =~ s/^\(|\)$//g;

    if (exists $funcs{$fName}) {
        my $expr = $funcs{$fName}{expr};

        $expr =~ s/\b$funcs{$fName}{param}\b/$param/g;

        my $result = Evaluate($currLine, $expr);

        return $result;
    } elsif ($fName eq 'ABS') {
        return abs Evaluate($currLine, $param);
    } elsif ($fName eq 'INT') {
        return int Evaluate($currLine, $param);
    } elsif ($fName eq 'LEFT$') {
        my ($str, $len) = map {Evaluate($currLine, $_)} FindParams($pa
+ram);

        $str =~ s/^"(.*)"$/$1/;
        return '"' . substr($str, 0, $len) . '"';
    } elsif ($fName eq 'LEN') {
        # Remove for the embedded quotes for a string retuned by Evalu
+ate
        return length(Evaluate($currLine, $param)) - 2;
    } elsif ($fName eq 'MID$') {
        my ($str, $start, $len) =
            map {Evaluate($currLine, $_)} FindParams($param);

        $str =~ s/^"(.*)"$/$1/;
        return '"' . substr($str, $start - 1, $len) . '"';
    } elsif ($fName eq 'RIGHT$') {
        my ($str, $len) = map {Evaluate($currLine, $_)} FindParams($pa
+ram);

        $str =~ s/^"(.*)"$/$1/;
        return '"' . substr($str, -$len) . '"';
    } elsif ($fName eq 'RND') {
        state $last = 0;
        my $paramValue = Evaluate($currLine, $param);

        return $last = rand if $paramValue > 0;
        return $last        if $paramValue == 0;
        return srand $paramValue;
    } elsif ($fName eq 'SQU') {
        return sqrt(Evaluate($currLine, $param));
    } elsif ($fName eq 'SQR') {
        my $value = Evaluate($currLine, $param);
        return $value * $value;
    } elsif ($fName eq 'STR$') {
        return sprintf qq{"%d"}, Evaluate($currLine, $param);
    } elsif ($fName eq 'TAB') {
        my $col = Evaluate($currLine, $param);
        $col = $outCursor if $col < $outCursor;
        return '"' . (' ' x ($col - $outCursor)) . '"';
    } else {
        $DB::single = 1;
        croak "Can't handle '$fName' @ $currLine";
    }
}


sub FindParams {
    my ($tail) = @_;
    my @paren_contents;
    $tail =~
        s{($parenRegex)}{push(@paren_contents, $1);"[p$#paren_contents
+]"}eg;

    my @parts = split /,/, $tail;

    # restore parens
    s{\[p(\d+)\]}{($paren_contents[$1])}eg for @parts;
    return @parts;
}


sub GetNextFullLine {
    my ($currLine) = @_;

    # Find all the parts on the current line
    my ($lineMatch) = $currLine =~ /^(\d+)/;
    my @parts = sort grep {/^(\d+)(?:-(\d+))?/ && $1 == $lineMatch} ke
+ys %code;

    return $code{$parts[-1]}{nextLine};
}
[download]