#!/usr/bin/perl -w
# file KLEIDER/web/src/localization/resstruct.pl
# Verschachtelungen in der Übersetzung auflösen
# 2015-01-27 Herbert Schiemann <h.schiemann@herbaer.de>
# GPL Version 2 oder neuer

# 2015-07-02 Name der Übersetzungs-Maschine
# 2016-03-25 Wortendungen

package main;

use utf8 ;
use Herbaer::Readargs ;
use Herbaer::Replace ;
use Herbaer::XMLDataWriter ;

binmode (STDIN,  ":utf8") ;
binmode (STDOUT, ":utf8") ;
binmode (STDERR, ":utf8") ;

# Hash der Kommandozeilen-Argumente
my $args = {
   "[cnt]verbose" => 1,
   "in"           => "-",         # Eingabedatei (Text) oder - für STDIN
   "out"          => "-",         # Ausgabedatei oder - für STDOUT
   "tgtlang"      => undef,       # Zielsprache
   "ptnfix"       => 'XK${id}KX', # Platzhalter für nicht übersetzbaren Text mit ${id}
};

my $verbose ;

# gibt die Version nach STDOUT aus
sub version {
   print <<'VERSION' ;
resstruct.pl v20150127
Verschachtelungen in der Übersetzung auflösen
2015 Herbert Schiemann <h.schiemann@herbaer.de>
VERSION
}
$args -> {"[sr]version"} = sub { version (); exit 0; };

$args -> {"[sr]help"} = sub {
   version ();
   print_message_with_values (<<'HELP', $args);
resstruct.pl [Optionen]
--[no_]verbose     Umfang der Meldungen ${[cnt]verbose}
--in IN            Pfad der Eingabedatei oder "-" für STDIN
                   ${in}
--out OUT          Pfad der Ausgabedatei oder "-" für STDOUT
                   ${out}
--tgtlang TGTLANG  Zielsprache ${tgtlang}
--ptnfix PTNFIX    Platzhalter für unveränderlichen Text ${ptnfix}
HELP
   exit 0;
};

read_args ($args);
$verbose = $args -> {"[cnt]verbose"};

=for comment

Ausgabe:

<translation>
   <to>zh</to>
   <text id = "4711">übersetzter Text</text>
   <struct id = "4711">
     <part>Teiltext</part>
     <ref>id1</ref>
     <part>Teiltext</part>
     <ref>id2</ref>
     <part>Teiltext</part>
     <moved>id3</moved>
     <moved>id4</moved>
   </struct>
   <error>0815</error>
   <machine>Mudel</machine>
</translation>

=cut

my $translation = {
   "to"      => $args -> {"tgtlang"},
   "text"    => {},    # id als Schlüssel
   "machine" => undef, # maschinelle Übersetzung in die Zielsprache?

   # ebenfalls id als Schlüssel
   # die Werte sind eine Liste von {"part" => "TEXT"} oder {"ref" => "IDREF"}
   "struct"  => {},

   # Liste der ID zu "unlösbaren" Strukturen
   "error"   => [],
};

# Die Werte sind Listen von ID
my $inpstr = {};

readinp   ($args, $translation, $inpstr);
resolve   ($args, $translation, $inpstr);
writeoutp ($args, $translation);
exit 0;

# Die Eingabe lesen
sub readinp {
   my ($args, $translation, $inpstr) = @_;
   my $text = $translation -> {"text"};
   my $in = $args -> {"in"};
   my $hin;
   if ($in ne "-") {
      open ($hin, "<:encoding(utf-8)", $in);
   }
   else {
      $hin = STDIN ;
   }
   my $line;
   my $read = 0;
   my $id;
   my $txt;
   my $remach = "^=machine\\s+" . quotemeta ($args -> {"tgtlang"}) . "\\s+(.*?)\\s*\$" ;
   my $retrans = "^=trans\\s+" . quotemeta ($args -> {"tgtlang"}) ;
   my $refs;      # referenzierte IDs als Textliste
   while ( defined ($line = <$hin>) ) {
      if ( $line =~ /^#/ ) {
      }
      elsif ( $line =~ /^=/ ) {
         if ($id && $read) {
            $txt =~ s/\s*$// ;
            $txt =~ s/\s+/ /g ;
            $text -> {$id} = $txt;
            $txt  = "";
            $read = 0;
         }
         $read = 0;
         if ( $line =~ /$remach/ ) {
            $translation -> {"machine"} = $1 ;
         }
         elsif ( $line =~ /^=segment\s+(\S+)/ ) {
            $id = $1;
         }
         elsif ( $line =~ /$retrans/ ) {
            $read = 1;
         }
         elsif ( $line =~ /^=struct\s+(.+)$/ ) {
            $refs = $1;
            $refs =~ s/\s+$//;
            $inpstr -> {$id} = [split (/\s+/, $refs)] ;
         }
      }
      elsif ( $read ) {
         $line =~ s/^\\// ;
         $txt .= $line;
      }
   }
   if ($id && $read) {
      $txt =~ s/\s*$// ;
      $txt =~ s/\s+/ /g ;
      $text -> {$id} = $txt;
      $txt = "";
      $read = 0;
   }
   close $hin if $in ne "-";
} # readinp

# Die Verschachtelungen auflösen
sub resolve {
   my ($args, $translation, $inpstr) = @_ ;
   my $ptnfix = $args -> {"ptnfix"};    # Platzhalter für unveränderlichen Text
   my $text   = $translation -> {"text"};
   my $struct = $translation -> {"struct"};
   my $errlst = $translation -> {"error"};
   my $id;
   my $refs;
   my $ref;      # ID-Referenz mit optionalem Fragezeichen
   my $refid;    # die referenzierte ID
   my $rm;       # verbleibender Text
   my $opt;      # Optionale Referenz?
   my $tt;       # Teiltext
   my $rtext;    # referenzierter Text
   my $retext;   # RegEx zum referenzierten Text

   # Ergebnisliste mit Einträgen {"part" => text},  {"ref" => id}, {"moved" => id}
   my $list;

   while ( ($id, $refs) = each %$inpstr ) {

      # Hier sind andere Verfahren nötig.
      # Die Reihenfolge der Kindelemente hat meist keine Bedeutung.
      # Und wenn es auf die Reihenfolge ankommt,
      # kann die richtige Reihenfolge außerhalb des Zusammenhangs der Übersetzung
      # überprüft und sichergestellt werden.

      $list = [];
      $rm = $text -> {$id} or next;

      print STDERR "ID $id\n", "TEXT $rm\n" if $verbose;
      # Für jeden Verweis erzeugen wir einen Hash mit Einträgen
      # refid, rtext, length, moveable, pos, mcount, matches ...
      # matchpos ist eine Liste von Positionen, an denen rtext gefunden wird.
      my $refhsh;
      
      # Wir erzeugen zu jedem MATCH einen Hash mit Einträgen
      # beg, end, refhsh
      my $matchhsh;

      # Wir erzeugen Listen der $refhsh und $matchhsh
      my $refhlist   = [];
      my $matchhlist = [];

      # Die Datenstruktur muss wegen der Verweiszyklen dekonstruiert werden.

      my $pos = -1;     # Position des Verweises in der Ausgangsliste
      my $matches;      # Liste der Matches
      my $len;          # Länge des Verweistextes  # ***  hängt vom Match ab
      my $mcount;       # Anzahl der Match-Treffer
      my $pend = 0;     # Ende des bevorzugten Matches des vorhergehenden refs
      my $nend;         # Ende des bevorzugten Matches des refs
      my $fend;         # Ende des ersten Matches des refs
      my $nreqrefs = 0; # Anzahl der Verweise, die erforderlich sind
      my $noptrefs = 0; # Anzahl der optionalen (verschiebbaren) Verweise
      for $ref (@$refs) {
         $refid = $ref;
         $opt = 0;
         $matches = [];
         if ($refid =~ s/\?//) { $opt = 1; ++$noptrefs; }
         else                  { ++$nreqrefs; }
         $refhsh = {
            "refid"    => $refid,
            "moveable" => $opt,
            "matches"  => $matches,
            "pos"      => ++$pos,
         };
         push (@$refhlist, $refhsh);
         $rtext = $text -> {$refid};
         if (! defined ($rtext)) {
            $rtext = replace ($ptnfix, {"id" => $refid});
            $refhsh -> {"fix"} = 1;
            $len   = length ($rtext);
            $rtext = quotemeta ($rtext);
            $retext = qr/($rtext)/;
         }
         elsif ($rtext =~ /^(\S{2,})([a-z])([a-z])$/ ) {
            $retext = '\b(' . quotemeta ($1) . $2 . "?" . $3 . "?" . '[a-z]{0,2})\b';
            $retext = qr/$retext/i ;
            # Wort mit Endung
         }
         else {
            $len   = length ($rtext);
            $rtext = quotemeta ($rtext);
            $retext = qr/($rtext)/i;
         }
         $mcount = 0;
         $fend   = 0;
         $nend   = 0;
         while ( $rm =~ /$retext/g ) {
            $len = length ($1);
            $matchhsh = {
               "beg"    => pos ($rm) - $len,
               "end"    => pos ($rm),
               "length" => $len,
               "refhsh" => $refhsh,
            };
            $fend = $matchhsh -> {"end"} if !$fend;
            if ($matchhsh -> {"beg"} >= $pend && ! $nend) {
               $refhsh   -> {"prefmatch"} = $matchhsh;
               $matchhsh -> {"pref"} = 1;
               $nend = $matchhsh -> {"end"};
            }
            push (@$matches, $matchhsh);
            push (@$matchhlist, $matchhsh);
            ++$mcount;
         }
         if (!$nend && $fend) {
            $refhsh -> {"prefmatch"} = $matches -> [0];
            $pend = $fend;
         }
         else {
            $pend = $nend;
         }
         $refhsh -> {"mcount"} = $mcount;
      }
      print STDERR "ID $id: Verweisliste erzeugt\n" if $verbose;

      # wir sortieren die Matchliste nach Beginn, ...
      $matchhlist = [
         sort
         {
            $a -> {"beg"} <=> $b -> {"beg"}
            || $a -> {"refhsh"} -> {"mcount"}   <=> $b -> {"refhsh"} -> {"mcount"}
            || $a -> {"refhsh"} -> {"moveable"} <=> $b -> {"refhsh"} -> {"moveable"}
            || $a -> {"end"} <=> $b -> {"end"}
            || $a -> {"refhsh"} -> {"pos"} <=> $b -> {"refhsh"} -> {"pos"}
         }
         @$matchhlist
         ];
      print STDERR "ID $id: Verweisliste sortiert\n" if $verbose;

      # Jetzt suchen wir eine "stimmige" Teilliste der Matchliste
      if (! resolve_text ($matchhlist, $nreqrefs, $noptrefs) ) {
         push (@$errlst, $id);
         print STDERR "ID $id: Verweise nicht aufgelöst\n" if $verbose;
      }
      else {
         # wir bauen die Ausgabe-Liste auf
         # Ergebnisliste mit Einträgen {"part" => text},  {"ref" => id}, {"moved" => id}
         my $textpos = 0;
         my $len;
         $struct -> {$id} = $list;
         for $matchhsh (@$matchhlist) {
            if ($matchhsh -> {"selected"}) {
               $len = $matchhsh -> {"beg"} - $textpos;
               push (@$list, {"part" => substr ($rm, $textpos, $len)}) if $len;
               $refhsh = $matchhsh -> {"refhsh"};
               push (@$list, {"ref"  => $refhsh -> {"refid"}});
               if (!$refhsh -> {"fix"}) {
                  $text -> {$refhsh -> {"refid"}} =
                     substr ($rm, $matchhsh -> {"beg"}, $matchhsh -> {"length"});
               }
               $textpos = $matchhsh -> {"end"};
            }
         }
         push (@$list, {"part" => substr ($rm, $textpos)}) if $textpos < length ($rm);
         for $refhsh (@$refhlist) {
            push (@$list, {"moved" => $refhsh -> {"refid"}}) if ! $refhsh -> {"resolved"};
         }
      }

      # wir lösen zyklische Verweise auf
      for $matchhsh (@$matchhlist) {
         $matchhsh -> {"refhsh"} = undef;
      }
   }
} # resolve

# Wir suchen eine "stimmige" Teilliste der Matchliste
# my $reslist = resolve_text ($matchhlist)
# Die ausgewählten Matches bekommen die Markierung "selected" = 1;
sub resolve_text {
   my ($matchhlist, $nreqrefs, $noptrefs, $pos, $textpos, $allrefs) = @_;
   $pos     ||= 0;
   $textpos ||= 0;
   $allrefs ||= 0;
   # nreqrefs  Anzahl der nicht-optionalen Verweise
   # noptrefs  Anzahl der optionalen Verweise
   # pos       Position in der Liste matchhlist, ab der gesucht werden soll
   # textpos   Textposition, ab der Verweise möglich sind
   # allrefs   Fehler, wenn ein optionaler Verweis nicht gelöst wird

   print STDERR "resolve_text ($nreqrefs, $noptrefs, $pos, $textpos, $allrefs)\n"
      if $verbose;

   # Ende der Liste erreicht
   if ($pos >= @$matchhlist) {
      return ! $nreqrefs && (! $noptrefs || ! $allrefs);
   }

   # alle Verweise gelöst?
   if (!$nreqrefs && !$noptrefs) {
      while ($pos < @$matchhlist) {
         $matchhlist -> [$pos] -> {"selected"} = 0;
         ++$pos;
      }
      return 1;
   }

   my $match  = $matchhlist -> [$pos];
   my $refhsh = $match -> {"refhsh"};

   # Ist der Verweis schon gelöst?
   if ($refhsh -> {"resolved"}) {
      $match -> {"selected"} = 0;
      return resolve_text ($matchhlist, $nreqrefs, $noptrefs, ++$pos, $textpos, $allrefs);
   }
   
   my $res; # Ergebnis
   # Ist der Match schon "hinter dem Mond"?
   if ($match -> {"beg"} < $textpos) {
      -- $refhsh -> {"mcount"};
      $match -> {"selected"} = 0;
      $res = resolve_text ($matchhlist, $nreqrefs, $noptrefs, ++$pos, $textpos, $allrefs);
      ++ $refhsh -> {"mcount"};
      return $res;
   }

   if ($refhsh -> {"mcount"} == 1) {
      if ($refhsh -> {"moveable"}) {
         # wir versuchen erst, den Match auszuwählen
         $match  -> {"selected"} = 1;
         $refhsh -> {"resolved"} = 1;
         $res = resolve_text ($matchhlist, $nreqrefs, $noptrefs - 1, $pos + 1, $match -> {"end"}, 1);
         if ($allrefs || $res) {
            return $res;
         }
         if (!$res) {
            deselect ($matchhlist, $pos + 1);
            $res = resolve_text ($matchhlist, $nreqrefs, $noptrefs - 1, $pos + 1, $match -> {"end"}, 0);
            if ($res) {
               return $res;
            }
         }
         # Dann nicht
         deselect ($matchhlist, $pos);
         return resolve_text ($matchhlist, $nreqrefs, $noptrefs, $pos + 1, $textpos, 0);
      }
      else {
         # der Match muss ausgewählt werden
         $match  -> {"selected"} = 1;
         $refhsh -> {"resolved"} = 1;
         return resolve_text ($matchhlist, $nreqrefs - 1, $noptrefs, $pos + 1, $match -> {"end"}, $allrefs);
      }
   }

   if ( $refhsh -> {"prefmatch"} -> {"beg"} > $match -> {"beg"} ) {
      # wir probieren erst, den Match nicht auszuwählen
      -- $refhsh -> {"mcount"};
      $res = resolve_text ($matchhlist, $nreqrefs, $noptrefs, $pos + 1, $textpos, $allrefs);
      ++ $refhsh -> {"mcount"};
      if ($res) {
         return $res;
      }
      deselect ($matchhlist, $pos + 1);
   }

   # wir wählen den Match aus
   $match  -> {"selected"} = 1;
   $refhsh -> {"resolved"} = 1;
   -- $refhsh -> {"mcount"};
   $res =
      $refhsh -> {"moveable"} ?
      resolve_text ($matchhlist, $nreqrefs, $noptrefs - 1, $pos + 1, $match -> {"end"}, $allrefs) :
      resolve_text ($matchhlist, $nreqrefs - 1, $noptrefs, $pos + 1, $match -> {"end"}, $allrefs)
      ;
   ++ $refhsh -> {"mcount"};
   if ($res) {
      return $res;
   }

   if ( $refhsh -> {"prefmatch"} -> {"beg"} <= $match -> {"beg"} ) {
      deselect ($matchhlist, $pos);
      -- $refhsh -> {"mcount"};
      $res = resolve_text ($matchhlist, $nreqrefs, $noptrefs, $pos + 1, $textpos, $allrefs) ;
      ++ $refhsh -> {"mcount"};
   }

   return $res;
} # resolve_text

sub deselect {
   my ($matchhlist, $pos) = @_;
   my $match;
   my $refhsh;
   while ($pos < @$matchhlist) {
      $match  = $matchhlist -> [$pos];
      $refhsh = $match -> {"refhsh"};
      if ($match -> {"selected"}) {
         $refhsh -> {"resolved"} = 0;
         $match  -> {"selected"} = 0;
      }
      ++$pos;
   }
} # deselect

# Ausgabe
sub writeoutp {
   my ($args, $translation) = @_;
   my $writer = new Herbaer::XMLDataWriter ({
      '%struct'  => ["", "segment", '@id'],
      '@segment' => ["struct", "comp"],
      '%comp'    => ["", ""],
      '%text'    => ["", "text", '@id'],
      '@error'   => ["", ""],
   });
   $writer -> open (
      $args -> {"out"}, "utf-8", "http://herbaer.de/xmlns/20150127/resstruct#"
   );
   $writer -> write ("translation", {}, $translation);
   $writer -> close ();
} # writeoutp
# end of file KLEIDER/web/src/localization/resstruct.pl