File Coverage

blib/lib/Lingua/Romana/Perligata.pm

Criterion	Covered	Total	%
statement	316	568	55.6
branch	190	434	43.7
condition	85	169	50.3
subroutine	44	69	63.7
pod	1	19	5.2
total	636	1259	50.5

package Lingua::Romana::Perligata;

our $VERSION = '0.604';

use Filter::Util::Call;
use IO::Handle;
use Data::Dumper 'Dumper';
no warnings 'once';

my $offset = 0;
my $translate = 0;
my $debug = 0;

sub import {
    filter_add({});
    $offset = (caller)[2]+1;
    $translate = grep /^converte?$/i, @_[1..$#_];
    $debug = grep /^investiga?$/i, @_[1..$#_];
    $lex = grep /^discribe?$/i, @_[1..$#_];
    1;
}

$translator = q{
BEGIN {
    $SIG{__DIE__} = sub { die Lingua::Romana::Perligata::readversum($_[0]) };
    $SIG{__WARN__} = sub { return if $_[0] =~ /(...) interpreted as function/;
                   warn Lingua::Romana::Perligata::readversum($_[0]) };
}
};

sub unimport { filter_del() }

sub filter {
    my($self) = @_ ;

    my $status = 1;
    $status = filter_read(100_000);
    return $status if $status<0;
    s/\A#!.*\n//;
    s{^ \h* ecce \b .*? (?: ^ \h* ecce \h+ seco \h* $ | \Z )}{}gxmsi;
    $tokens = tokenize($_);

    my @commands;
    push @commands, conn_command($tokens,'END') while @$tokens;
    $_ = join ";\n", map { $_->translate } @commands;

    if ($translate) { print "$_;\n" and exit }
    elsif ($debug && /\S/) {
        print "=" x 72,
              "\nTranslated to:\n\n$_\n",
              "=" x 72;
    }
    $_ = "$translator\n#line $offset\n;$_";
    return $status;
}

#==========TOKENIZER============

sub adversum { " ad versum " . to_rn($_[0]->{line}) . "\n" }
sub readversum { $_[0] =~ m{(.*)at\s+(\S+)\s+line\s+(\d+)(.*)}s or return $_[0];
         return $1 . " ad $2 versum " . to_rn($3) . $4 }

sub make_range {
    my ($unit, $five, $ten) = @_;
    my ($two, $three) = ($unit x 2, $unit x 3);
    return [ "", $unit, $two, $three, $unit.$five, $five,
         $five.$unit, $five.$two, $five.$three, $unit.$ten ];
}

my @order = (
    make_range(qw{         I         V                  X          }),
    make_range(qw{         X         L                  C          }),
    make_range(qw{         C         D                  M          }),
    make_range(qw{         M         I))              ((I))        }),
    make_range(qw{       ((I))       I)))            (((I)))       }),
    make_range(qw{      (((I)))      I))))          ((((I))))      }),
    make_range(qw{     ((((I))))     I)))))        (((((I)))))     }),
    make_range(qw{    (((((I)))))    I))))))      ((((((I))))))    }),
    make_range(qw{   ((((((I))))))   I)))))))    (((((((I)))))))   }),
    make_range(qw{  (((((((I)))))))  I))))))))  ((((((((I))))))))  }),
);

my %val;
foreach my $power (0..$#order) {
    @val{@{$order[$power]}} = map {$_*10**$power} 0..9;
}

my $roman = '(' . join(")(", map {join("|",map { quotemeta } reverse(@$_))} reverse @order) . '|)';

sub from_rn {
    my $val = shift;
    @numerals = $val =~ /(?:$roman)/ix;
    join("",@numerals) eq $val or return $val;
    my $an = 0;
    $an += $val{$_} foreach @numerals;
    return $an;
}

sub __beautify__ {
    my ($text) = @_;
    $text =~ s/\b(\d+)\b/to_rn($1)/ge;
    return $text;
}

sub to_rn {
    return "nullum" if $_[0] == 0;
    @digits = split '', $_[0];
    return $_[0] if grep {/\D/} @digits;
    my $power = 0;
    my $rn = "";
    $rn = $order[$power++][$_||0] . $rn foreach reverse @digits;
    return $rn;
}

sub getline {
    my ($fh) = @_;
    if (wantarray) {
        my @lines = IO::Handle::getlines($fh);
        s/\b($roman)\b/$1 ? from_rn($1) : $1/ge for @lines;
        return @lines;
    }
    else {
        my $line = IO::Handle::getline($fh);
        $line =~ s/\b($roman)\b/$1 ? from_rn($1) : $1/ge;
        return $line;
    }
}

sub multibless(\%$$)
{
    my ($hash,$blesstype,$lextype) = @_;
    foreach my $key (keys %$hash)
    {
        $hash->{$key}{lex} = $lextype;
        bless $hash->{$key}, $blesstype;
    }
}

sub addres(\%$$)
{
    my ($hash,$blesstype,$lextype) = @_;
    my (%acc, %dat);
    foreach my $key (keys %$hash)
    {
        $acc{$key.'mentum'} = { %{$hash->{$key}} };
        $acc{$key.'menta'}  = { %{$hash->{$key}} };
        $dat{$key.'mento'}  = { %{$hash->{$key}} };
        $dat{$key.'mentis'} = { %{$hash->{$key}} };
    }
    multibless %acc, $blesstype, $lextype.'_ACCUSATIVE';
    multibless %dat, $blesstype, $lextype.'_DATIVE';
    %$hash = ( %$hash, %acc, %dat );
}

sub add_genitives(\%$$$)
{
    my ($hash, $blesstype, $from, $to) = @_;
    foreach my $key (keys %$hash)
    {
        my $genkey = $key;
        $genkey =~ s/$from$/$to/ or next;
        $hash->{$genkey} = bless { %{$hash->{$key}},
                       lex => 'GENITIVE' },
                     $blesstype;
    }
}

my %literals =
(
    'novumversum' => { perl => '"\n"'  },
    'semicolon'   => { perl => '";"'   },
    'biguttam'    => { perl => '":"'   },
    'guttam'      => { perl => '"."'   },
    'comma'       => { perl => '","'   },
    'lacunam'     => { perl => '" "'   },
    'stadium'     => { perl => '"\t"'  },
    'parprimum'   => { perl => '$1'    },
    'parsecundum' => { perl => '$2'    },
    'partertium'  => { perl => '$3'    },
    'parquartum'  => { perl => '$4'    },
    'parquintum'  => { perl => '$5'    },
    'parsextum'   => { perl => '$6'    },
    'parseptimum' => { perl => '$7'    },
    'paroctavum'  => { perl => '$8'    },
    'parnonum'    => { perl => '$9'    },
    'pardecimum'  => { perl => '$10'   },
    'nomen'       => { perl => '$<'    },
);

multibless %literals, 'Literal', 'ACCUSATIVE';
add_genitives %literals, 'Literal', 'um'  => 'i';
add_genitives %literals, 'Literal', 'am'  => 'ae';
add_genitives %literals, 'Literal', 'ma'  => 'matis';
add_genitives %literals, 'Literal', 'ula' => 'uli';


my %numerals =
(
    'nullum'    => { perl => '0' },
    'unum'      => { perl => '1' },
    'unam'      => { perl => '1' },
    'duo'       => { perl => '2' },
    'duas'      => { perl => '2' },
    'tres'      => { perl => '3' },
    'quattuor'  => { perl => '4' },
    'quinque'   => { perl => '5' },
    'sex'       => { perl => '6' },
    'septem'    => { perl => '7' },
    'octo'      => { perl => '8' },
    'novem'     => { perl => '9' },
    'decem'     => { perl => '10' },
);

multibless %numerals, 'Literal', 'NUMERAL';


my %ordinals_a =
(
    'nullimum'  => { perl => '0' },
    'primum'    => { perl => '1' },
    'secundum'  => { perl => '2' },
    'tertium'   => { perl => '3' },
    'quartum'   => { perl => '4' },
    'quintum'   => { perl => '5' },
    'sextum'    => { perl => '6' },
    'septimum'  => { perl => '7' },
    'octavum'   => { perl => '8' },
    'nonum'     => { perl => '9' },
    'decimum'   => { perl => '10' },
);

foreach ( map substr($_,0,-2), keys %ordinals_a ) {
    $ordinals_a{"${_}os"} = $ordinals_a{"${_}um"};  # MASC. PLURALS
    $ordinals_a{"${_}am"} = $ordinals_a{"${_}um"};  # FEMININE
    $ordinals_a{"${_}as"} = $ordinals_a{"${_}um"};  # FEM. PLURALS
}

multibless %ordinals_a, 'Ordinal', 'ORDINAL';
add_genitives %ordinals_a, 'Ordinal', 'um' => 'i';
add_genitives %ordinals_a, 'Ordinal', 'am' => 'ae';
# add_genitives %ordinals_a, 'Ordinal', 'os' => 'orum';

my %ordinals_d =
(
    'nullimo'   => { perl => '0' },
    'primo'     => { perl => '1' },
    'secundo'   => { perl => '2' },
    'tertio'    => { perl => '3' },
    'quarto'    => { perl => '4' },
    'quinto'    => { perl => '5' },
    'sexto'     => { perl => '6' },
    'septimo'   => { perl => '7' },
    'octavo'    => { perl => '8' },
    'nono'      => { perl => '9' },
    'decimo'    => { perl => '10' },
);

multibless %ordinals_d, 'Ordinal', 'ORDINAL_DATIVE';

my %special_vars =
(
    'hoc'          => { perl => '$_',    lex => 'ACCUSATIVE' },
    'huius'        => { perl => '$_',    lex => 'GENITIVE'   },
    'huic'         => { perl => '$_',    lex => 'DATIVE'     },
    'haec'         => { perl => '@_',    lex => 'ACCUSATIVE' },
    'horum'        => { perl => '@_',    lex => 'GENITIVE'   },
    'his'          => { perl => '@_',    lex => 'DATIVE'     },
    'ianitorem'    => { perl => '$/',    lex => 'ACCUSATIVE' },
    'ianitoris'    => { perl => '$/',    lex => 'GENITIVE'   },
    'ianitori'     => { perl => '$/',    lex => 'DATIVE'     },
    'programma'    => { perl => '$0',    lex => 'ACCUSATIVE' },
    'programmati'  => { perl => '$0',    lex => 'DATIVE'     },
    'programmatis' => { perl => '$0',    lex => 'GENITIVE'   },
    'parametra'    => { perl => '@ARGV', lex => 'ACCUSATIVE' },
    'parametris'   => { perl => '@ARGV', lex => 'DATIVE'     },
    'parametrorum' => { perl => '@ARGV', lex => 'GENITIVE'   },
);

for my $key ( keys %special_vars )
{
    bless $special_vars{$key}, 'Literal';
}

my %varmods =
(
    'loco'      => bless ({ perl => 'local', lex => 'OWNER_D' },
                  'ScalarMod'),
    'locis'     => bless ({ perl => 'local', lex => 'OWNER_D' },
                  'ArrMod'),
    'meo'       => bless ({ perl => 'my', lex => 'OWNER_D' },
                  'ScalarMod'),
    'meis'      => bless ({ perl => 'my', lex => 'OWNER_D' },
                  'ArrMod'),
    'nostro'    => bless ({ perl => 'our', lex => 'OWNER_D' },
                  'ScalarMod'),
    'nostris'   => bless ({ perl => 'our', lex => 'OWNER_D' },
                  'ArrMod'),
);

my %streams =
(
    'parametro'  => { perl => '*ARGV'  },
    'vestibulo'  => { perl => '*STDIN' },
    'egresso'    => { perl => 'STDOUT' },
    'oraculo'    => { perl => 'STDERR' },
    'nuntio'     => { perl => '*Lingua::Romana::Perligata::DATA' },
);
multibless %streams, 'Literal', 'DATIVE';

my %matchops =
(
    'compara'   => { perl => 'm' },
    'substitue' => { perl => 's' },
    'converte'  => { perl => 'tr' },
);

multibless %matchops, 'MatchOperator', 'SUBNAME';
addres %matchops, 'MatchOperator', 'SUBNAME';

my %ops =
(
    'adde'      => { perl => '+' },
    'deme'      => { perl => '-' },
    'multiplica'    => { perl => '*' },
    'itera'     => { perl => 'x' },
    'divide'    => { perl => '/' },
    'recide'    => { perl => '%' },
    'eleva'     => { perl => '**' },
    'consocia'  => { perl => '&' },
    'interseca' => { perl => '|' },
    'discerne'  => { perl => '^' },
    'depone'    => { perl => '' , prefix => 1 },
);

$ops{$_}{operator} = 1 foreach keys %ops;
multibless %ops, 'Operator', 'SUBNAME_A';
addres %ops, 'Operator', 'SUBNAME_A';

my %lops =
(
    'da'        => { perl => '=', operator => 1 },
);

multibless %lops, 'Operator', 'SUBNAME_AD';
addres %lops, 'Operator', 'SUBNAME_AD';

my %invarops =
(
    'atque'            => { perl => '&&'   },
    'vel'              => { perl => '||'   },
    'praestantiam'     => { perl => '<'    },
    'non praestantiam' => { perl => '>='   },
    'praestantias'     => { perl => 'lt'   },
    'non praestantias' => { perl => 'ge'   },
    'aequalitam'       => { perl => '=='   },
    'non aequalitam'   => { perl => '!='   },
    'aequalitas'       => { perl => 'eq'   },
    'non aequalitas'   => { perl => 'ne'   },
    'comparitiam'      => { perl => '<=>'  },
    'comparitias'      => { perl => 'cmp'  },
    'non comparitiam'  => { perl => '!<=>' },
    'non comparitias'  => { perl => '!cmp' },

    'non'           => { perl => '!', prefix => 1 },
    'nega'          => { perl => '-', prefix => 1 },
);

$invarops{$_}{operator} = 1 foreach keys %invarops;
multibless %invarops, 'Operator', 'SUBNAME_A_ACCUSATIVE';

my %connectives =
(
    'que'           => { perl => 'and' },
    've'            => { perl => 'or' },
);

@{$connectives{$_}}{'operator','raw'} = (1,-$_) foreach keys %connectives;
multibless %connectives, 'Operator', 'CONNECTIVE';

my %funcs_td =
(
    'excerpe'   => { perl => 'substr' },    # SPECIAL: SEE BELOW

    'cumula'    => { perl => 'push'     },
    'capita'    => { perl => 'unshift'  },
    'iunge'     => { perl => 'splice'   },
    'digere'    => { perl => 'sort'     },
    'retexe'    => { perl => 'reverse'  },
    'evolute'   => { perl => 'open'     },
    'lege'      => { perl => 'read'     },
    'scribe'    => { perl => 'print'    },
    'describe'  => { perl => 'printf'   },
    'subscribe' => { perl => 'write'    },
    'conquire'  => { perl => 'seek'     },
    'benedice'  => { perl => 'bless'    },
    'liga'      => { perl => 'tie'      },
    'modera'    => { perl => 'fcntl'    },
    'conflue'   => { perl => 'flock'    },
    'impera'    => { perl => 'ioctl'    },
    'trunca'    => { perl => 'truncate' },
);

multibless %funcs_td, 'Function', 'SUBNAME_AD';
addres %funcs_td, 'Function', 'SUBNAME_AD';

# "bless" HAS A COMMON LATIN CONTRACTION...

$funcs_td{benedictum} = $funcs_td{benedicementum};
$funcs_td{benedicto} = $funcs_td{benedicemento};

# THE FOLLOWING IS LVALUABLE, SO ARG MUST AGREE IN CASE WITH FUNCTION'S CASE...

for (qw( excerpe )) {
    $funcs_td{"${_}mentum"}{lex} = 'SUBNAME_A_ACCUSATIVE';
}


my %funcs_bd =
(
    'vanne'     => { perl => 'grep' },
    'applica'   => { perl => 'map'  },
    'digere'    => { perl => 'sort' },
);

multibless %funcs_bd, 'Function', 'SUBNAME_AB';
addres %funcs_bd, 'Function', 'SUBNAME_AB';

my %funcs_b =
(
        'factorem'  => { perl => 'sub' },
        'factori'   => { perl => 'sub' },
);

multibless %funcs_b, 'Function', 'SUBNAME_B_ACCUSATIVE';
$funcs_b{'factori'}{lex} = 'SUBNAME_B_DATIVE';


my %funcs_t =
(
    'morde'        => { perl => 'chomp'                              },
    'praecide'     => { perl => 'chop'                               },
    'stude'        => { perl => 'study'                              },
    'iani'         => { perl => 'undef'                              },
    'lusta'        => { perl => 'reset'                              },
    'decumula'     => { perl => 'pop'                                },
    'decapita'     => { perl => 'shift'                              },
    'claude'       => { perl => 'close'                              },
    'perlege'      => { perl => 'Lingua::Romana::Perligata::getline' },
    'sublege'      => { perl => 'getc'                               },
    'enunta'       => { perl => 'tell'                               },
    'dele'         => { perl => 'delete'                             },
    'quisque'      => { perl => 'each'                               },
    'adfirma'      => { perl => 'exists'                             },
    'solvere'      => { perl => 'untie'                              },
    'preincresce'  => { perl => '++', prefix => 1, operator => 1     },
    'postincresce' => { perl => '++', prefix => 0, operator => 1     },
    'predecresce'  => { perl => '--', prefix => 1, operator => 1     },
    'postdecresce' => { perl => '--', prefix => 0, operator => 1     },

    'reperi'    => { perl => 'pos' },   # SPECIAL: SEE BELOW
    'nomina'    => { perl => 'keys' },  # SPECIAL: SEE BELOW
);

multibless %funcs_t, 'Function', 'SUBNAME_D';
addres %funcs_t, 'Function', 'SUBNAME_D';


# THE FOLLOWING ARE LVALUABLE, SO ARG MUST AGREE IN CASE WITH FUNCTION'S CASE...

for (qw( reperi nomina )) {
    $funcs_t{"${_}mentum"}{lex} = 'SUBNAME_A_ACCUSATIVE';
}

my %funcs_d =
(
    'admeta'    => { perl => 'Lingua::Romana::Perligata::__lastelem__' },
    'inque'     => { perl => 'Lingua::Romana::Perligata::__enquote__' },
    'conscribe' => { perl => 'Lingua::Romana::Perligata::__enlist__' },
    'come'      => { perl => 'Lingua::Romana::Perligata::__beautify__' },
    'priva'     => { perl => 'abs' },
    'angula'    => { perl => 'atan2' },
    'oppone'    => { perl => 'sin' },
    'accuba'    => { perl => 'cos' },
    'decolla'   => { perl => 'int' },
    'succide'   => { perl => 'log' },
    'fode'      => { perl => 'sqrt' },
    'conice'    => { perl => 'rand' },
    'prosemina' => { perl => 'srand' },
    'inde'      => { perl => 'chr' },
    'senidemi'  => { perl => 'hex' },
    'octoni'    => { perl => 'oct' },
    'numera'    => { perl => 'ord' },
    'deminue'   => { perl => 'lc' },
    'minue'     => { perl => 'lcfirst' },
    'amplifica' => { perl => 'uc' },
    'amplia'    => { perl => 'ucfirst' },
    'excipe'    => { perl => 'quotemeta' },
    'huma'      => { perl => 'crypt' },
    'meta'      => { perl => 'length' },
    'convasa'   => { perl => 'pack' },
    'deconvasa' => { perl => 'unpack' },
    'scinde'    => { perl => 'split' },
    'scruta'    => { perl => 'index' },
    'coniunge'  => { perl => 'join' },
    'confirma'  => { perl => 'defined' },
    'secerna'   => { perl => 'scalar' },
    'argue'     => { perl => 'values' },
    'extremus'  => { perl => 'eof' },
    'deside'    => { perl => 'wantarray' },
    'aestima'   => { perl => 'eval' },
    'exi'       => { perl => 'exit' },
    'redde'     => { perl => 'return' },
    'mori'      => { perl => 'die' },
    'mone'      => { perl => 'warn' },
    'coaxa'     => { perl => 'Carp::croak' },
    'carpe'     => { perl => 'Carp::carp' },
    'memora'    => { perl => 'caller' },
    'agnosce'   => { perl => 'ref' },
    'exhibere'  => { perl => 'tied' },
    'require'   => { perl => 'require' },
    'demigrare' => { perl => 'chdir' },
    'permitte'  => { perl => 'chmod' },
    'vende'     => { perl => 'chown' },
    'inveni'    => { perl => 'glob' },
    'copula'    => { perl => 'link' },
    'decopula'  => { perl => 'unlink' },
    'aedifica'  => { perl => 'mkdir' },
    'renomina'  => { perl => 'rename' },
    'excide'    => { perl => 'rmdir' },
    'exprime'   => { perl => 'stat' },
    'terre'     => { perl => 'alarm' },
    'mitte'     => { perl => 'dump' },
    'commuta'   => { perl => 'exec' },
    'furca'     => { perl => 'fork' },
    'interfice' => { perl => 'kill' },
    'dormi'     => { perl => 'sleep' },
    'obsecra'   => { perl => 'system' },
    'dissimula' => { perl => 'umask' },
    'manta'     => { perl => 'wait' },

    'inscribe'  => { perl => ':' }, # SPECIAL: SEE BELOW
    'arcesse'   => { perl => '${' },    # SPECIAL: SEE BELOW

    'sere'      => { perl => 'Lingua::Romana::Perligata::__encatenate__' },
);

multibless %funcs_d, 'Function', 'SUBNAME_A';
addres %funcs_d, 'Function', 'SUBNAME_A';

# 'inscribe' IS SPECIAL: ONLY IMPERATIVE

delete @funcs_d{grep /^inscribement/, keys %funcs_d};

# 'arcesse' IS SPECIAL: NO IMPERATIVE AND EXTRA (PSEUDO-)RESULTATIVES

delete $funcs_d{'arcesse'};

# SCALAR AS NON-TERMINAL INDEX

$funcs_d{'arcessementi'} = { %{$funcs_d{'arcessementum'}},
                 lex => 'SUBNAME_A_GENITIVE' };

# ARRAY DEREFERENCE

$funcs_d{'arcessementa'}{perl}  = '@{';
$funcs_d{'arcessementis'}{perl} = '@{';
$funcs_d{'arcessementorum'} = { %{$funcs_d{'arcessementa'}},
                lex => 'SUBNAME_A_GENITIVE' };

$funcs_d{'arcessementus'}   = { %{$funcs_d{'arcessementa'}}, perl => '%{' };
$funcs_d{'arcessementibus'} = { %{$funcs_d{'arcessementis'}}, perl => '%{' };
$funcs_d{'arcessementuum'}  = { %{$funcs_d{'arcessementus'}},
                 lex => 'SUBNAME_A_GENITIVE'};


my %funcs_dl =
(
    'adi'        => { perl => 'goto' },
    'confectus'  => { perl => 'continue' },
    'domus'      => { perl => 'package' },
    'legatarius' => { perl => 'use base' },
    'ute'        => { perl => 'use' },
);

multibless %funcs_dl, 'Function_Lit', 'SUBNAME_A';
addres %funcs_dl, 'Function_Lit', 'SUBNAME_A';

my %funcs_dlo =
(
    'ultimus'    => { perl => 'last' },
    'posterus'   => { perl => 'next' },
    'reconnatus' => { perl => 'redo' },
);

multibless %funcs_dlo, 'Function_Lit', 'SUBNAME_OA';
# addres %funcs_dl, 'Function_Lit', 'SUBNAME_OA';

my %misc  =
(
    'fac'         => { lex => 'DO',                perl => 'do' },
    'per'         => { lex => 'FOR',               perl => 'for' },
    'per quisque' => { lex => 'FOR',               perl => 'foreach' },
    'si'          => { lex => 'CONTROL',           perl => 'if' },
    'nisi'        => { lex => 'CONTROL',           perl => 'unless' },
    'donec'       => { lex => 'CONTROL',           perl => 'until' },
    'dum'         => { lex => 'CONTROL',           perl => 'while' },
    'cum'         => { lex => 'WITH',              perl => '' },
    'intra'       => { lex => 'WITHIN',            perl => '::' },
    'apud'        => { lex => 'ARROW',             perl => '->' },
    'tum'         => { lex => 'COMMA',             perl => ',' },
    'in'          => { lex => 'IN',                perl => '' },
    'sic'         => { lex => 'BEGIN',             perl => '{' },
    'cis'         => { lex => 'END',               perl => '}' },
    'princeps'    => { lex => 'NAME', raw=>'main', perl => 'main' },
    'ad'          => { lex => 'ADDRESS',           perl => '\\' },
);

my %tokens =
(
    %literals, %numerals, %special_vars,
    %numerals, %ordinals_a, %ordinals_d,
    %varmods, %matchops, %ops, %lops, %invarops,
    %funcs_td, %funcs_bd, %funcs_b, %funcs_t,
    %funcs_d, %funcs_dl, %funcs_dlo,
    %misc, %streams,
);

# Handle likely captialization variations...
@tokens{map {ucfirst} keys %tokens} = values %tokens;

foreach my $key ( keys %tokens )
{
    $tokens{$key}{raw} = $key
        unless $tokens{$key}{raw};
}

my $distokens = join '|', reverse sort keys %tokens;
my $tokens    = "\\A\\s*($distokens)\\b";
my $tokensque = "\\A\\s*($distokens)que\\b";
my $tokensve  = "\\A\\s*($distokens)ve\\b";

sub token($$$$)
{
    my ($raw, $lex, $perl, $blesstype) = @_;
    return bless { raw => $raw, lex => $lex, perl => $perl }, $blesstype;
}

sub tokdup
{
    my ($archetype) = @_;
    bless { %$archetype }, $archetype->{lex};
}

sub tokenize
{
    my ($text) = @_;
    my @tokens;
    my $bad = "";
    my $lines = $text =~ tr/\n/\n/;

    while (length $text)
    {
        $text =~ s/\A\s+//;
        my $line = $lines - ($text =~ tr/\n/\n/) + $offset;
        if ($text =~ s/\A(adnota.*)//i)
        {
            # ignore comments
        }
        elsif ($text =~ s/\A(nuntius|finis)[ \t]*[.]?[ \t]*\n(.*)//smi)
        {
            # set up DATA stream
            use vars '*DATA';
            local *Lingua::Romana::Perlidata::DATASRC;
            my $pipe = pipe \*Lingua::Romana::Perligata::DATA,
                        \*Lingua::Romana::Perlidata::DATASRC;

            print Lingua::Romana::Perlidata::DATASRC $2;
        }
        elsif ($text =~ s/\Adic(?:emen)?tum(que|ve|)\s+sic\s+\b(.*?)\s+cis\b//si)
        {
            push @tokens, tokdup $connectives{lc $1} if $1;
            push @tokens, token($2,'NAME',"$2",'Name');
        }
        elsif ($text =~ s/\Asic(que|ve|)\s+(.*?)\s+cis\s+dic(?:emen)?tum\b//si)
        {
            push @tokens, tokdup $connectives{lc $1} if $1;
            push @tokens, token($2,'NAME',"$2",'Name');
        }
        elsif ($text =~ s/\A(atque|vel)\b//i)
        {
            push @tokens, tokdup $misc{'tum'};
            push @tokens, tokdup $invarops{lc $1};
        }
        elsif ($text =~ s/\A(($roman)im(?:o|ae)(que|ve|))\b//ix && length $2)
        {
            push @tokens, tokdup $connectives{lc $+} if $+;
            push @tokens, token($1,'ORDINAL_DATIVE',from_rn($2),'ORDINAL_DATIVE');
        }
        elsif ($text =~ s/\A(($roman)im(?:um|os|am|as)(que|ve|))\b//ix && length $2)
        {
            push @tokens, tokdup $connectives{lc $+} if $+;
            push @tokens, token($1,'ORDINAL',from_rn($2),'ORDINAL');
        }
        elsif ($text =~ s/\A(($roman)(que|ve|))\b//ix && length $2)
        {
            push @tokens, tokdup $connectives{lc $+} if $+;
            push @tokens, token($1,'NUMERAL',from_rn($2),'NUMERAL');;
        }
        elsif ($text =~ s/$tokensque//i)
        {
            push @tokens, tokdup $connectives{'que'};
            push @tokens, tokdup $tokens{lc $1};
        }
        elsif ($text =~ s/$tokensve//i)
        {
            push @tokens, tokdup $connectives{'ve'};
            push @tokens, tokdup $tokens{lc $1};
        }
        elsif ($text =~ s/$tokens//i)
        {
            push @tokens, tokdup $tokens{lc $1};
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*?)(um|)ementum)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($5)
            {
                my $token = $4 ? $1.$4 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $4} if $4;
                my $perl = $3 ? "\$$2->" : $2;
                push @tokens, token($1,'SUBNAME_OA_ACCUSATIVE',$perl,'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*?)(um|)ementa)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($5)
            {
                my $token = $4 ? $1.$4 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $4} if $4;
                my $perl = $3 ? "\$$2->" : $2;
                push @tokens, token($1,'SUBNAME_OA_ACCUSATIVE',$perl,'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*?)(um|)emento)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($5)
            {
                my $token = $4 ? $1.$4 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $4} if $4;
                my $perl = $3 ? "\$$2->" : $2;
                push @tokens, token($1,'SUBNAME_OA_DATIVE',$perl,'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*?)(um|)ementis)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($5)
            {
                my $token = $4 ? $1.$4 : $1;
                push @tokens, token($token,'NAME',"$token",'Name');
            }
            else
            {
                $bad .= "'-mentis' illicitum: '$1'"
                      . adversum({line=>$line});
                # One day this may be:
                #
                # push @tokens, tokdup $connectives{lc $4} if $4;
                # my $perl = $3 ? "\$$2->" : $2;
                # push @tokens, token($1,'SUBNAME_OA_DATIVE',$perl,'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)orum)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'GENITIVE',"\@$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)uum)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'GENITIVE',"\%$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)um)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'ACCUSATIVE',"\$$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)a)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'ACCUSATIVE',"\@$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)ibus)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'DATIVE',"\%$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)us)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'Name',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'ACCUSATIVE',"\%$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)o)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'DATIVE',"\$$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)is)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'DATIVE',"\@$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)tori)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'DATIVE',"\\&$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)i)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'GENITIVE',"\$$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)ere)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'INFINITIVE',"$2",'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*?)(um|)e)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($5)
            {
                my $token = $4 ? $1.$4 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $4} if $4;
                my $perl = $3 ? "\$$2->" : $2;
                push @tokens, token($1,'SUBNAME',$perl,'Literal');
            }
        }
        elsif ($text =~ s/\A(([a-z_][0-9a-z_]*)torem)(que|ve|)((?:\s+)sicut)?\b//i)
        {
            if ($4)
            {
                my $token = $3 ? $1.$3 : $1;
                push @tokens, token($token,'NAME',$token,'Name');
            }
            else
            {
                push @tokens, tokdup $connectives{lc $3} if $3;
                push @tokens, token($1,'ACCUSATIVE',"\\&$2",'Literal');
            }
        }
        elsif ($text =~ s/\A([.])//)
        {
            push @tokens, token($1,'PERIOD',";",'Separator');
        }
        elsif ($text =~ s/\A(\S+)(que|ve|)((?:\s+)sicut)?\b//)
        {
            if ($3)
            {
                my $token = $2 ? $1.$2 : $1;
                push @tokens, token($token,'NAME',$token,'Name') if $token;
            }
            else
            {
                push @tokens, tokdup $connectives{lc $2} if $2;
                push @tokens, token($1,'NAME',"$1",'Name') if $1;
            }
        }
        else
        {
            $text =~ s/\A(\S+)// or next;
            my $error = $1;
            $bad .= "Aliquod barbarum inveni: '$error'"
                  . adversum({line=>$line});
        }
        $tokens[-1]->{line} = $line if @tokens;
    }
    if (($lex ||$debug) && @tokens) {
        my $format = "%-20s     %-10s     %-20s\n";
        printf $format, qw(Word Role Meaning);
        printf $format, qw(==== ==== =======);
        foreach ( @tokens ) {
            printf $format, @{$_}{qw(raw lex perl)};
        }
        print "\n", "="x72, "\n\n";
        die "\n" if $lex;
    }

    die $bad if $bad;
    return [@tokens];
}

use Carp;

sub conn_command {
    my ($toks, $eatend, $noeatend) = @_;
    my $command = &command;
    while (@$toks && $toks->[0]{lex} eq 'CONNECTIVE') {
        local $Lingua::Romana::Perligata::connective = shift @$toks;
        $connective->{L} = $command;
        $connective->{R} = &command;
        $command = $connective;
    }
    return $command;
}


sub command {
    my ($toks, $eatend, $noeatend) = @_;
    my @Astack = { data => [], complete => 1 };   #SENTINEL ACCUSATIVE FRAME
    my (@Bstack, @Dstack, @Vstack, $Vdone);
    my $Dindir = 0;
    my @lastsubstantive;
    my $empty = 1;

    my $reduce;
    my $Astack_push = sub {
        if ($Astack[-1]{complete}) {
            $reduce->($_[0]) if @Astack > 1;
            push @Astack, { data => [ $_[0] ] };
        }
        else {
            push @{$Astack[-1]{data}}, $_[0];
        }
        $Astack[-1]{complete} = 1;
    };

    $reduce = sub {
        my ($lookahead) = @_;
        if (! @Vstack) {
            if (@Dstack && ($Dstack[-1]{V}{lex}||"") eq 'OWNER_D') {
                $Vdone = pop @Dstack;
                return 1
            }
            return 0;
        }
        return 0 if $Vstack[-1]{lex} =~ /^SUBNAME_?A?D?$/ && $lookahead->{lex} !~ /PERIOD|DO|END|CONNECTIVE/
                 || ref $Vstack[-1] eq "STATEMENT";
        my $verb = $Vstack[-1];
        my ($needA, $needD) = $verb->{lex} =~ /_(O?A?)([BD])?/;
        $needA ||= $verb->{lex} eq 'SUBNAME' ? "OA" : "";
        $needD ||= "";
        return 0 if $needA && $needA ne "OA"  && (@Astack<=1 || !$Astack[-1]{complete})
             || $needD eq 'D' && !@Dstack
             || $needD eq 'B' && !@Bstack;
        my $dat = $needD eq 'D' ? pop(@Dstack)
                : $needD eq 'B' ? pop(@Bstack)
                : undef;
        my $acc = $needA && @Astack>1 ? pop(@Astack)->{data} : undef;
        my $statement = bless { V=>pop(@Vstack), A=>$acc, D=>$dat }, "STATEMENT";
        if ($verb->{lex} =~ /SUBNAME_.*_ACCUSATIVE/
         || $Dindir && $verb->{lex} =~ /SUBNAME_.*_DATIVE|OWNER_D/ )
        {
            if ($verb->{lex} =~ /SUBNAME_.*_DATIVE|OWNER_D/) {
                $statement->{R} = $Dindir;
                $Dindir = 0;
            }
            $Astack_push->($statement);
            push @lastsubstantive, $Astack[-1]{data};
        }
        elsif ($verb->{lex} =~ /SUBNAME_.*_DATIVE|OWNER_D/ ) {
            push @Dstack, $statement;
            push @lastsubstantive, \@Dstack;
        }
        elsif ($verb->{lex} =~ /SUBNAME_.*_GENITIVE/ ) {
            my $lastsubstantive = pop @lastsubstantive;
            die "Genitivum non junctum: '$ord->{raw}'"
                . adversum($verb)
                unless $lastsubstantive;
            $ord = $lastsubstantive[-1][-1];
            die "Index '$ord->{raw}' ordinalis non est"
                . adversum($ord)
                if $ord->{lex} && $ord->{lex} eq 'NUMERAL';
            push @{$ord->{G}}, $statement;
            push @lastsubstantive, $Astack[-1]{data};
        }
        else { $Vdone = $statement }
        if ($debug) {
            print "reduced: ", Data::Dumper->Dump([$statement]);
        }
        return 1;
    };

    my $tok;
    while ( $tok = $toks->[0] ) {
        if ($debug) {
            print "Next: '$toks->[0]{raw}' ($toks->[0]{lex}):\n";
        }
        if ($tok->{lex} =~ /^(NUMERAL|ORDINAL)$/
         || $Dindir && $tok->{lex} eq 'ORDINAL_DATIVE')
            { shift @$toks;
              if ($1 eq 'NUMERAL' && $toks->[0]{lex} eq 'ORDINAL') {
                $tok->{raw} .= " " . $toks->[0]{raw};
                $tok->{perl} /= $toks->[0]{perl};
                shift @$toks;
              }
              if ($tok->{lex} eq 'ORDINAL_DATIVE') {
                  $tok->{R} = $Dindir;
                  $Dindir = 0;
              }
              $Astack_push->($tok);
              $lastownable = $Astack[-1]{data};
              push @lastsubstantive, $lastownable;
            }
        elsif ($tok->{lex} eq 'ORDINAL_DATIVE')
            { shift @$toks;
              $reduce->($tok);
              push @Dstack, $tok;
              $lastownable = \@Dstack;
              push @lastsubstantive, $lastownable;
            }
        elsif ($tok->{lex} eq 'WITH') {
            push @Astack, { data=>[], complete=>0 };
            shift @$toks;
        }
        elsif ($tok->{lex} =~ /^(?:ACCUSATIVE|NAME)$/
            || $Dindir && $tok->{lex} eq 'DATIVE')
            { if ($tok->{lex} eq 'DATIVE') {
                $tok->{R} = $Dindir;
                $Dindir = 0;
              }
              $Astack_push->($tok);
              shift @$toks;
              $lastownable = $Astack[-1]{data};
              push @lastsubstantive, $lastownable;
            }
        elsif ( $tok->{lex} eq 'ARROW' ) {
              my $owner = $toks->[1];
              my $perl = $owner->{perl} =~ /^\W/
                ? $owner->{perl}
                : "$owner->{raw}::";
              $lastownable->[-1]->{perl}
                    =~ s{^}{$perl->};
              splice @$toks, 0, 2;
            }
        elsif ( $tok->{lex} eq 'WITHIN' ) {
              my $owner = $toks->[1];
              $lastownable->[-1]->{raw}
                    =~ s{^(\W*)}{$1$owner->{raw}::};
              $lastownable->[-1]->{perl}
                    =~ s{^(\W*)}{$1$owner->{raw}::};
              splice @$toks, 0, 2;
            }
        elsif ( $tok->{lex} eq 'GENITIVE' ) {
              $reduce->($tok);
              my $gen = shift @$toks;
              die "Genitivum indominum: '$ord->{raw}'"
                . adversum($gen)
                unless @lastsubstantive;
              $ord = $lastsubstantive[-1][-1];
              die "Index '$ord->{raw}' ordinalis non est"
                . adversum($ord)
                if $ord->{lex} && $ord->{lex} eq 'NUMERAL';
              push @{$ord->{G}}, $gen;
              $lastownable = $ord->{G};
            }
        elsif ( $tok->{lex} eq 'INFINITIVE' )
            { $reduce->($tok); $Vdone = subdefn($toks); last }
        elsif ( $tok->{lex} eq 'CONTROL' )
            { $reduce->($tok); $Vdone = control($toks, \@Bstack); last }
        elsif ( $tok->{lex} eq 'FOR' )
            { $reduce->($tok); $Vdone = for_control($toks, \@Bstack); last }
        elsif ( $tok->{lex} eq 'BEGIN' )
            { push @Bstack, block($toks) }
        elsif ( $tok->{lex} eq 'OWNER_D' )
            { $reduce->($tok); push @Vstack, $tok; shift @$toks; }
        elsif ( $tok->{lex} eq 'COMMA' )
            { $reduce->($tok)
                unless $lastownable && @Astack>1 &&
                       $lastownable == $Astack[-1]{data};
              die "'$tok->{raw}' immaturum est " . adversum($tok)
                unless @Astack>1 && $Astack[-1]{complete};
              $Astack[-1]{complete} = 0;
              shift @$toks;
            }
        elsif ( $tok->{lex} eq 'ADDRESS' )
            { $reduce->($tok);
              $Dindir++;
              shift @$toks;
            }
        elsif ( $tok->{lex} eq 'DATIVE' )
            { $reduce->($tok); push @Dstack, $tok; shift @$toks;
              $lastownable = \@Dstack;
              push @lastsubstantive, $lastownable;
            }
        elsif ( $tok->{lex} =~ /^SUBNAME/ )     # WAS: /SUBNAME_
            { if ($Astack[-1]{complete}) {
                $reduce->($tok)
              }
              elsif ($tok->{perl} !~ /^(and|or|[&|]{2})$/) {
                push @Astack, { data=>[] };
              }
              push @Vstack, $tok; shift @$toks;
              $lastownable = \@Vstack;
            }
        # elsif ( $tok->{lex} =~ /^SUBNAME$/ )
            # { if ($Astack[-1]{complete}) {
                # $reduce->($tok)
              # }
              # elsif ($tok->{perl} !~ /^[&|]{2}$/ {
                # push @Astack, { data=>[] };
              # }
              # push @Vstack, $tok; shift @$toks;
              # $lastownable = \@Vstack;
            # }
        elsif ( $tok->{lex} =~ /PERIOD/ )
            { 1 while $reduce->($tok) && !$Vdone;
              $Vdone = pop(@Astack)->{data}
                if $Lingua::Romana::Perligata::connective
                && !($Vdone || @Astack <= 1);
              shift @$toks;
              last
            }
        elsif ( $tok->{lex} =~ /CONNECTIVE/ )
            { 1 while $reduce->($tok) && !$Vdone;
              $Vdone = pop(@Astack)->{data}
                unless $Vdone || @Astack <= 1;
              last }
        elsif ( $eatend && $tok->{lex} =~ /$eatend/ )
            { 1 while $reduce->($tok);
              $Vdone or $Vdone = @Astack > 1
                        ? pop(@Astack)->{data}
                        : pop @Dstack;
              shift @$toks; last }
        elsif ( $noeatend && $tok->{lex} =~ /$noeatend/ )
            { 1 while $reduce->($tok);
              $Vdone or $Vdone = pop(@Astack)->{data}
                      || pop @Dstack;
              last }
        else {
            die "Non intellexi: '$tok->{raw}'" . adversum($tok);
            }
    }
    continue {
        $empty = 0;
        if ($debug) {
            print "After '$tok->{raw}' ($tok->{lex}):\n";
            print Data::Dumper->Dump([\@Vstack, \@Astack, \@Bstack, \@Dstack, \@lastsubstantive, \$lastownable, \$Vdone], [qw{Vstack Astack Bstack Dstack LastS LastO Vdone}]);
        }
    }
    die "Iussum nefastum: '$Vstack[-1]{raw}'" . adversum($Vstack[-1])
      . ( $Vstack[-1]{lex} !~ /(ACCUSATIVE|DATIVE)$/
        ? "(Vellesne '$Vstack[-1]{raw}mentum' unumve ceteri)\n"
        : "" )
        if $Vdone && @Vstack;
    die "Accusativum non junctum: '"
      . join(" tum ", map {$_->{raw}} @{$Astack[-1]{data}})
      . "'"
      . adversum($Astack[-1]{data}[0])
        if @Astack > 1 && !@Vstack;
    die "Dativum non junctum: '$Dstack[-1]{raw}'" . adversum($Dstack[-1])
        if @Dstack && !@Vstack;
    die "Sententia imperfecta prope '$tok->{raw}'" . adversum($tok)
        unless $Vdone || $empty;
    return $empty           ? $tok
           : ref $Vdone eq 'ARRAY'  ? $Vdone->[0]
           :              $Vdone;
}

sub block
{
    my ($toks) = @_;
    my @self;
    my $next = shift @$toks;
    die "Exspectavi 'sic' sed inveni '$next->{raw}'" . adversum($next)
        unless $next->{lex} eq 'BEGIN';
    while ($toks->[0]{lex} ne 'END') {
        my $command = conn_command($_[0],'PERIOD','END');
        push @self, $command if $command;
    }
    $next = shift @$toks;
    die "Exspectavi 'cis' sed inveni '$next->{raw}'" . adversum($next)
        unless $next->{lex} eq 'END';
    return bless \@self, 'BLOCK';
}

sub subdefn
{
    my ($toks) = @_;
    my $self = shift @$toks;
    $self->{B} = block($toks);
    return $self;
}

sub for_control
{
    my ($toks, $Bstack) = @_;
    my $self = shift @$toks;
    my $var;
    $var = $toks->[0]{lex} eq 'ACCUSATIVE'
            ? shift @$toks
         : $toks->[0]{lex} ne 'IN'
            ? die "Exspectavi accusativum post 'per' sed inveni '$toks->[0]{raw}'" . adversum($toks->[0])
         : tokdup $tokens{'huic'};
    my $in = shift @$toks;
    die "'in' pro 'per' afuit" . adversum($in)
        unless $in->{lex} eq 'IN';
    $self->{D} = $var;
    $self->{C} = conn_command($toks,'DO', 'PERIOD');
    unless (($self->{C}{lex}||$self->{C}{V}{lex}) =~ /DATIVE|OWNER_D/) {
        my ($badraw, $bad) = $self->{C}{lex}
            ? ($self->{C}{raw}, $self->{C})
            : ($self->{C}{V}{raw}, $self->{C}{V});
        die "'$badraw' dativus non est in 'per'" . adversum($bad);
    }
    if ($toks->[0]{lex} =~ /PERIOD|CONNECTIVE/) {
        die "Iussa absentia per '$self->{raw}'" . adversum($self)
            unless @$Bstack;
        $self->{B} = pop @$Bstack;
        shift @$toks unless $toks->[0]{lex} eq 'CONNECTIVE';
    }
    else {
        $self->{B} = block($toks);
    }
    return $self;
}

sub control
{
    my ($toks, $Bstack) = @_;
    my $self = shift @$toks;
    $self->{C} = conn_command($toks,'DO');
    if (($self->{perl}||"") eq 'while' &&
        ($self->{C}{V}{perl}||"") eq 'Lingua::Romana::Perligata::getline') {
        $self->{C}{V}{diamond} = 1;
    }
    if (!@$toks || $toks->[0]{lex} =~ /PERIOD|CONNECTIVE/) {
        die "Iussa absentia per '$self->{raw}'" . adversum($self)
            unless @$Bstack;
        $self->{B} = pop @$Bstack;
        shift @$toks unless $toks->[0]{lex} eq 'CONNECTIVE';
    }
    else {
        $self->{B} = block($toks);
    }
    return $self;
}


sub __enlist__ {
    return ($_[0]..$_[1]);
}

sub __enquote__ {
    return join " ", @_;
}

sub __encatenate__ {
    return join "", @_;
}

sub __lastelem__(\@) {
    return $#{$_[0]};
}

my %lb = ( '@'=>'[', '%'=>'{' );
my %rb = ( '@'=>']', '%'=>'}' );

sub STATEMENT::translate {
    my $verb = $_[0]{V}->translate;
    my $prefix = $_[0]{V}{prefix};
    my $hasblock = $verb =~ m{^(grep|map)$};
    my $noparen = $_[0]{V}{lex} eq 'OWNER_D' && $_[0]{V}{raw} =~ /o$/
           || $_[0]{V}{raw} =~ /^(finis|nuntius|factor(em|i))$/
           || $hasblock;
        my $dative = defined $_[0]{D}
            ? $_[0]{D}->translate
            : "";
    my $Dref = $verb =~ /^(bless)$/ && $dative =~ /^[%@]/ ? "\\" : "";
    $dative = $Dref . $dative if $dative;
    my $Dcomma = $dative && defined $_[0]{A} && !$hasblock && $verb !~ /^(print|printf)$/ ? "," : "";
    if ($verb =~ /^(package|use)$/) {
        return "$verb $_[0]{A}[0]{raw} ";
    }
    elsif ($verb eq ':') {  # LABEL
        return " $_[0]{A}[0]{raw}: ";
    }
    elsif ($_[0]{V}{diamond}) {
        $result = "<" . substr($dative,1) . ">";
    }
    elsif ($verb =~ /^[\$%@]\{$/) {
        $result = $verb . $_[0]{A}[0]->translate . '}';
    }
    elsif (! $_[0]{V}{operator}) {
        $result = "$verb "
             . ($noparen ? "" : "(")
             . $dative . $Dcomma
             . " "
             . (defined $_[0]{A} ? join ", ", map({ $_->translate($_[0]{V}) } @{$_[0]{A}}) : "")
             . ($noparen ? "" : ")") ;
    }
    elsif ($prefix && $dative) {
        $result = " $verb $dative ";
    }
    elsif ($prefix) {
        $result = " $verb (" . $_[0]{A}[0]->translate . ")";
    }
    elsif ( $verb eq '=' ) {
        $result = " "
             . $dative
             . " $verb "
             . ( @{$_[0]{A}} > 1
            ? "(" . join(",", map($_->translate, @{$_[0]{A}})) .  ")"
            : $_[0]{A}[0]->translate
               );
    }
    else
    {
        my $Acount = @{$_[0]{A}||[]};
        my $neg = $verb =~ s/^!(<=>|cmp)/$1/ ? "!" : "";
        $result = " $neg("
             . ( $dative          ? $dative
               : $Acount-- ? shift(@{$_[0]{A}})->translate
               :                    "")
             . " $verb "
             . ( $Acount ? $_[0]{A}[0]->translate : "")
             . ")";
    }
    if ($_[0]->{G}) {
        my $perl = pop(@{$_[0]->{G}})->{perl};  # LAST GENITIVE IS THE VARIABLE
        $perl =~ s/^([\%\@])/\$/;
        my $type = $1;
        while (my $next = pop @{$_[0]->{G}}) {
            $perl .= $lb{$type} . $next->translate . $rb{$type};
        }
        $result = $perl . $lb{$type} . $result . $rb{$type};
    }
    return '\\'x($_[0]{R}||0) . $result;
}

sub BLOCK::translate {
    return "{"
         . join(";\n", map {$_->translate} @{$_[0]})
         . "}" ;
}

sub CONNECTIVE::translate {
    return $_[0]{L}->translate . " $_[0]{perl} " . $_[0]{R}->translate;
}

sub Separator::translate {
    return $_[0]{perl};
}

sub SUBNAME::translate {
    return $_[0]{perl};
}

sub SUBNAME_OA::translate {
    return $_[0]{perl};
}

sub SUBNAME_A::translate {
    return $_[0]{perl};
}

sub SUBNAME_D::translate {
    return $_[0]{perl};
}

sub SUBNAME_AD::translate {
    return $_[0]{perl};
}

sub SUBNAME_AB::translate {
    return $_[0]{perl};
}

sub SUBNAME_ACCUSATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_A_ACCUSATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_D_ACCUSATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_AD_ACCUSATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_AB_ACCUSATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_B_ACCUSATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_DATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_A_DATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_D_DATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_AD_DATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_AB_DATIVE::translate {
    return $_[0]{perl};
}

sub SUBNAME_B_DATIVE::translate {
    return $_[0]{perl};
}

sub DATIVE::translate {
    my ($self) = @_;
    my $perl = $self->{perl};
    if ($self->{G}) {
        my $gen = pop(@{$self->{G}})->{perl};   # LAST GENITIVE IS THE VARIABLE
        $gen =~ s/^([\%\@])/\$/;
        my $type = $1;
        while (my $next = pop @{$self->{G}}) {
            $gen .= $lb{$type} . $next->translate . $rb{$type};
        }
        $perl = $gen . $lb{$type} . $perl . $rb{$type};
    }
    return $perl;
}

sub OWNER_D::translate {
    return $_[0]{perl};
}

sub ACCUSATIVE::translate {
    my ($self) = @_;
    my $perl = $self->{perl};
    if ($self->{G}) {
        my $gen = pop(@{$self->{G}})->{perl};   # LAST GENITIVE IS THE VARIABLE
        $gen =~ s/^([\%\@])/\$/;
        my $type = $1;
        while (my $next = pop @{$self->{G}}) {
            $gen .= $lb{$type} . $next->translate . $rb{$type};
        }
        $perl = $gen . $lb{$type} . $perl . $rb{$type};
    }
    return '\\'x($_[0]{R}||0) . $perl;
}

sub CONTROL::translate {
    return $_[0]{perl}
         . " (" . $_[0]{C}->translate . ") "
         . $_[0]{B}->translate
         . "\n";
}

sub FOR::translate {
    return $_[0]{perl}
         . " " . $_[0]{D}->translate
         . " (" . $_[0]{C}->translate . ") "
         . $_[0]{B}->translate
         . "\n";
}

sub NUMERAL::translate {
    my ($self) = @_;
    # if ($self->{G}) {
        # return $self->{G}->index($self->{perl});
    # }
    return $self->{perl};
}

sub ORDINAL::translate {
    my ($self) = @_;
    return $self->{perl} unless $self->{G};
    my $perl = pop(@{$self->{G}})->translate;   # LAST GENITIVE IS THE VARIABLE
    $perl =~ s/^([\%\@])/\$/;
    my $type = $1;
    while (my $next = pop @{$self->{G}}) {
        $perl .= $lb{$type} . $next->translate . $rb{$type};
    }
    return $perl . $lb{$type} . $self->{perl} . $rb{$type};
}

*ORDINAL_DATIVE::translate = *ORDINAL::translate;

sub DISJUNCTION::translate {
    return $_[0]{perl};
}

sub CONJUNCTION::translate {
    return $_[0]{perl};
}

sub Literal::translate {
    my ($self, $context) = @_;
    my $perl;
    if ($context && $context->{raw} =~ /^inque/) {
        $perl = qq{'$_[0]{raw}'}
    }
    elsif ( $self->{lex} eq 'GENITIVE' ) {
        $perl = $self->GENITIVE::translate;
    }
    elsif ( $self->{lex} eq 'SUBNAME_A_GENITIVE' ) {
        $perl = $self->SUBNAME_A_GENITIVE::translate;
    }
    elsif ( $self->{lex} eq 'INFINITIVE' ) {
        $perl = "sub $_[0]{perl}\n" .  $_[0]{B}->translate;
    }
    else {
        $perl = '\\'x($_[0]{R}||0) . $_[0]{perl}
    }
    if ($self->{G}) {
        my $gen = pop(@{$self->{G}})->{perl};   # LAST GENITIVE IS THE VARIABLE
        $gen =~ s/^([\%\@])/\$/;
        my $type = $1;
        while (my $next = pop @{$self->{G}}) {
            $gen .= $lb{$type} . $next->translate . $rb{$type};
        }
        $perl = $gen . $lb{$type} . $perl . $rb{$type};
    }
    return $perl;
}

sub GENITIVE::translate {
    return $_[0]{perl};
};

sub SUBNAME_A_GENITIVE::translate {
    return $_[0]{perl};
};

sub Name::translate {
    return qq{'$_[0]{raw}'}
}

1;

__END__