#!/usr/local/bin/perl -w

# Copyright 1999-2005, Paul Johnson (pjcj@cpan.org)

# This software is free.  It is licensed under the same terms as Perl itself.

# The latest version of this software should be available from my homepage:
# http://www.pjcj.net

# Version 1.1502 - 20th December 2005

use strict;

require 5.005;

use diagnostics;

use Data::Dumper;
use Getopt::Long;

use FindBin;
use lib $FindBin::Bin;

use Parse::RecDescent;

use Gedcom 1.1502;
use Gedcom::LifeLines 1.1502;

use vars qw( $VERSION $Prefix $Suffix );
$VERSION = "1.1502";

sub _indent
{
  join "", map { ref $_ ? _indent(@$_) : $_ } @_
}

sub indent
{
# print STDERR "indenting @_\n";
  my $i = _indent(@_);
  $i =~ s/^/  /gm;
  $i
}

my %Opts;
GetOptions(\%Opts, "quiet!") or die "bad options";

sub msg
{
  return if $Opts{quiet};
  printf STDERR "%4d,%3d: ", shift, shift;
  print  STDERR @_, "\n";
  return
}

# TODO - use correct perl
$Prefix = <<'EOH';
#!/usr/local/bin/perl -w

# This program was generated by lines2perl, which is part of Gedcom.pm.
# Gedcom.pm is Copyright 1999-2005, Paul Johnson (pjcj@cpan.org)
# Version 1.1502 - 20th December 2005

# Gedcom.pm is free.  It is licensed under the same terms as Perl itself.

# The latest version of Gedcom.pm should be available from my homepage:
# http://www.pjcj.net

use strict;

require 5.005;

use diagnostics;
use integer;

use Getopt::Long;

use Gedcom::LifeLines 1.1502;

my $Ged;                                                         # Gedcom object
my %Opts;                                                              # options
my $_Traverse_sub;                                     # subroutine for traverse

sub out  { print  STDERR @_ unless $Opts{quiet} }
sub outf { printf STDERR @_ unless $Opts{quiet} }

sub initialise ()
{
  die "usage: $0 -gedcom_file file.ged\n"
    unless GetOptions(\%Opts,
                      "gedcom_file=s",
                      "quiet!",
                      "validate!",
                     ) and defined $Opts{gedcom_file};
  local $SIG{__WARN__} = sub { out "\n@_" };
  out "reading...";
  $Ged = Gedcom->new
  (
    gedcom_file  => $Opts{gedcom_file},
    callback     => sub { out "." }
  );
  if ($Opts{validate})
  {
    out "\nvalidating...";
    my %x;
    my $vcb = sub
    {
     my ($r) = @_;
     my $t = $r->{xref};
     out "." if $t && !$x{$t}++;
    };
    $Ged->validate($vcb);
  }
  out "\n";
  set_ged($Ged);
}

$SIG{__WARN__} = sub
{
  out $_[0] unless $_[0] =~ /^Use of uninitialized value/
};

EOH

$Suffix = <<'EOS';

initialise();
main();
flush();
0
EOS

my $Grammar = <<'EOG';

{ my (%Globals, %Locals, %Params); }

program              : declaration(s) /$/s
                       { print $::Prefix, join("", @{$item[1]}), $::Suffix }
                     | <error: column $thiscolumn: bad program>

declaration          : //
                       { ::msg($thisline, $thiscolumn, "parsing declaration") }
                     | comment
                     | procedure_definition
                     | global_statement
                       { "$item[1];\n" }
                     | list_statement
                       { "$item[1];\n" }
                     | table_statement
                       { "$item[1];\n" }
                     | indiset_statement
                       { "$item[1];\n" }
                     | include_statement
                       { "$item[1];\n" }
                     | <error: column $thiscolumn: bad declaration>

statement            : "}" <commit> <reject>
                     | //
                       { ::msg($thisline, $thiscolumn, "parsing statement") }
                     | comment
                     | constant
                       { "display $item[1];\n" }
                     | call_statement
                       { "display $item[1];\n" }
                     | builtin_function
                       { "display $item[1];\n" }
                     | emulated_function
                       { "display $item[1];\n" }
                     | builtin_procedure
                       { "$item[1];\n" }
                     | global_statement
                       { "$item[1];\n" }
                     | list_statement
                       { "$item[1];\n" }
                     | table_statement
                       { "$item[1];\n" }
                     | indiset_statement
                       { "$item[1];\n" }
                     | set_statement
                       { "$item[1];\n" }
                     | getintmsg_statement
                       { "$item[1];\n" }
                     | getstrmsg_statement
                       { "$item[1];\n" }
                     | getindimsg_statement
                       { "$item[1];\n" }
                     | continue_statement
                       { "$item[1];\n" }
                     | break_statement
                       { "$item[1];\n" }
                     | return_statement
                       { "$item[1];\n" }
                     | include_statement
                       { "$item[1];\n" }
                     | if_statement
                     | while_statement
                     | forlist_statement
                     | spouses_statement
                     | families_statement
                     | forindi_statement
                     | children_statement
                     | forfam_statement
                     | fornodes_statement
                     | traverse_statement
                     | forindiset_statement
                     | non_call_statement
                       { "display $item[1];\n" }
                     | scalar ...!"("
                       { "display $item[1];\n" }
                     | <uncommit> <error: column $thiscolumn: bad statement>

statements           : ..."}"
                       { [] }
                     | statement statements
                       { [$item[1], @{$item[2]}] }

expression           : ")" <commit> <reject>
                     | //
                       { ::msg($thisline, $thiscolumn, "parsing expression") }
                     | constant
                     | call_statement
                     | builtin_function
                     | emulated_function
                     | non_call_statement
                     | "(" ")"
                       { "" }
                     | "(" expression ")"
                       { "($item[2])" }
                     | scalar ...!"("
                       { $item[1] }
                     | <uncommit> <error: column $thiscolumn: bad expression>

procedure_definition : ("proc" | "func") name "(" scalars(?) ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         my $args = @{$item[4]} ? $item[4][0] =~ tr/$/$/ : 0;
                         my $val =
                           "sub $item[2] (" . '$' x $args  . ")\n" .
                           "{\n" .
                           ($args
                              ? ("  my($item[4][0]) = \@_;\n")
                              : "") .
                           join("", map { qq(  my \$$_;\n) }
                                        sort keys %Locals) .
                           ::indent($item[7]) .
                           ($item[1] eq "proc" ? "  undef\n" : "") .
                           "}\n\n";
                         %Locals = %Params = ();
                         $val
                       }

comment              : /\s*\/\*.*?\*\/\s*/s
                       {
                         my $comment = $item[1];
                         $comment =~ s/\n+$//;
                         $comment =~ s/^/# /gm;
                         $comment . "\n"
                       }

block                : comment(s?) "{" statements "}" comment(s?)
                       {
                         "@{$item[1]}" .
                         "{\n" .
                         ::indent($item[3]) .
                         "}\n@{$item[5]}"
                       }

condition_and_block  : "(" scalar_assignment(?) expression ")" block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "(@{$item[2]}$item[3])\n$item[5]"
                       }

if_statement         : "if" condition_and_block
                       elsif_statement(s?)
                       else_statement(?)
                       {
                         # warn "item is ", ::Dumper \@item;
                         # local $"; # this line breaks the parser...
                         "if $item[2]" . join "", @{$item[3]}, @{$item[4]}
                       }

elsif_statement      : "elsif" condition_and_block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "elsif $item[2]"
                       }

else_statement       : "else" block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "else\n$item[2]"
                       }

while_statement      : "while" condition_and_block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "LOOP: while $item[2]"
                       }

forlist_statement    : "forlist" "(" name "," scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[7] = 0;\n" .
                         "LOOP: for $item[5] (\@\$$item[3])\n" .
                         "{\n" .
                         "  $item[7]++;\n" .
                         ::indent($item[10]) .
                         "}\n"
                       }

spouses_statement    : "spouses" "(" expression ","
                         scalar "," scalar "," scalar ")" "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[9] = 0;\n" .
                         "LOOP: for $item[7] ($item[3]" . "->fams)\n" .
                         "{\n" .
                         "  for $item[5] ($item[7]" . "->parents)\n" .
                         "  {\n" .
                         "    next if $item[5]" . "->xref eq " .
                                     "$item[3]" . "->xref;\n" .
                         "    $item[9]++;\n" .
                         ::indent(::indent($item[12])) .
                         "  }\n" .
                         "}\n"
                       }

families_statement   : "families"
                       "(" expression "," scalar "," scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[9] = 0;\n" .
                         "LOOP: for $item[5] ($item[3]" . "->fams)\n" .
                         "{\n" .
                         "  for $item[7] ($item[5]" . "->parents || undef)\n" .
                         "  {\n" .
                         "    next if $item[7] && $item[7]" . "->xref eq " .
                                                 "$item[3]" . "->xref;\n" .
                         "    $item[9]++;\n" .
                         ::indent(::indent($item[12])) .
                         "  }\n" .
                         "}\n"
                       }

forindi_statement    : "forindi" "(" scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[5] = 0;\n" .
                         "LOOP: for $item[3] (\$Ged" . "->individuals)\n" .
                         "{\n" .
                         "  $item[5]++;\n" .
                         ::indent($item[8]) .
                         "}\n"
                       }

children_statement   : "children" "(" expression "," scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[7] = 0;\n" .
                         "LOOP: for $item[5] ( " .
                           "do { my \$e = $item[3]; \$e ? \$e->children : ()} )\n" .
                         "{\n" .
                         "  $item[7]++;\n" .
                         ::indent(::indent($item[10])) .
                         "}\n"
                       }

forfam_statement     : "forfam" "(" scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[5] = 0;\n" .
                         "LOOP: for $item[3] (\$Ged" . "->families)\n" .
                         "{\n" .
                         "  $item[5]++;\n" .
                         ::indent($item[8]) .
                         "}\n"
                       }

fornodes_statement   : "fornodes" "(" expression "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "LOOP: for $item[5] (\@{$item[3]" . "->_items})\n" .
                         "{\n" .
                         ::indent($item[8]) .
                         "}\n"
                       }

traverse_statement   : "traverse" "(" expression "," scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "\$_Traverse_sub = sub\n" .
                         "{\n" .
                         "  my (\$_traverse_sub_node, " .
                               "\$_traverse_sub_level) = \@_;\n" .
                         "  $item[5] = \$_traverse_sub_node;\n" .
                         "  $item[7] = \$_traverse_sub_level;\n" .
                         ::indent($item[10]) .
                         "  LOOP: for my \$_traverse_sub_item " .
                               "(\@{\$_traverse_sub_node" . "->_items})\n" .
                         "  {\n" .
                         "    \$_Traverse_sub->(\$_traverse_sub_item, " .
                               "\$_traverse_sub_level + 1)\n" .
                         "  }\n" .
                         "};\n" .
                         "\$_Traverse_sub->($item[3], 0);\n"
                       }

forindiset_statement : "forindiset"
                       "(" scalar "," scalar "," scalar "," scalar ")"
                         "{" statements "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[9] = 0;\n" .
                         "LOOP: for (\@{" . "$item[3]})\n" .
                         "{\n" .
                         "  ($item[5], $item[7]) = \@\$_;\n" .
                         "  $item[9]++;\n" .
                         ::indent($item[12]) .
                         "}\n"
                       }

scalar_assignment    : scalar ","
                       { "$item[1] = " }

include_statement    : "include" "(" expression ")"
                       { "do $item[3]" }

global_statement     : "global" "(" name ")"
                       { $Globals{$item[3]}++; qq(my \$$item[3]) }

set_statement        : "set" "(" scalar "," expression ")"
                       { "$item[3] = $item[5]" }

getintmsg_statement  : "getintmsg" "(" scalar "," expression ")"
                       {
                         ::msg($prevline, $prevcolumn,
                               qq(warning: $item[1] needs to be replaced));
                         "$item[3] = $item[5]"
                        }

getstrmsg_statement  : "getstrmsg" "(" scalar "," expression ")"
                       {
                         ::msg($prevline, $prevcolumn,
                               qq(warning: $item[1] needs to be replaced));
                         "$item[3] = $item[5]"
                        }

getindimsg_statement  : "getindimsg" "(" scalar "," expression ")"
                       {
                         ::msg($prevline, $prevcolumn,
                               qq(warning: $item[1] needs to be replaced));
                         "$item[3] = $item[5]"
                        }

continue_statement   : "continue" "(" ")"
                       { "next LOOP" }

break_statement      : "break" "(" ")"
                       { "last LOOP" }

return_statement     : "return" expression(?)
                       { "return" . (@{$item[2]} ? " @{$item[2]}" : "") }

list_statement       : "list" "(" name ")"
                       {
                         my $s = $item[3];
                         $Locals{$s}++
                           unless exists $Globals{$s} || exists $Params{$s};
                         "\$$s = []"
                       }

table_statement      : "table" "(" name ")"
                       {
                         my $s = $item[3];
                         $Locals{$s}++
                           unless exists $Globals{$s} || exists $Params{$s};
                         "\$$s = {}"
                       }

indiset_statement    : "indiset" "(" name ")"
                       {
                         my $s = $item[3];
                         $Locals{$s}++
                           unless exists $Globals{$s} || exists $Params{$s};
                         "\$$s = []"
                       }

name                 : /(?!\d)\w+/

scalar               : name
                       {
                         my $s = $item[1];
                         $Locals{$s}++
                           unless exists $Globals{$s} || exists $Params{$s};
                         "\$$s"
                       }

scalars              : name ("," name)(s?)
                       {
                         $Params{$_}++ for ($item[1], @{$item[2]});
                         '$' . join ', $', $item[1], @{$item[2]}
                       }

#scalars              : scalar ("," scalar)(s?)
#                       {
#                         # $Params{$_}++ for ($item[1], @{$item[2]);
#                         join ', ', $item[1], @{$item[2]}
#                       }

expressions          : expression ("," expression)(s?)
                       { [$item[1], @{$item[2]}] }

expressions2         : expression ("," expression)(s)
                       { [$item[1], @{$item[2]}] }

_call_statement      : name "(" expressions(?) ")" ...!"{"
                       {
                        "&$item[1](" . join(", ", map {@$_} @{$item[3]}) . ")"
                       }

non_call_statement   : _call_statement
                       {
                         ::msg($prevline, $prevcolumn,
                               qq(warning: $item[1] called without "call"));
                         $item[1]
                       }

call_statement       : "call" _call_statement

builtin_function     : add_function
                     | sub_function
                     | mul_function
                     | div_function
                     | mod_function
                     | exp_function
                     | neg_function
                     | and_function
                     | or_function
                     | not_function
                     | eq_function
                     | eqstr_function
                     | ne_function
                     | nestr_function
                     | lt_function
                     | le_function
                     | gt_function
                     | ge_function
                     | empty_function
                     | length_function
                     | dequeue_function
                     | pop_function
                     | getel_function
                     | lookup_function

builtin_procedure    : incr_procedure
                     | decr_procedure
                     | enqueue_procedure
                     | requeue_procedure
                     | push_procedure
                     | setel_procedure
                     | insert_procedure

add_function         : "add" "(" expressions2 ")"
                       { "(" . join(" + ", @{$item[3]}) . ")" }

sub_function         : "sub" "(" expression "," expression ")"
                       { "($item[3] - $item[5])" }

mul_function         : "mul" "(" expressions2 ")"
                       { "(" . join(" * ", @{$item[3]}) . ")" }

div_function         : "div" "(" expression "," expression ")"
                       { "($item[3] / $item[5])" }

mod_function         : "mod" "(" expression "," expression ")"
                       { "($item[3] % $item[5])" }

exp_function         : "exp" "(" expression "," expression ")"
                       { "($item[3] ** $item[5])" }

neg_function         : "neg" "(" expression ")"
                       { "(- $item[3])" }

and_function         : "and" "(" expressions2 ")"
                       { "(" . join(" && ", @{$item[3]}) . ")" }

or_function          : "or" "(" expressions2 ")"
                       { "(" . join(" || ", @{$item[3]}) . ")" }

not_function         : "not" "(" expression ")"
                       { "(! $item[3])" }

eq_function          : "eq" "(" expression "," expression ")"
                       { "($item[3] == $item[5])" }

ne_function          : "ne" "(" expression "," expression ")"
                       { "($item[3] != $item[5])" }

eqstr_function          : "eqstr" "(" expression "," expression ")"
                       { "($item[3] eq $item[5])" }

nestr_function          : "nestr" "(" expression "," expression ")"
                       { "($item[3] ne $item[5])" }

lt_function          : "lt" "(" expression "," expression ")"
                       { "($item[3] < $item[5])" }

le_function          : "le" "(" expression "," expression ")"
                       { "($item[3] <= $item[5])" }

gt_function          : "gt" "(" expression "," expression ")"
                       { "($item[3] > $item[5])" }

ge_function          : "ge" "(" expression "," expression ")"
                       { "($item[3] >= $item[5])" }

empty_function       : "empty" "(" name ")"
                       { "(\@\$$item[3] ? 0 : 1)" }

length_function       : "length" "(" name ")"
                       { "(scalar \@\$$item[3])" }

dequeue_function     : "dequeue" "(" name ")"
                       { "(shift \@\$$item[3])" }

pop_function         : "pop" "(" name ")"
                       { "(pop \@\$$item[3])" }

getel_function       : "getel" "(" name "," expression ")"
                       { "\$$item[3]" . "->[$item[5] - 1]" }

lookup_function      : "lookup" "(" name "," expression ")"
                       { "\$$item[3]" . "->{$item[5]}" }

emulated_function    : emulated_name "(" expressions(?) ")"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "&$item[1](" . join(", ", map {@$_} @{$item[3]}) . ")"
                       }

incr_procedure       : "incr" "(" scalar ")"
                       { "$item[3]++" }

decr_procedure       : "decr" "(" scalar ")"
                       { "$item[3]--" }

enqueue_procedure    : "enqueue" "(" name "," expression ")"
                       { "push \@\$$item[3], $item[5]" }

requeue_procedure    : "requeue" "(" name "," expression ")"
                       { "unshift \@\$$item[3], $item[5]" }

push_procedure       : "push" "(" name "," expression ")"
                       { "push \@\$$item[3], $item[5]" }

setel_procedure      : "setel" "(" name "," expression "," expression ")"
                       { "\$$item[3]" . "->[$item[5] - 1] = $item[7]" }

insert_procedure     : "insert" "(" name "," expression "," expression ")"
                       { "\$$item[3]" . "->{$item[5]} = $item[7]" }

constant             : /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
                     | /".*?(?<!\\)"/
                     | /'.*?(?<!\\)'/

EOG

my @keywords =
(
  @Gedcom::LifeLines::EXPORT,
  qw
  (
    proc
    func
    if
    elsif
    else
    while
    forlist
    spouses
    families
    forindi
    children
    forfam
    fornodes
    traverse
    include
    global
    set
    getintmsg
    getstrmsg
    getindimsg
    continue
    break
    return
    list
    table
    call
    add
    sub
    mul
    div
    mod
    exp
    neg
    and
    or
    not
    eq
    ne
    lt
    le
    gt
    ge
    empty
    length
    dequeue
    pop
    getel
    lookup
    incr
    decr
    enqueue
    requeue
    push
    setel
    insert
  )
);
my $x = "emulated_name : /\\b(" . join("|", @Gedcom::LifeLines::EXPORT) .
                         ")\\b/\n" .
#                        '{ $item[1] }' . "\n" .
#       "keyword       : /\\b(" . join("|", @keywords) . ")\\b/\n" .
        "";
#       "name          : ...!keyword /(?!\\d)\\w+/\n" .
#       "name          : /(?!\\d)\\w+/\n" .
#       "scalar        : name\n" .
#                        '{ "\$$item[1]" }';

# $::RD_TRACE = 1;
$::RD_HINT  = 1;

my $parse = Parse::RecDescent->new($Grammar . $x);

undef $/;

my $input = <>;

# print STDERR "input is $input";

$parse->program($input) or die "invalid input";

print <<EOO

__END__

Original LifeLines program follows:

$input
EOO