I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

RCSNUSP/Mathematica

From Rosetta Code
$IterationLimit = Infinity;
next[{x_, y_}, dir_] := {x, y} +
Switch[dir, Up, {0, -1}, Down, {0, 1}, Left, {-1, 0},
Right, {1, 0}];
lurd[dir_] :=
Switch[dir, Up, Left, Down, Right, Left, Up, Right, Down];
ruld[dir_] :=
Switch[dir, Up, Right, Down, Left, Left, Down, Right, Up];
snusp[prog_, {x_, y_}, _, out_, _, _, _] /;
x < 1 || y < 1 || y > Length[prog] || x > Length[prog[[1]]] :=
out;
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "<" :=
snusp[prog, next[{x, y}, dir], in, out, dir,
If[ptr == 1, Prepend[tape, 0], tape], Max[ptr - 1, 1]];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == ">" :=
snusp[prog, next[{x, y}, dir], in, out, dir,
If[ptr == Length[tape], Append[tape, 0], tape], ptr + 1];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "+" :=
snusp[prog, next[{x, y}, dir], in, out, dir,
ReplacePart[tape, ptr -> Mod[tape[[ptr]] + 1, 256]], ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "-" :=
snusp[prog, next[{x, y}, dir], in, out, dir,
ReplacePart[tape, ptr -> Mod[tape[[ptr]] - 1, 256]], ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "," :=
snusp[prog, next[{x, y}, dir], If[in == "", "", StringDrop[in, 1]],
out, dir,
ReplacePart[tape,
ptr -> If[in == "", 255, ToCharacterCode[in][[1]]]], ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "." :=
snusp[prog, next[{x, y}, dir], in,
out <> FromCharacterCode[tape[[ptr]]], dir, tape, ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "\\" :=
snusp[prog, next[{x, y}, lurd[dir]], in, out, lurd[dir], tape,
ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "/" :=
snusp[prog, next[{x, y}, ruld[dir]], in, out, ruld[dir], tape,
ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "!" :=
snusp[prog, next[next[{x, y}, dir], dir], in, out, dir, tape, ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] /;
prog[[y, x]] == "?" :=
snusp[prog, If[tape[[ptr]] == 0, next, # &][next[{x, y}, dir], dir],
in, out, dir, tape, ptr];
snusp[prog_, {x_, y_}, in_, out_, dir_, tape_, ptr_] :=
snusp[prog, next[{x, y}, dir], in, out, dir, tape, ptr];
input[] :=
Block[{l = InputString[]},
If[l === EndOfFile, "", l <> "\n" <> input[]]];
If[Length[$ScriptCommandLine] < 2,
WriteString["stderr",
"Usage: WolframScript -script " <> $ScriptCommandLine[[1]] <>
" <file...>\n"]; Quit[]];
file = StringRiffle[$ScriptCommandLine[[2 ;;]]];
If[! FileExistsQ[file],
WriteString["stderr",
"Error: File '" <> file <> "' does not exist.\n"]; Quit[]];
sProg = StringSplit[ReadString[file], "\n"];
gProg = PadRight[Characters[#], Max[StringLength /@ sProg], " "] & /@
sProg;
Print[snusp[gProg,
FirstPosition[gProg,
"$"] /. {{y_, x_} :> {x, y}, _Missing -> {1, 1}},
StringDrop[input[], -1], "", Right, {0}, 1]];

Run as WolframScript -script <file> <program...>.