#!/usr/bin/perl -w ###################################################################### 2004/03/02
#
# MorphoFS.pl ########################################################################## Otakar Smrz

# $Id: MorphoFS.pl,v 1.9 2004/07/08 18:00:03 smrz Exp $

our $VERSION = do { my @r = q$Revision: 1.9 $ =~ /\d+/g; sprintf "%d." . "%02d" x $#r, @r };

use ExperiMorph;

use AraMorph;

use XMorph;

use MorphoMap 1.03;

use Encode::Arabic;

use Fslib;

sub encrypt ($) {

    my $text = shift @_;

    $text =~ s/\&/\&amp\;/g;
    $text =~ s/\>/\&gt\;/g;
    $text =~ s/\</\&lt\;/g;

    return $text;
}

sub decrypt ($) {

    my $text = shift @_;

    $text =~ s/\&lt\;/\</g;
    $text =~ s/\&gt\;/\>/g;
    $text =~ s/\&amp\;/\&/g;

    return $text;
}


$decode = "utf8";
$encode = "utf8";

@ARGV = glob join " ", @ARGV;

until (eof()) {


    $file = FSFile->create(

                'FS'        => FSFormat->create(

                                        '@N ord',
                                        '@P type',
                                        '@L type|paragraph|word_node|entity|partition|token_form|lemma_id|token_node',
                                        '@P tips',
                                        '@P inherit',
                                        '@H hide',
                                        '@P restrict',
                                        '@P ref',
                                        '@P par',
                                        '@V input',
                                        '@P input',

                                        #'@P lemma',

                                        map {

                                            '@P ' . $_,

                                            } qw 'solution form morph tag gloss lookup id apply_m apply_t comment'
                                ),

                'hint'      => q {<? '${gloss}' if $this->{type} eq 'token_node' ?>},
                'patterns'  => [

                        'cvs: $' . 'Revision' . ': $ $' . 'Date' . ': $',

                        'style:' . q {<?

                                $this->{apply_m} > 0 ? '#{Line-fill:red}' : defined $this->{apply_m} ? '#{Line-fill:black}' : ()

                            ?>},

                        q {<?
                                $this->{type} eq 'token_node'

                                    ? ( '${form}' )

                                    : (

                                    $this->{type} eq 'lemma_id'

                                        ? ( '#{purple}${gloss} #{gray}${id} #{darkmagenta}${form}' )
                                        : (

                                        $this->{type} =~ /^entity|word_node|paragraph$/

                                            ? (

                                            $this->{apply_m} > 0

                                                ? '#{black}${id} #{gray}${lookup} #{red}${input}'
                                                : '#{black}${id} #{gray}${lookup} #{black}${input}'

                                            )
                                            : ( '${form}' )
                                        )
                                    )
                            ?>},

                        '#{darkred}${tag}' . q {<?

                                $this->{inherit} eq '' ? '#{red}' : '#{orange}'

                            ?>} . '${restrict}',

                                ],
                'trees'     => [],
                'backend'   => 'FSBackend',
                'encoding'  => $encode,
        );


    $now_time = gmtime;

    $/ = ">";

    ($date, $type) = <> =~ /<DOC id=\"([^\"]+)\" type=\"([^\"]+)\"/;

    $DOCid = $date . '_' . $type;

    $par_id = 0;

    $word_tree = 0;

    $prev_par = 1;

    $/ = "</";


    until (eof) {

        $_ = decode $decode, scalar <>;

        $sgml = $data = undef;

        ($sgml, $data) = m%^(?: [A-Z]+ > )? (?: [\ \t\r\n]* < ([^>]+) > )+ ([^<]*) </$%x;

        next unless $sgml and $data;

        $data = decrypt $data;

        @anchor = (0);

        @nodes = ();

        while ($data =~ /(\G [\ \t\r\n]* ( (?: \p{Arabic} | [\x{064B}-\x{0652}\x{0670}\x{0657}\x{0656}\x{0640}] |
                                             # \p{InArabic} |   # too general
                                               \p{InArabicPresentationFormsA} | \p{InArabicPresentationFormsB} )+ |
                                            \p{Latin}+ |
                                            [0-9]+(?:[\.\,\x{060C}\x{066B}\x{066C}][0-9]+)? |
                                            [\x{0660}-\x{0669}]+(?:[\.\,\x{060C}\x{066B}\x{066C}][\x{0660}-\x{0669}]+)? |
                                            [\.\,\;\:\!\?\`\"\'\(\)\[\]\{\}\<\>\\\|\/\~\@\#\$\%\^\&\*\_\=\+\-] |   # G...
                                            [^\ \t\r\n] ) )/gx) {

            $chunk = $1; # look, a squirrel!

        {
    #       use bytes;
            push @anchor, $anchor[-1] + length $chunk;
        }
        }

        for ($i = 1; $i < @anchor; $i++) {

            $node = {};

        {
    #       use bytes;
            $input = substr $data, $anchor[$i - 1], $anchor[$i] - $anchor[$i - 1];
        }

            $input =~ s/^[\ \t\r\n]+//;

            $lookup = encode 'buckwalter', $input;

            $node->{'input'} = $input;
            $node->{'lookup'} = $lookup;

            if ($lookup =~ /^[\.\,\;\:\!\?\`\"\'\(\)\[\]\{\}\<\>\\\|\/\~\@\#\$\%\^\&\*\_\=\+\-]$/) { # see above

                $node->{'morpho'} = [ [ "() [DEFAULT] " . ( encrypt $lookup ) . "/PUNC", "" ] ];
            }
            else {

                $remove = remove_diacritics_buckwalter($lookup);

                @queue = ($lookup, ( $remove eq $lookup ? () : $remove ), AraMorph::get_alternatives($remove));

                $score = 0;

                $node->{'morpho'} = [];

                while (@queue) {

                    $lookup = shift @queue;

                    $input = decode 'buckwalter', $lookup;

                    if (@morpho = ExperiMorph::analyze(encode 'utf8', $input)) {

                        warn $morpho[0] . "<>". $lookup . "\n" if $morpho[0] ne $lookup;

                        shift @morpho;

                        $node->{'lookup'} .= ' ' . $lookup;
                        push @{$node->{'morpho'}}, map { $_ % 2 ? [ $morpho[$_ - 1], $morpho[$_] ] : () } 1..@morpho;

                        $score++;
                    }
                    elsif (@morpho = AraMorph::analyze($lookup)) {

                        $node->{'lookup'} .= ' ' . $lookup;
                        push @{$node->{'morpho'}}, map { [ $morpho[$_][0], $morpho[$_][1] ] } 0..@morpho - 1;

                        $score++;
                    }
                }

                unless ($score > 0) {

                    $node->{'morpho'} = [ [ '(' . ( encrypt $node->{'lookup'} ) . ') ' .
                                                  ( encrypt $node->{'lookup'} ) . '/NIL', 'NOT_IN_LEXICON' ] ];
                }

                @lookups = split / /, $node->{'lookup'};

                if ($lookups[0] eq $lookups[1]) {

                    shift @lookups;
                }
                else {

                    $lookups[0] = '[' . $lookups[0] . ']';
                }

                $node->{'lookup'} = join ' ', @lookups;
            }

            push @nodes, $node;
        }


        # #########################################################################################
        #
        # #########################################################################################

        # process paragraph

        $this_par = ++$par_id + $word_tree;

        $root = $file->new_tree($this_par - 1);

        $root->{'type'} = 'paragraph';
        $root->{'id'} = "#$par_id";
        $root->{'input'} = $sgml eq 'P' ? 'TEXT' : $sgml;
        $root->{'ord'} = $ord = 0;

        $root->{'comment'} = "$DOCid $now_time [MorphoFS.pl $VERSION]";

        foreach $node (@nodes) {

            $wordnode = FSNode->new();

            $wordnode->{'type'} = 'word_node';
            $wordnode->{'input'} = $node->{'input'};
            $wordnode->{'ref'} = ++$word_tree + $par_id;
            $wordnode->{'ord'} = ++$ord;

            Paste($wordnode, $root, $file->FS()->defs());
        }

        $root->{'par'} = $prev_par . '^';
        $prev_par = $this_par;
        $root->{'par'} .= $word_tree + $par_id + 1;

        $word_in_par = 0;

        foreach $node (@nodes) {

            $root = $file->new_tree(++$word_in_par + $this_par - 1);

            $root->{'type'} = 'entity';
            $root->{'id'} = "#$par_id/" . $word_in_par;
            $root->{'ref'} = $this_par;
            $root->{'ord'} = $ord = 0;

            $root->{$_} = $node->{$_} foreach keys %{$node};

            process_node_morpho($node);

            foreach (@{$node->{'token_info'}}) {

                push @{$node->{'partition'}{remove_diacritics(join " ", map { $_->[0] } @{$_}[1..@{$_} - 1])}}, $_;
            }

            foreach (sort keys %{$node->{'partition'}}) {

                $partinode = FSNode->new();

                $partinode->{'type'} = 'partition';
                $partinode->{'form'} = $_;
                $partinode->{'ord'} = ++$ord;

                Paste($partinode, $root, $file->FS()->defs());

                for ($l = 1; $l < @{$node->{'partition'}{$_}->[0]}; $l++) {

                    $morphonode = FSNode->new();

                    $morphonode->{'type'} = 'token_form';
                    $morphonode->{'form'} = remove_diacritics($node->{'partition'}{$_}->[0][$l][0]);
                    $morphonode->{'ord'} = ++$ord;

                    Paste($morphonode, $partinode, $file->FS()->defs());

                    %repeated = ();
                    %cluster = ();

                    for ($i = 0; $i < @{$node->{'partition'}{$_}}; $i++) {

                        push @{$cluster{$node->{'partition'}{$_}->[$i][$l][4]}}, $node->{'partition'}{$_}->[$i][$l];
                    }

                    foreach (sort keys %cluster) {

                        $lemmanode = FSNode->new();

                        @lem_id = restore_lemma($_);

                        $lemmanode->{'type'} = 'lemma_id';
                        $lemmanode->{'form'} = $lem_id[0];
                        $lemmanode->{'id'} = $lem_id[1];
                        $lemmanode->{'ord'} = ++$ord;

                        $lemmanode->{'gloss'} = join '/', sort keys %{XMorph::analyze(@lem_id)};

                        Paste($lemmanode, $morphonode, $file->FS()->defs());

                        for ($i = 0; $i < @{$cluster{$_}}; $i++) {

                            foreach $tag (MorphoMap::distinguish_POSVector(MorphoMap::AraMorph_POSVector($cluster{$_}[$i]->[2]))) {

                                next if exists $repeated{join " ", $cluster{$_}[$i]->[0], $cluster{$_}[$i]->[4], $tag};

                                $repeated{join " ", $cluster{$_}[$i]->[0], $cluster{$_}[$i]->[4], $tag}++;

                                $tokennode = FSNode->new();

                                $tokennode->{'type'} = 'token_node';
                                $tokennode->{'form'} = $cluster{$_}[$i]->[0];
                                $tokennode->{'morph'} = $cluster{$_}[$i]->[1];
                                $tokennode->{'tag'} = $tag;

                                # $tokennode->{'lemma'} = $cluster{$_}[$i]->[4];

                                $tokennode->{'gloss'} = $cluster{$_}[$i]->[3];
                                $tokennode->{'gloss'} =~ s/[\+\ ]+$//;

                                $tokennode->{'ord'} = ++$ord;

                                Paste($tokennode, $lemmanode, $file->FS()->defs());
                            }
                        }
                    }
                }
            }
        }
    }

    # process rest of file

    $file->tree($this_par - 1)->{'par'} = join '^', (split /[^0-9]+/, $file->tree($this_par - 1)->{'par'})[0], $this_par;

    $file->writeFile($ARGV . '.morpho.fs');
}


# #########################################################################################
#
# #########################################################################################

# process the string of morphological analysis

sub process_node_morpho {

    my ($node) = @_;
    my (@token_info, @morpheme_buffer, @morphemes, @glosses, $lemma_id, $i);

    # $node->{morpho} = [];    # to include elements of the form ['translit', 'lemma_id', 'tag', 'gloss', 'number']

    if (exists $node->{morpho} and @{$node->{morpho}}) {

    # extract the elements out of the analyzer's string

    $node->{'morpho'} = [ map { [

                                    $_->[0] =~ m/^\( ( [^\)]* ) \) \s* ((?: \[ [^\]]* \] )?) \s* (.*)$/x,
                                    $_->[1],
                                    ++$i

                            ] } @{$node->{'morpho'}} ];

    $node->{token_info} = [];

    foreach (@{$node->{morpho}}) {

        @token_info = ($_->[1]);    # remember the lemma_id

        # $token_info[0] =~ s/^\[\s*//;
        # $token_info[0] =~ s/\s*\]$//;

        @morpheme_buffer = ();

        if (defined $_->[2]) {

            $_->[2] =~ s/\-//g unless $_->[2] eq '-/PUNC';
        }
        else {

            warn "My undefined, token_info '@token_info', remember '$remember'\n";
            $_->[2] = "";
        }

        $remember = $_->[1];

        @morphemes = split /\+/, $_->[2];

        @glosses = split /\s*\+\s*/, $_->[3];
        push @glosses, ('') x (@morphemes - @glosses);

        # warn 'Split mismatch ' . @morphemes . ' ' . @glosses unless @morphemes == @glosses;


        for (my $m = 0; $m < @morphemes; $m++) {

        if ($morphemes[$m] =~ m{^(wa/CONJ|bi/PREP|fa/CONJ|li/PREP|sa/FUT|ka/PREP|la/EMPHATIC_PART|
                    lam/NEG_PART|la/RESULT_CLAUSE_PARTICLE|li/SUBJUNC|\>a/INTERROG_PART|min/PREP|
                    [lm]A/NEG_PART|\>an/CONJ)}x and $m < @morphemes - 1) {

            # fill the buffer and complete the info on the token being this morpheme

            $lemma_id = $morphemes[$m];

            push @morpheme_buffer, [$morphemes[$m], $glosses[$m]];
            push @token_info, process_morpheme_buffer(\@morpheme_buffer, $lemma_id);
        }
        elsif ($morphemes[$m] =~ m{^(.*/POSS_PRON_|.*/PRON|mA/REL_PRON|mA/INTERROG_PART|[lm]A/NEG_PART|
                    .*/[PIC]VSUFF_DO|\>ay~/INTERROG_PART|\>ay~ap/INTERROG_PART|kam/INTERROG_PART|
                    man/REL_PRON|man/INTERROG_PART|mA\*A/INTERROG_PART)}x and $m > 0) {

            # complete the info on the token defined by the previous sequence of morphemes
            # buffer the current morpheme

            push @token_info, process_morpheme_buffer(\@morpheme_buffer, $lemma_id);
            push @morpheme_buffer, [$morphemes[$m], $glosses[$m]];

            $lemma_id = $morphemes[$m];
        }
        else {

            # buffer the current morpheme

            push @morpheme_buffer, [$morphemes[$m], $glosses[$m]];

            $lemma_id = $token_info[0];
        }
        }

        push @token_info, process_morpheme_buffer(\@morpheme_buffer, $lemma_id);

        push @{$node->{token_info}}, [@token_info];
    }

    }
    else {

    @token_info = map { [ $_, $_, $_, 'NON_ALPHABETIC_DATA', '[XXX]', 'd' ] }
                  grep { $_ ne "" }
                      map { split /([\]\[\!\"\'\(\)\+\,\-\.\/\:\;\=\?\`\<\>\|\_\$\%\&\*])/, $_ }
                      split /(\s+)/, $node->{input};

    $node->{'token_info'} = [ [@token_info] ];
    }
}


# prepare form, lemma and tag for current token

sub process_morpheme_buffer {

    my ($ref, $id) = @_;

    return unless @$ref;

    my $token = join "+", map { $_->[0] =~ m{^(.*)/}; $1 } @$ref;

    $token =~ s/([tknhy])\+\1/$1\~/g;
    $token =~ s/\+//g;

    if ($token =~ /\-/ and $token ne '-') {

        warn "Reducing '$token'";
        $token =~ s/\-//g;
    }

    $token = detransliterate($token);

    my $lemma = join '+', map { $_->[0] =~ m{^(.*)/}; $1 } @$ref;

    my $tag = join '+', map { $_->[0] =~ m{^.*/(.*)}; $1 } @$ref;

    my $gloss = join ' + ', map { $_->[1] } @$ref;

    @$ref = ();

    return [$token, $lemma, $tag, $gloss, $id, 'f'];
}


sub restore_lemma {

    my ($lemma, $idx) = $_[0] =~ /^\[([^_]*)(?:_([^\]*]))\]$/;

    # not for cp1256 # return join "_", map { decode 'buckwalter', $_ } $lemma, $idx;

    $lemma =~ tr[{][A] if $lemma;

    return ( ( decode 'buckwalter', $lemma ), $idx ) if $lemma;

    ($lemma, $idx) = $_[0] =~ /^([^\/]*)\/(.*)$/;

    $lemma =~ tr[{][A] if $lemma;

    return ( ( decode 'buckwalter', $lemma ), $idx ) if $lemma;

    return $_[0], '?';
}


sub remove_diacritics {

    my $text = encode 'buckwalter', shift;

    $text = remove_diacritics_buckwalter($text);

    return decode 'buckwalter', $text;
}


sub remove_diacritics_buckwalter {

    my $text = shift;

    $text =~ s/[aiuoFKN\~\`\_]//g;

    return $text;
}


sub detransliterate {
  my ($s)=@_;
  $s=~s/\(null\)//g;

  # $s=~s/[auio\~\`FKN]//g;

  #$s=~tr['|>&<}AbptvjHxd*rzs$SDTZEg_fqklmnhwYyFNKaui~o`{] # ' # emacs -*- perl -*-
  #  [\xC1-\xD6\xD8-\xDF\xE1\xE3-\xE6\xEC\xED\xF0-\xF3\xF5\xF6\xF8\xFA\xF3\xC7];

  $s = decode 'buckwalter', $s;

  $s =~ tr[\x{0671}][\x{0627}];

  return $s;
}
