#!/usr/bin/env perl

# strelnokoff.pl - Cat's Eye Technologies' Strelnokoff Interpreter
# v1.0-2024.0119 Chris Pressey, Cat's Eye Technologies

# Copyright (c) 2001-2024 Chris Pressey, Cat's Eye Technologies
# This file is distributed under a 2-clause BSD license.
# For more information, see the following file in the LICENSES directory:
# SPDX-License-Identifier: LicenseRef-BSD-2-Clause-X-Strelnokoff

# USAGE: [perl] strelnokoff[.pl] program.skf

### BEGIN strelnokoff.pl ###

### SCANNER ###

$program = '';
$token = '';
sub scan
{
  if ($program =~ /^\s+/)
  {
    $program = $';
    goto &scan;
  }
  if ($program =~ /^REM.*?\n/)
  {
    $program = $';
    goto &scan;
  }
  if ($program =~ /^(\d+)/)
  {
    $token = $1;
    $program = $';
  }
  elsif ($program =~ /^([A-Za-z_][A-Za-z0-9_]*)/)
  {
    $token = $1;
    $program = $';
  }
  elsif ($program =~ /^(\'.\')/)
  {
    $token = $1;
    $program = $';
  }
  elsif ($program =~ /^(.)/)
  {
    $token = $1;
    $program = $';
  }
  else
  {
    # end of program
    $token = '';
    $program = '';
  }
  # print "Scanned: $token\n";
}

sub expect
{
  my $expected = shift;
  if ($token eq $expected)
  {
    scan();
  } else
  {
    error("Expected '$expected' not '$token'");
  }
}

sub error
{
  my $msg = shift;
  print STDERR "*** ERROR: strelnokoff: $msg\n";
}

### SYMBOL TABLE ###

%sym = ();

### PARSER ###

# Strelnokoff = {Assignment}.
# Assignment  = Variable [Index] "=" Expression0.
# Expression0 = Expression1 {"=" Expression1 | ">" Expression1}.
# Expression1 = Expression2 {"+" Expression2 | "-" Expression2}.
# Expression2 = Primitive   {"*" Primitive   | "/" Primitive}.
# Primitive   = ["PRINT" | "INPUT"] ["CHAR"] Variable [Index]
#             | IntegerLiteral | CharLiteral
#             | "(" Expression0 ")".
# Index       = "[" Expression0 {"," Expression0} "]".

# Program      ::= {Assignment}.
sub program
{
  my @p = ();
  while($token ne '')
  {
    my $x = assignment();
    push @p, $x;
    # print join(', ', @$x);
  }
  # print "end program on $token\n";
  return \@p;
}

# Assignment   ::= Variable [Index] "=" Expression0.

sub assignment
{
  my $varname = $token;
  scan();
  if ($token eq '[')
  {
    varindex();
  }
  expect('=');
  return [':=', $varname, expression0()];
  # print "$varname = $sym{$varname}\n";
}

# Expression0 = Expression1 {"=" Expression1 | ">" Expression1}.

sub expression0
{
  my $q = expression1();
  while($token eq "=" or $token eq ">")
  {
    my $t = $token;
    scan();
    my $r = expression1();
    my $b = $q;
    if ($t eq '=') { $q = ['=', $q, $r]; }
    if ($t eq '>') { $q = ['>', $q, $r]; }
    # print "compare: $b $t $r -> $q\n";
  }
  return $q;
}

# Expression1 = Expression2 {"+" Expression2 | "-" Expression2}.

sub expression1
{
  my $q = expression2();
  while($token eq "+" or $token eq "-")
  {
    my $t = $token;
    scan();
    my $r = expression2();
    if ($t eq '+') { $q = ['+', $q, $r]; }
    if ($t eq '-') { $q = ['-', $q, $r]; }
  }
  return $q;
}

# Expression2 = Primitive   {"*" Primitive   | "/" Primitive}.

sub expression2
{
  my $q = primitive();
  while($token eq "*" or $token eq "/")
  {
    my $t = $token;
    scan();
    my $r = primitive();
    if ($t eq '*') { $q = ['*', $q, $r]; }
    if ($t eq '/') { $q = ['/', $q, $r]; }
  }
  return $q;
}

# Primitive   = ["PRINT" | "INPUT"] ["CHAR"] Variable [Index]
#             | IntegerLiteral | CharLiteral
#             | "(" Expression0 ")".

sub primitive
{
  my $mode = 0; # listen up, kids: this is called *context* :-)
  if ($token eq 'PRINT')
  {
    $mode = 1;
    scan();
  }
  elsif ($token eq 'INPUT')
  {
    $mode = 2;
    scan();
  }
  if ($token eq 'CHAR')
  {
    $mode = 3 if $mode == 1;
    $mode = 4 if $mode == 2;
    scan();
  }
  if ($token =~ /^(\d+)$/)
  {
    my $q = 0+$1;
    scan();
    return ['print', 'int',  $q] if $mode == 1;
    return ['print', 'char', $q] if $mode == 3;
    return $q;
  }
  elsif ($token =~ /^\'(.)\'$/)
  {
    my $q = ord($1);
    scan();
    return ['print', 'int',  $q] if $mode == 1;
    return ['print', 'char', $q] if $mode == 3;
    return $q;
  }
  elsif ($token eq '(')
  {
    scan();
    my $q = expression0();
    expect(')');
    return ['print', 'int',  $q] if $mode == 1;
    return ['print', 'char', $q] if $mode == 3;
    return $q;
  }
  else
  {
    $sym{$token} = 0 if not exists $sym{$token};
    $q = [':', $token, 0];
    scan();
    if($token eq '[')
    {
      varindex();
    }
    return ['print', 'int',  $q] if $mode == 1;
    return ['print', 'char', $q] if $mode == 3;
    return $q;
  }
}

# Index       = "[" Expression0 {"," Expression0} "]".
sub varindex
{
  error("arrays not implemented");
  expect('[');
  my $q = expression0();
  while($token eq ',')
  {
    scan();
    $q .= expression0();
  }
  expect(']');
  return $q;
}

### EVALUATOR ###

sub dumpic
{
  my $x = shift;
  if(ref($x) eq 'ARRAY')
  {
    my $c = $x->[0];
    my $q = $x->[1] || 0;
    my $r = $x->[2] || 0;
    print "[$c ";
    dumpic($q);
    print " ";
    dumpic($r);
    print "] ";
  } else
  {
    print $x;
  }
}

sub evaluate
{
  my $x = shift;
  if(ref($x) eq 'ARRAY')
  {
    my $c = $x->[0];
    # print "--> command: $c\n"; # <STDIN>;
    my $q = $x->[1] || 0;
    my $r = $x->[2] || 0;
    if    ($c eq '+') { $q = evaluate($q) + evaluate($r) }
    elsif ($c eq '-') { $q = evaluate($q) - evaluate($r) }
    elsif ($c eq '*')
    {
      # multiplication is interesting in strelnokoff
      # because it is short circuiting :-)
      $q = evaluate($q);
      if ($q != 0)
      {
        $q *= evaluate($r);
      }
    }
    elsif ($c eq '/')
    {
      # division is also interesting
      # because division by 0 yields 0
      $q = evaluate($q);
      $r = evaluate($r);
      if ($r != 0)
      {
        $q = int($q / $r);
      } else
      {
        $q = 0;
      }
    }
    elsif ($c eq '=')
    {
      if(evaluate($q) == evaluate($r))
      {
        $q = 1;
      } else
      {
        $q = 0;
      }
    }
    elsif ($c eq '>')
    {
      if(evaluate($q) > evaluate($r))
      {
        $q = 1;
      } else
      {
        $q = 0;
      }
    }
    elsif ($c eq 'print')
    {
      $r = evaluate($r);
      if ($q eq 'char') { print chr($r); } else { print $r; }
      $q = $r;
    }
    elsif ($c eq ':=')
    {
      $sym{$q} = evaluate($r);
      $q = $sym{$q};
    }
    elsif ($c eq ':')
    {
      $q = $sym{$q};
    }
    else
    {
      error("unknown runtime command $c");
    }
    return $q;
  } else
  {
    return $x;
  }
}

### MAIN ###

$| = 1;
open FILE, "<$ARGV[0]";
$program = join('', <FILE>);
close FILE;
scan();
$assignments = program();
$done = 0;
while (not $done)
{
  my $no = int(rand(1) * ($#{$assignments}+1));
  my $assignment = $assignments->[$no];
  # print "Assignment # $no\n";
  # dumpic($assignment); <STDIN>;
  evaluate($assignment);
}

### END of strelnokoff.pl ###