|
2020
|
1 #!/usr/bin/env perl
|
|
|
2 # -*- cperl -*-
|
|
|
3 # Shove interpreter. By Alex Smith.
|
|
|
4
|
|
|
5 # Commands:
|
|
|
6 # ' " Quote a string ('' strings nest inside "" strings and vice versa)
|
|
|
7 # < v > ^ Change direction of execution
|
|
|
8 # A V ( ) Pop a string onto the playfield
|
|
|
9 # space NOP
|
|
|
10
|
|
|
11 # ! NOP, but tells the compiler that everything behind the IP will
|
|
|
12 # never be used (a useful optimisation)
|
|
|
13 # S NOP, but outputs TOS (without popping) on systems with output
|
|
|
14 # n NOP, but outputs a newline on systems with output
|
|
|
15
|
|
|
16 use strict;
|
|
|
17
|
|
|
18 # Read in the program
|
|
|
19
|
|
2023
|
20 my $debug = ($#ARGV >= 0 and $ARGV[0] eq '-d' and shift and 1);
|
|
2026
|
21 my @program = ($#ARGV >= 0 and ($ARGV[0] ne '-f' or (shift and 0)))
|
|
|
22 ? @ARGV : <>;
|
|
2020
|
23 chomp for @program;
|
|
|
24
|
|
|
25 my $x = 0;
|
|
|
26 my $y = 0;
|
|
|
27 my $width = 0; $width = ($width < length $_ ? length $_ : $width) for @program;
|
|
|
28 my $height = scalar @program;
|
|
|
29 my $totalrotation = 0;
|
|
|
30 my @stack = ();
|
|
|
31 # always going right, we rotate the program if necessary to ensure this
|
|
|
32
|
|
|
33 # Pads its argument to width $width.
|
|
|
34 sub widthpad {
|
|
|
35 my $s = shift;
|
|
|
36 return $s . (' ' x ($width - length $s));
|
|
|
37 }
|
|
|
38
|
|
|
39 # Rotates the program clockwise (arg = 1), 180 degrees (arg = 2),
|
|
|
40 # or anticlockwise (arg = 3)
|
|
|
41 sub rotateprogram {
|
|
|
42 my $amount = shift;
|
|
|
43 $amount or return;
|
|
|
44 $totalrotation += $amount;
|
|
|
45 $totalrotation %= 4;
|
|
|
46 if ($amount >= 2) {
|
|
|
47 @program = reverse @program;
|
|
|
48 $_ = reverse widthpad $_ for @program;
|
|
|
49 $x = $width - 1 - $x;
|
|
|
50 $y = $height - 1 - $y;
|
|
|
51 tr/<v>^AV()/>^<vVA)(/ for @program;
|
|
|
52 $amount == 2 and return;
|
|
|
53 } else {
|
|
|
54 $_ = widthpad $_ for @program;
|
|
|
55 }
|
|
|
56 my @newprog = ();
|
|
|
57 # We repeatedly move the leftmost column of @program to the top row
|
|
|
58 # of @newprog.
|
|
|
59 while (length $program[0]) {
|
|
|
60 my $build='';
|
|
|
61 $build = (substr $_, 0, 1, '') . $build for @program;
|
|
|
62 push @newprog, $build;
|
|
|
63 }
|
|
|
64 @program = @newprog;
|
|
|
65 tr/<^>v(A)V/^>v<A)V(/ for @program;
|
|
|
66 ($width, $height) = ($height, $width);
|
|
|
67 ($x, $y) = ($width - 1 - $y, $x);
|
|
|
68 }
|
|
|
69
|
|
|
70 sub shove {
|
|
|
71 my $sx = shift;
|
|
|
72 my $sy = shift;
|
|
|
73 if($sx < 0) {
|
|
|
74 $_ = ' '.$_ for @program;
|
|
|
75 $x++;
|
|
|
76 $sx++;
|
|
|
77 $width++;
|
|
|
78 }
|
|
|
79 if($sx >= $width) {
|
|
|
80 $width++;
|
|
|
81 }
|
|
|
82 if($sy < 0) {
|
|
|
83 unshift @program, "";
|
|
|
84 $y++;
|
|
|
85 $sy++;
|
|
|
86 $height++;
|
|
|
87 }
|
|
|
88 if($sy >= $height) {
|
|
|
89 push @program, "";
|
|
|
90 $height++;
|
|
|
91 }
|
|
|
92 scalar @stack or die "Empty stack when shoving.";
|
|
|
93 $program[$sy] = widthpad $program[$sy];
|
|
|
94 ($x > $sx && $y == $sy) and $x += length $stack[0];
|
|
|
95 substr $program[$sy], $sx, 0, shift @stack;
|
|
|
96 $program[$sy] =~ s/\ +$//;
|
|
|
97 $width < length $program[$sy] and $width = length $program[$sy];
|
|
|
98 }
|
|
|
99
|
|
|
100 sub showprogram {
|
|
|
101 my $tr = $totalrotation;
|
|
|
102 print "\nactual size: ($width, $height), pos: ($x, $y)\n";
|
|
|
103 rotateprogram ((4-$tr)%4);
|
|
|
104 $program[$y] = widthpad $program[$y];
|
|
|
105 my $c = substr $program[$y], $x, 1, '*';
|
|
|
106 print "rotated for viewing; pos: ($x, $y), dir: $tr\n";
|
|
|
107 print "stack: ";
|
|
|
108 print "{$_} " for @stack;
|
|
|
109 print "\n";
|
|
|
110 print "$_\n" for @program;
|
|
|
111 substr $program[$y], $x, 1, $c;
|
|
|
112 rotateprogram $tr;
|
|
2026
|
113 scalar <STDIN>;
|
|
2020
|
114 }
|
|
|
115
|
|
|
116 while ($x < $width && $y < $height && $x >= 0 && $y >= 0) {
|
|
2023
|
117 showprogram if $debug;
|
|
2020
|
118 my $cmd = substr $program[$y], $x, 1;
|
|
|
119 # $cmd eq '>' is a nop
|
|
|
120 $cmd eq '^' and rotateprogram 1;
|
|
|
121 $cmd eq '<' and rotateprogram 2;
|
|
|
122 $cmd eq 'v' and rotateprogram 3;
|
|
|
123 $cmd eq '(' and shove $x-1, $y;
|
|
|
124 $cmd eq ')' and shove $x+1, $y;
|
|
|
125 $cmd eq 'A' and shove $x, $y-1;
|
|
|
126 $cmd eq 'V' and shove $x, $y+1;
|
|
|
127 $cmd eq 'S' and print $stack[0];
|
|
|
128 $cmd eq 'n' and print '\n';
|
|
|
129 if ($cmd eq '!') {
|
|
|
130 substr $_, 0, $x, '' for @program;
|
|
|
131 $width -= $x;
|
|
|
132 $x = 0;
|
|
|
133 }
|
|
|
134 if ($cmd eq '"' || $cmd eq "'") {
|
|
|
135 my $quotecount = 1;
|
|
|
136 my $lws = $cmd eq "'";
|
|
|
137 my $newpush = "";
|
|
|
138 while($quotecount) {
|
|
|
139 $x++;
|
|
|
140 $x < $width or die "Unterminated string.";
|
|
|
141 $cmd = substr $program[$y], $x, 1;
|
|
|
142 $cmd eq "'" and ($quotecount += ($lws ? -1 : 1)), ($lws = !$lws);
|
|
|
143 $cmd eq '"' and ($quotecount += ($lws ? 1 : -1)), ($lws = !$lws);
|
|
|
144 $quotecount and $newpush .= $cmd;
|
|
|
145 }
|
|
|
146 unshift @stack, $newpush;
|
|
|
147 }
|
|
2023
|
148 $x++; # move to next command
|
|
2020
|
149 }
|
