There are bound to be bugs in the code still, but I've spent a little time playing the game and it seems to substantially work (i.e. I haven't seen any breakage).
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};
}
The BASIC script for the StarTrek program is given in a reply to this node.