#!/usr/bin/perl

use strict; # tinylanguage
use warnings;

sub node { bless [ splice @_, 1 ], shift } # create perl object
sub error { my $line = substr($_, 0, pos($_)) =~ tr/\n// + 1;
  tr/\n// < 2 ? die s/\G.*//sr =~ tr/\t/ /cr, "^ $_[0] !\n" :
  die "\nERROR near line $line:\n", s/\G(.{0,30}).*/[** @_ **]$1/sr, "\n" }
sub want { /\G$_[1]/gc ? shift : error pop }
my $ws = qr/(?:#.*+|\s++)*+/; # match white space
my $pad = ' ' x 4;            # AST indent padding
my %variables;                # variable storage

sub expr                      # parse section
  {
  /\G$ws/gc;
  my $tree =
    /\G(print|putc?|int)\b/gc ? node uc $1 => expr(3) :
    /\G(?:(-?\d+)|'(.*?)')/gc ? node NUMBER => $+ :  # or string
    /\G(\w+)$ws=(?!=)/gc      ? node STORE => "$1", expr(3) :
    /\G\w+/gc                 ? node FETCH => $& :
    /\G-/gc                   ? node UMINUS => expr(8) :
    /\G\+/gc                  ? expr(8) :
    /\G\(/gc                  ? want expr(0), qr/\)/, 'Missing Right Paren' :
    /\G\{/gc                  ? want expr(0), qr/\}/, 'Missing Right Brace' :
    error 'Operand Expected';
  $tree =
    /\G$ws/gc ? $tree :
    $_[0] <= 9 && /\G\;(?=$ws(?:\z|\)|\}))/gc ? $tree : # ignore redundant ;
    $_[0] <= 0 && /\G\;/gc ? node       STMT => # merging STMTs
      ref $tree eq 'STMT' ? @$tree : $tree, expr(1) :
    $_[0] <= 1 && /\Gwhile\b/gc ? node WHILE => $tree, expr(2) :
    $_[0] <= 2 && /\Gand\b/gc ? node     AND => $tree, expr(3) :
    $_[0] <= 3 && /\G\?/gc ? node       COND => $tree,
      want( expr(3), ':', 'Missing : '), expr(3) :
    $_[0] <= 4 && /\G==/gc ? node         EQ => $tree, expr(5) :
    $_[0] <= 5 && /\G>/gc ? node          GT => $tree, expr(6) :
    $_[0] <= 5 && /\G</gc ? node          LT => $tree, expr(6) :
    $_[0] <= 6 && /\G\+/gc ? node        ADD => $tree, expr(7) :
    $_[0] <= 6 && /\G\-/gc ? node   SUBTRACT => $tree, expr(7) :
    $_[0] <= 6 && /\G\./gc ? node     CONCAT => $tree, expr(7) :
    $_[0] <= 7 && /\G\*(?!\*)/gc ? node MULTIPLY => $tree, expr(8) :
    $_[0] <= 7 && /\G\//gc ? node     DIVIDE => $tree, expr(8) :
    $_[0] <= 7 && /\G%/gc ? node         MOD => $tree, expr(8) :
    $_[0] <= 7 && /\Gx\b/gc ? node       DUP => $tree, expr(8) :
    $_[0] <= 8 && /\G\*\*/gc ? node    POWER => $tree, expr(8) :
    return $tree while 1;
  }

sub      ADD::value { $_[0][0]->value + $_[0][1]->value } # execute section
sub SUBTRACT::value { $_[0][0]->value - $_[0][1]->value }
sub   CONCAT::value { $_[0][0]->value . $_[0][1]->value }
sub MULTIPLY::value { $_[0][0]->value * $_[0][1]->value }
sub   DIVIDE::value { $_[0][0]->value / $_[0][1]->value }
sub      MOD::value { $_[0][0]->value % $_[0][1]->value }
sub      DUP::value { $_[0][0]->value x $_[0][1]->value }
sub    POWER::value { $_[0][0]->value ** $_[0][1]->value }
sub      AND::value { $_[0][0]->value and $_[0][1]->value }
sub   UMINUS::value { - $_[0][0]->value }
sub      INT::value { int $_[0][0]->value }
sub     COND::value { $_[0][0]->value ? $_[0][1]->value : $_[0][2]->value }
sub   NUMBER::value { $_[0][0] }
sub    PRINT::value { print my $t = $_[0][0]->value, "\n"; $t }
sub      PUT::value { print my $t = $_[0][0]->value; $t }
sub     PUTC::value { print chr( my $t = $_[0][0]->value ); $t }
sub     STMT::value { (map $_->value, @{ $_[0] })[-1] }
sub       GT::value { $_[0][0]->value > $_[0][1]->value ? 1 : 0 }
sub       LT::value { $_[0][0]->value < $_[0][1]->value ? 1 : 0 }
sub       EQ::value { $_[0][0]->value == $_[0][1]->value ? 1 : 0 }
sub    WHILE::value { $_[0][0]->value while $_[0][1]->value; 0 }
sub    FETCH::value { $variables{$_[0][0]} // 0 }
sub    STORE::value { $variables{$_[0][0]} = $_[0][1]->value }

sub     FETCH::show { "FETCH $_[0][0]\n" } # display AST section
sub     STORE::show { "STORE $_[0][0]\n" . $_[0][1]->show =~ s/^/$pad/gmr}
sub    NUMBER::show { local $_ = $_[0][0]; /\s|^\z/ ? "'$_'\n" : "$_\n" }
sub UNIVERSAL::show
  { ref($_[0]) . "\n" . join('', map $_->show, @{$_[0]}) =~ s/^/$pad/gmr }

# begin translate to perl
my %var;
my %op = qw( ADD + SUBTRACT - MULTIPLY * DIVIDE / CONCAT . MOD %
  EQ == LT < GT > DUP x POWER ** AND and
  );
sub FETCH::var { $var{$_[0][0]}++ }
sub STORE::var { $var{$_[0][0]}++; $_[0]->SUPER::var }
sub UNIVERSAL::var { ref($_) and $_->var for @{ $_[0] } }
sub NUMBER::perl { qq("$_[0][0]") }
sub FETCH::perl { "\$$_[0][0]" }
sub STORE::perl { "\$$_[0][0] = @{[ $_[0][1]->perl ]}" }
sub PRINT::perl { "print @{[ $_[0][0]->perl ]}, \"\\n\"\n" }
sub PUT::perl { "print @{[ $_[0][0]->perl ]}\n" }
sub PUTC::perl {
  "do{local \$\@ = @{[$_[0][0]->perl]}; print chr \$\@\n; \$\@}" }
sub STMT::perl { join ';', map $_->perl, @{ $_[0] } }
sub WHILE::perl { "\nwhile(do{@{[$_[0][1]->perl]}}){" .
  "do{@{[$_[0][0]->perl]}}}" }
sub COND::perl { "do{@{[$_[0][0]->perl]}}\n" .
  "?" .
  "do{@{[$_[0][1]->perl]}}" .
  ":" .
  "do{@{[$_[0][2]->perl]}}" }
sub UNIVERSAL::perl { "do{@{[$_[0][0]->perl]}}\n" .
  "$op{ref $_[0]}\n" .
  "do{@{[$_[0][1]->perl]}}" }
# end translate to perl

@ARGV or local $/ = ''; # control section - read test cases by paragraph
for ( @ARGV ? <> : <DATA> )  # if no args, use DATA section test cases
  {
  %variables = ();
  s/\s*\z/\n/;
  /^last\n\z/ and last;
  /^\h*[^#\n]/m or next; # no uncommented code
  print;
  eval
    {
    my $tree = expr(0);
    pos($_) == length or error 'Incomplete Parse';
    print $tree->show; #   prints the AST
    $tree->value;      # executes the AST
    %var = ();         # generate perl from AST
    $tree->var;
    my $perl = "do{\n@{[ map qq(my \$$_ =), sort keys %var ]} 0;\n";
    $perl .= $tree->perl . '};1';
    print "\n$perl\n\n";
    eval $perl or die $@; # run the generated perl
    1 } or print "$@\n";
  print '-' x 70, "\n";
  }

__DATA__

print foobar

# inspired by https://rosettacode.org/wiki/Compiler/Sample_programs#Factorial
n = fact = 1;
fact = fact * n = n + 1 while n < 12;
print fact;
# 12 factorial is 479001600

n = 1;           # primes < 100
put 2;
(
i = isprime = 2;
n % i == 0 and isprime = 0 while isprime and ( i = i + 1 ) ** 2 - 1 < n;
isprime and put ' ' . n;
) while ( n = n + 2 ) < 100;
print ''  # output just a newline

( put foo = foo + (foo < 20 ? 2 : 10); put ' ' ) while foo < 100; print ''

stars = '*';               # triangle
{
print ' ' x ( 30 - n ) . stars;
stars = stars . '**'
} while (n = n + 1) < 11

ch = 65;                                  # A to Z
ch = ch + 1 while ( putc ch ) < 90;
print ''

# converted from
# https://rosettacode.org/wiki/Compiler/Sample_programs#Fibonacci_sequence
# fibonacci of 44 is 701408733
#
n = 44;
i = 1;
a = 0;
b = 1;
{
    w = a + b;
    a = b;
    b = w;
    i = i + 1;
} while (i < n);
print w

# converted from
# https://rosettacode.org/wiki/Compiler/Sample_programs#Greatest_common_divisor
# Compute the gcd of 1071, 1029:  21
#
a = 1071;
b = 1029;
#
{
    new_a = b;
    b     = a % b;
    a     = new_a;
} while b;
print a;


# This is an ascii Mandelbrot generator converted from
# https://rosettacode.org/wiki/Compiler/Sample_programs#Ascii_Mandlebrot
#
left_edge   = -420;
right_edge  =  300;
top_edge    =  300;
bottom_edge = -300;
x_step      =    7;
y_step      =   15;
#
max_iter    =  200;
#
y0 = top_edge;
{
  x0 = left_edge;
  {
    x = y = i = 0;
    the_char = ' ';
    {
      x_x = x * x / 200;
      y_y = y * y / 200;
      (x_x + y_y > 800 ) and {
        the_char = i > 9 ? '@' : i;
        i = max_iter;
      };
      y = x * y / 100 + y0;
      x = x_x - y_y + x0;
      i = i + 1;
    } while (i < max_iter) ;
    put(the_char);
    x0 = x0 + x_step;
  } while (x0 < right_edge) ;
  print '';
  y0 = y0 - y_step;
} while y0 > bottom_edge ;