Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

A BASIC interpreter to run StarTrek

by GrandFather (Saint)
on Aug 11, 2021 at 12:03 UTC ( #11135785=CUFP: print w/replies, xml ) Need Help??

Many years ago I spent a chunk of time playing StarTrek written in BASIC on a PDP11. I stumbled on BASIC source for the game recently and thought it might be cool to write a BASIC interpreter in Perl to run it. This is the result (click the Readmore to see the code).

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.

Update: Changed chomp to s/\r?\n// per roboticus's suggestion. Thank's too to cavac for also picking up on the issue.
Commented out srand 1 used to get a consistent game world for debugging.
Update to make parser case agnostic for key words and identifiers.
Fix parameter parsing bug,

Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond

Replies are listed 'Best First'.
Re: A BASIC interpreter to run StarTrek
by cavac (Curate) on Aug 11, 2021 at 14:03 UTC

    Cool!

    A few things: Seems you developed this on Windows. Other OS are case sensitive regarding the filesystem, so the correct filename to save the BASIC program would is StarTrek.bas (note the uppercase letters).

    Another thing: Perl uses "native" line endings by default. I had to convert the bas file to Unix line endings for the interpreter to work for the first test.

    Here's a simple patch that should make this work on Linux and possibly also on Mac:

    diff -u basicinterpreter.pl basicinterpreter_fixed.pl --- basicinterpreter.pl 2021-08-11 15:51:20.359658237 +0200 +++ basicinterpreter_fixed.pl 2021-08-11 16:01:08.724748447 +0200 @@ -28,6 +28,8 @@ while (<$fIn>) { chomp; + s/\r//g; + s/\n//g; next if /^#/; my ($lineNum, $line) = /^(\d+)\s+(.*)/;

    perl -e 'use Crypt::Digest::SHA256 qw[sha256_hex]; print substr(sha256_hex("the Answer To Life, The Universe And Everything"), 6, 2), "\n";'
      Seems you developed this on Windows

      Guilty as charged. Usually I'd at least have gotten the file name case consistent, but it was a few minutes past bed time and I created the node in a bit of a rush. Sorry about that. Fixed now along with the line ending issue.

      Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
Re: A BASIC interpreter to run StarTrek
by roboticus (Chancellor) on Aug 11, 2021 at 14:07 UTC

    GrandFather:

    Very fun! I had created a version of Star Trek to run on a 4K TRS-80 with Level II BASIC back in the stone age. In order to make it fit, I had to keep cutting bits out, and I eventually called it "RandoTrek" because there was so little storage available I had to randomly generate each sector on demand. (I still remember "3284 bytes free" as the amount of RAM I had until I could afford the 16K upgrade.)

    Anyway, I just wanted to mention that I had to change the chomp statement to s/\r?\n// because the line endings on the BASIC program were CR+LF and cygwin perl was expecting LF. That caused the interpreter to fail when trying to branch to line "1200\r". I've not played the game yet, as I'm at work now, but at least that let me get to the first COMMAND prompt. I'll likely give it a go on my lunch break. ;^)

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.

      Those were pretty insane days, and a lot of fun!

      Thanks for the heads up about the line endings issue. Now fixed as suggested.

      Note that I left a srand 1; in the code which I'd been using while debugging to get a consistent game world. Probably best to comment that out.

      Maybe of interest is that the interpreter provides support for TRACE statements (see ParesTrace for usage hints) and break statements (that break into the debugger) - just in case you feel inclined to do a little exploration.

      Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
Re: A BASIC interpreter to run StarTrek
by GrandFather (Saint) on Aug 11, 2021 at 12:05 UTC

    and the BASIC source for StarTrek: (note: copy the following into a file called StarTrek.bas in the same folder as the Perl source given in the OP)

    Update: corrected case of suggested file name (thanks cavac).

    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
      > FORI=1TO8:D(I)=0:NEXTI

      I remember the book that's from, one of the early bestsellers in computer literature:)

      But was the lack of whitespace between constructs and variables really originally so?

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      Wikisyntax for the Monastery

        BASIC was widely adopted in mini-computers and micro-computers with very limited memory so most implementations allowed white space to be expunged. The original Dartmouth BASIC doesn't mention the option of omitting spaces so that probably wasn't a thing.

        Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
Re: A BASIC interpreter to run StarTrek
by LanX (Sage) on Aug 12, 2021 at 17:11 UTC
    You might also be interested to look into Language::Basic :)

    Not sure if there is more on CPAN , since searching for "basic" is producing too many unrelated hits.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

Re: A BASIC interpreter to run StarTrek
by fishy (Friar) on Aug 12, 2021 at 15:30 UTC
    Interesting work.

    Thank you!

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://11135785]
Approved by Corion
Front-paged by haj
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (3)
As of 2021-11-28 18:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?