#!/usr/bin/perl

# alpaca.pl v0.93 Chris Pressey
# http://catseye.webhop.net/projects/alpaca/
# Copyright (c)1999-2005 Cat's Eye Technologies.  All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 
#   Redistributions of source code must retain the above copyright
#   notice, this list of conditions and the following disclaimer.
# 
#   Redistributions in binary form must reproduce the above copyright
#   notice, this list of conditions and the following disclaimer in
#   the documentation and/or other materials provided with the
#   distribution.
# 
#   Neither the name of Cat's Eye Technologies nor the names of its
#   contributors may be used to endorse or promote products derived
#   from this software without specific prior written permission. 
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
# OF THE POSSIBILITY OF SUCH DAMAGE. 

# Usage: [perl] alpaca[.pl] alpaca-file [program-file]

# If alpaca-file is a badly formed ALPACA file, nothing is
# guaranteed - there is very little error checking.

# If alpaca-file is not specified, it is read from standard
# input.

# If program-file is not specified, the results of the
# compilation are routed to the standard output.

use strict vars, refs, subs;

### GLOBALS ###

my %State = ();
my %Class = ();

my %Relation =
(
  'n'     => '$Playfield->[$x][$y-1]',
  's'     => '$Playfield->[$x][$y+1]',
  'e'     => '$Playfield->[$x+1][$y]',
  'w'     => '$Playfield->[$x-1][$y]',
  'ne'    => '$Playfield->[$x+1][$y-1]',
  'nw'    => '$Playfield->[$x-1][$y-1]',
  'se'    => '$Playfield->[$x+1][$y+1]',
  'sw'    => '$Playfield->[$x-1][$y+1]',

  'me'    => '$Playfield->[$x][$y]',

  '^'     => '$Playfield->[$x][$y-1]',
  'v'     => '$Playfield->[$x][$y+1]',
  '>'     => '$Playfield->[$x+1][$y]',
  '<'     => '$Playfield->[$x-1][$y]',
  '^>'    => '$Playfield->[$x+1][$y-1]',
  '^<'    => '$Playfield->[$x-1][$y-1]',
  'v>'    => '$Playfield->[$x+1][$y+1]',
  'v<'    => '$Playfield->[$x-1][$y+1]'
);

my $Program = '';
my $Token = '';
my $TokenType = '';
my $Emission = '';

my $Class = '';

my $line = '';
my $emit_comments = 0;

### UTILITY SUBROUTINES ###

sub gtok()
{
  $Program =~ s/^\s+//o;
  while ($Program =~ /^\/\*(.*?)\*\/(\s*)/o)
  {
    $Program = $';
  }
  if ($Program =~ /^\'(.*?)\'/o or $Program =~ /^\"(.*?)\"/o)
  {
    $Token = $1;
    $Program = $';
    $TokenType = 'text';
  }
  elsif ($Program =~ /^(\d+)/o)
  {
    $Token = $1;
    $Program = $';
    $TokenType = 'integer';
  }
  elsif ($Program =~ /^([A-Z_a-z]\w+)/o)
  {
    $Token = $1;
    $Program = $';
    $TokenType = 'bareword';
  }
  elsif ($Program =~ /^([\.\;\,\(\)])/o)
  {
    $Token = $1;
    $Program = $';
    $TokenType = 'symbol';
  }
  elsif ($Program =~ /^([v\^\>\<]+)/o)
  {
    $Token = $1;
    $Program = $';
    $TokenType = 'arrow';
  }
  else
  {
    $Token = '';
    $TokenType = 'eof';
  }
}

sub emit_comment($)
{
  my $comment = shift;
  if ($emit_comments) {
    $Emission .= "\n# " . $comment . ": ($Token, $TokenType)\n";
  }
}

### RECURSIVE DESCENT PARSER ###

sub BoolPrimitive()
{
  emit_comment("BoolPrimitive");
  if ($TokenType eq 'bareword')
  {
    if ($Token eq 'true')
    {
      $Emission .= "true()";      gtok();  return 1;
    }
    elsif ($Token eq 'false')
    {
      $Emission .= "false()";     gtok();  return 1;
    }
    elsif ($Token eq 'guess')
    {
      $Emission .= "guess()";     gtok();  return 1;
    }
  }
  return 0;
}

sub AdjacencyFunc()
{
  emit_comment("AdjacencyFunc");
  if ($TokenType eq 'integer')
  {
    my $n = 0 + $Token;
    gtok();
    if ($Token eq 'is')
    {
      $Emission .= "(adjacent_class(\\\&";
      ClassDesignator();
      $Emission .= "${Class}ClassMember";
    } else
    {
      $Emission .= "(adjacent_state(";
      $Emission .= StateDesignator();
    }
    $Emission .= ") >= $n)";
    return 1;
  }
  return 0;
}

sub StateDesignator() # this function RETURNS text rather than emitting it
{
  emit_comment("StateDesignator");

  my $e = '';
  if ($TokenType eq 'bareword' or $TokenType eq 'arrow')
  {
    if (exists $Relation{$Token})
    {
      $e .= $Relation{$Token};
      gtok();
      return $e;
    }
    else
    {
      $e .= "\'$Token\'";
      gtok();
      return $e;
    }
  }
  return '';
}

sub RelationalFunc()
{
  emit_comment("RelationalFunc");
  if ($TokenType eq 'bareword' or $TokenType eq 'arrow')
  {
    my $e = StateDesignator();

    if ($Token eq 'is')
    {
      ClassDesignator();
      $e = "${Class}ClassMember($e)";
    } else
    {
      $e .= " eq " . StateDesignator();
    }

    $Emission .= $e;
    return 1;
  }
  return 0;
}

sub Expression(); # forward
sub Term()
{
  emit_comment("Term");
  if ($TokenType eq 'integer')
  {
    AdjacencyFunc();
    return 1;
  }
  elsif ($Token eq '(')
  {
    gtok();
    $Emission .= "(";
    Expression();
    $Emission .= ")";
    gtok() if ($Token eq ')');
    return 1;
  }
  elsif ($Token eq 'not')
  {
    gtok();
    $Emission .= "(not ";
    Term();
    $Emission .= ")";
    return 1;
  }
  elsif ($Token eq 'true' or $Token eq 'false' or $Token eq 'guess')
  {
    BoolPrimitive();
    return 1;
  } else
  {
    RelationalFunc();
  }
  return 0;
}

sub Expression()
{
  emit_comment("Expression");
  Term();
  while ($Token eq 'and' or $Token eq 'or' or $Token eq 'xor')
  {
    $Emission .= " $Token ";
    gtok();
    Term();
  }
}

sub Rule()
{
  emit_comment("Rule");
  if ($Token eq 'to')
  {
    gtok();
    $Emission .= "  return ";
    $Emission .= StateDesignator();
    $Emission .= " if (";
    if ($Token eq 'when')
    {
      gtok();
      Expression();
    } else
    {
      $Emission .= '1';
    }
    $Emission .= ");\n";
    return 1;
  }
  return 0;
}

sub Rules()
{
  emit_comment("Rules");
  Rule();
  while ($Token eq ',')
  {
    gtok();
    Rule();
  }
}

sub ClassDesignator()
{
  emit_comment("ClassDesignator");
  if ($Token eq 'is')
  {
    gtok();
    $Class = $Token;
    gtok();
    return 1;
  }
  return 0;
}

sub State()
{
  my @supers = ();

  emit_comment("State");
  if ($Token eq 'state')
  {
    gtok();
    if ($TokenType eq 'bareword')
    {
      my $x = $Token; my $a = ' ';
      gtok();
      $Emission .= "sub ${x}StateRules {\n";
      if ($TokenType eq 'text')
      {
        $a = $Token;
        gtok();
      }
      while ($Token eq 'is')
      {
        ClassDesignator();
        push @{$Class{$Class}}, $x;
        push @supers, $Class;
      }
      if ($Token eq 'to')
      {
        Rules();
      }
      $Emission .= "  return ";
      foreach my $k (@supers)
      {
        $Emission .= "${k}ClassRules() || ";
      }
      $Emission .= "\'${x}\'\n };\n\n";
      $State{$x} = $a;
      return 1;
    }
  }
  return 0;
}

sub Class()
{
  my @supers = ();

  emit_comment("Class");
  if ($Token eq 'class')
  {
    gtok();
    if ($TokenType eq 'bareword')
    {
      my $x = $Token; my $a;
      gtok();
      $Emission .= "sub ${x}ClassRules {\n";
      if ($TokenType eq 'text')
      {
        $a = $Token;
        gtok();
      }
      while ($Token eq 'is')
      {
        ClassDesignator();
        push @supers, $Class;
      }
      if ($Token eq 'to')
      {
        Rules();
      }
      $Emission .= "  return ";
      foreach my $k (@supers)
      {
        $Emission .= "${k}ClassRules() || ";
      }
      $Emission .= "0\n };\n\n";
      $Class{$x} = [];
      return 1;
    }
  }
  return 0;
}

sub Entry()
{
  emit_comment("Entry");
  if ($Token eq 'class')
  {
    Class();
    return 1;
  }
  elsif ($Token eq 'state')
  {
    State();
    return 1;
  }
  else
  {
    die "Expected 'class' or 'state' but found '$Token'";
  }
  return 0;
}

sub Entries()
{
  emit_comment("Entries");
  Entry();
  while ($Token eq ';')
  {
    gtok();
    Entry();
  }
  return 1;
}

sub AlpacaProgram
{
  $Emission .= <<"END_OF_HEADER";
#!/usr/bin/perl
# $ARGV[1] - automatically generated from $ARGV[0] by:
# alpaca.pl v0.93
# http://catseye.webhop.net/projects/alpaca/
######################################################

use Alpaca qw(true false guess
	      adjacent_state adjacent_class
	      load_playfield display_playfield process_playfield);

END_OF_HEADER
  gtok();
  Entries();
  if ($Token eq '.')
  {
    foreach my $k (sort keys %Class)
    {
      $Emission .= "sub ${k}ClassMember {\n  return ";
      foreach my $q (@{$Class{$k}})
      {
        $Emission .= "\$_\[0] eq \'$q\' ||\n         ";
      }
      $Emission .= "0\n};\n\n";
    }

    $Emission .= "\$Appearance = {\n";
    foreach my $k (sort keys %State)
    {
      $Emission .= "  '$k' => '$State{$k}',\n";
    }
    $Emission .= "\n};\n\n";

    $Emission .= "\$InputCodec = {\n";
    foreach my $k (sort keys %State)
    {
      $Emission .= "  '$State{$k}' => '$k',\n";
    }
    $Emission .= "\n};\n\n";

    $Emission .= "\$StateRule = {\n";
    foreach my $k (sort keys %State)
    {
      $Emission .= "  '$k' => \\\&main\:\:${k}StateRules,\n";
    }
    $Emission .= "\n};\n\n";

    $Emission .= <<"END_OF_FOOTER";
load_playfield(\$ARGV[0]);

display_playfield();

while (!\$done)
{
  process_playfield();
  display_playfield();
}

exit(0);

### END ###
END_OF_FOOTER
    return 1;
  }
  return 0;
}

########### MAIN ###########

$Program = '';

if (defined($ARGV[0]))
{
  open FILE, "<$ARGV[0]";
} else {
  open FILE, "-"; # STDIN
}
while (defined($line = <FILE>))
{
  chomp $line;
  $Program .= $line;
}
close FILE;

AlpacaProgram();

if (defined($ARGV[1]))
{
  open FILE, ">$ARGV[1]";
  print FILE $Emission;
  close FILE;
} else
{
  print $Emission;
}

exit(0);