#! /usr/bin/perl -w
#
# extract-tex.pl
#
# Dieses Perl-Skript extrahiert einfache Wortlisten aus der
# »wortliste«-Datenbank im Langformat (oder ähnlichen Dateien mit gleichem
# Dateiformat), die beispielsweise als Eingabedateien für »patgen« verwendet
# werden können.
#
# Aufruf:
#
#   perl extract-tex.pl [Optionen...] [liste1 liste2 ...] > input.patgen
#
# Die Eingabedateien müssen in UTF-8 kodiert sein; ist keine Eingabedatei
# angegeben, verwendet das Skript die Standardeingabe.  Beispiele:
#
#   perl extract-tex.pl -l < ../wortliste > wortliste.ref.latin9
#   perl extract-tex.pl -t ../wortliste > wortliste.trad.utf8
#
# Die Aufrufe
#
#   perl extract-tex.pl -1 ...
#   perl extract-tex.pl -t -1 ...
#   perl extract-tex.pl -s -1 ...
#
# liefern jeweils die gleiche Ausgabe wie
#
#   sprachauszug.py -l de-1996,de-1996-x-versal ...
#   sprachauszug.py -l de-1901,de-1901-x-versal ...
#   sprachauszug.py -l de-CH-1901,de-1901 ...
#
#
# Optionen
# --------
#
# -t
# -s  Option »-t« wählt die traditionelle deutsche Rechtschreibung aus,
#     Option »-s« die traditionelle (deutsch)schweizerische Rechtschreibung.
#     Wenn weder »-s« noch »-t« gesetzt ist, wird die reformierte deutsche
#     Rechtschreibung ausgewählt.
#
# -x  Ignoriere Optionen »-g«, »-u« sowie »-1« und gib die
#     sprachspezifischen Felder unbearbeitet aus (inklusive Kommentare).
#
# -g  Gib Wörter mit gewichteten Trennstellen aus.  Optional kann ein
#     ganzzahliges Argument angegeben werden: Wert 0 gibt alle gewichtete
#     Trennstellen aus inklusive »-« (das ist der Standardwert), Wert 1 nur
#     die Trennstellen mit der höchsten Wichtung (ohne »-«), Wert 2 die
#     Trennstellen mit der höchsten und zweithöchsten Wichtung (ohne »-«),
#     usw.
#
#     Beachte, dass bei nahe beieinanderstehenden Trennstellen derzeit keine
#     zusätzliche Wichtung vorgenommen wird.  Beispielsweise ist in dem Wort
#
#       ab<be<ru-fen
#
#     die Trennung »abbe-rufen« schlecht, weil ganz nahe der optimalen
#     Trennstelle (nach »ab«).  Das Skript gibt trotzdem diese Trennstelle
#     als zweitbeste aus.
#
# -u  Verhindere die Ausgabe von Wörtern mit Markern für unerwünschte
#     Trennungen (z.B. »An<=al-.pha=bet«).  Wenn nicht gesetzt, werden als
#     ungünstig markierte Trennstellen entfernt (z.B. »An<=alpha=bet«).
#
# -U  Gib Wörter mit Nicht-ASCII-Zeichen auch in Umschrift aus (z.B.
#     »loe-sen«, »Haen-de«).  Ausgenommen davon sind Wörter mit »ß«, weil
#     die entsprechenden Formen mit »ss« bereits in der Wortliste enthalten
#     sind.
#
# -1  (Ziffer 1) Verhindere einbuchstabige Trennungen.  Ist die Option
#     gesetzt, wird die erste dieser Trennungen unterdrückt, falls beide
#     Trennstellen gleichwertig sind (z.B. »eu-ro-päi-sche« statt
#     »eu-ro-pä-i-sche«), anderenfalls bleibt die stärkere erhalten (z.B.
#     »päd<ago-gisch« statt »pä-d<a-go-gisch«).
#
# -v  Verhindere die Ausgabe von Versalformen, wo »ß« durch »ss« ersetzt
#     ist.
#
# -l  (Kleinbuchstabe L) Konvertiere die Ausgabe von UTF-8 nach latin-9.
#
# -L  Erzeuge Schreibvarianten mit Lang-s (»le-ſen« neben »le-sen«).

# Wir verwenden »<<>>« statt »<>« aus Sicherheitsgründen.
require 5.22.0;

use strict;
use warnings;
use English '-no_match_vars';
use utf8;                              # String-Literals direkt als UTF-8.
use open qw(:std :utf8);
use Getopt::Long qw(:config bundling);


my ($opt_g, $opt_l, $opt_L, $opt_s, $opt_t, $opt_u, $opt_U, $opt_v, $opt_x, $opt_1);
$opt_g = -1;

GetOptions("g:i" => \$opt_g,
           "l"   => \$opt_l,
           "L"   => \$opt_L,
           "s"   => \$opt_s,
           "t"   => \$opt_t,
           "u"   => \$opt_u,
           "U"   => \$opt_U,
           "v"   => \$opt_v,
           "x"   => \$opt_x,
           "1"   => \$opt_1);


my $prog = $0;
$prog =~ s@.*/@@;


# Kodierung:
binmode(STDOUT, ":encoding(iso-8859-15)") if $opt_l;


# Einige Konstanten für reguläre Ausdrücke, um die Lesbarkeit zu
# erhöhen.
my $marker = qr/[.·<>=-]/x;
my $buchstabe = qr/(?: [^.·<>=-] | ch)/x;
my $vokal = qr/[aeiouäöüy]/x;
# Konsonant: nicht Vokal, aber Buchstabe.
my $konsonant = qr/(?! $vokal ) $buchstabe/;


sub entferne_marker {
  my $arg = shift;
  $arg =~ s/$marker//g;
  return $arg;
}

sub markiere_trennstellen {
  my $wort = shift;
  # Entferne spezielle Trennungen.
  $wort =~ s|\{ (.*?) / .*? \}|$1|gx;

  # Entferne Doppeldeutigkeiten.
  $wort =~ s|\[ (.*?) / .*? \]|entferne_marker($1)|egx;

  # Hier der Algorithmus, um die verbliebenen Markierungen in
  # Trennstellen aufzulösen.  Die Schritte sind in der gegebenen
  # Reihenfolge abzuarbeiten.
  #
  # Dieses Skript implementiert ausschließlich den morphemischen
  # Trennstil (siehe Punkt 1), unter weiterer Anwendung der Regeln
  # 2, 3, 4 und 6.  Regel 5 wird nicht angewendet.
  #
  # (1) Auflösung von Wahlmöglichkeiten zwischen morphemischem und
  #     syllabischem Trennstil (einer der beiden Stile muß gewählt
  #     werden).  Ungünstigkeitsmarker und Gesangstrennstellen
  #     werden in diesem Schritt nicht berücksichtigt (wohl aber
  #     entfernt, wenn die entsprechende Trennstelle entfällt).
  #
  #     (a) Die Bezeichnungen
  #
  #           <x-  und  -x<
  #
  #         sind Kurzschreibungen für
  #
  #           {<x/x-}  und  {x</-x}  (morphemisch/syllabisch)   ,
  #
  #         wobei »x« ein Konsonant oder »ch« ist.  Diese Regel gilt
  #         nicht für die Suffixe »>x-« und »-x>«.  Die
  #         Zusammensetzungen »=x-« und »-x=« werden gegenwärtig
  #         nicht beachtet, da sie in der Wortliste nicht vorkommen
  #         (Beispiel: Lö-b=au).
  #
  #     (b) Die Bezeichnungen
  #
  #           <i-  und  -i<
  #
  #         sind Kurzschreibungen für
  #
  #           {<i·/i-}  und  {·i</-i}  (morphemisch/syllabisch)   ,
  #
  #         wobei »i« ein Vokal ist (einschließlich »y«).  Diese
  #         Regel gilt nicht für die Suffixe »>i-« und »-i>«.  Die
  #         Zusammensetzungen »=i-« und »-i=« werden gegenwärtig
  #         nicht beachtet, da sie in der Wortliste nicht vorkommen
  #         (Beispiel: Ei-se-n=a-ch-er Motorenwerke).
  #
  #         Beispielsweise bleibt die Markierung
  #
  #             al-ge-bra>i-sche
  #
  #         in diesem Schritt unverändert; wegen »>« gibt es keine
  #         Wahlmöglichkeit.
  #
  # (2) Behandle (angehängte) ».«-Marker, falls ungünstige
  #     Trennstellen unterdrückt werden sollen.
  #
  # (3) Entferne Flattervokale (also Einbuchstaben-Silben), falls
  #     verlangt.  Beachte, daß »ch« wie ein Buchstabe behandelt
  #     wird und auch Schwankungsfälle berücksichtigt werden.
  #     Gesangstrennstellen dagegen werden ignoriert (aber
  #     gegebenenfalls entfernt).
  #
  #     (a) Ist eine Trennstelle »stärker« als die andere, wird die
  #         stärkere Trennstelle genommen (z.B. ist »>« stärker als
  #         »-«, »-« stärker als ».«).
  #
  #     (b) Sind die Trennstellen gleich stark, wird die rechte
  #         Trennstelle genommen.
  #
  # (4) Entferne Gesangstrennstellen, falls verlangt.  Beachte, daß
  #     die Markierung für Gesangstrennstellen, ähnlich zu
  #     Ungünstigkeitsmarkern, auch zu anderen Markern treten kann
  #     (die dann ebenfalls entfernt werden).
  #
  # (5) Entferne restliche Schwankungsfälle, falls verlangt.
  #
  # (6) Alle verbliebenen Markierungen werden zu »-« aufgelöst.
  #
  #
  # Beispiele:
  #   Re<s-tau-rant
  #   Re<stau-rant  (1a, morphemisch)
  #   Re-stau-rant  (6)
  #
  #   Re<s-tau-rant
  #   Res-tau-rant  (1a, syllabisch)
  #
  #   Ge-r<i.a-trie
  #   Ger<i.a-trie  (1a, morphemisch)
  #   Ger<ia-trie   (3)
  #   Ger-ia-trie   (6)
  #
  #   Ge-r<i.a-trie
  #   Ge-ri.a-trie  (1a, syllabisch)
  #   Ge-ria-trie   (3)
  #
  #   Ärz-te=i·n<.i-ti.a-ti-ve
  #   Ärz-te=i·n<.i·ti.a-ti-ve  (1b, morphemisch)
  #   Ärz-te=i·ni·ti.a-ti-ve    (2)
  #   Ärz-te=i·ni·tia-ti-ve     (3a)
  #   Ärz-te=initia-ti-ve       (4)
  #   Ärz-te-initia-ti-ve       (6)
  #
  #   Ärz-te=i·n<.i-ti.a-ti-ve
  #   Ärz-te=i·ni-ti.a-ti-ve  (1b, syllabisch)
  #   Ärz-te=i·ni-tia-ti-ve   (3a)
  #   Ärz-te=ini-tia-ti-ve    (4)
  #   Ärz-te-ini-tia-ti-ve    (6)
  #
  #   Di-a<s-po-ra
  #   Di·a<s-po-ra  (1b, morphemisch)
  #   Di·a<spo-ra   (1a)
  #   Dia<spo-ra    (4)
  #   Dia-spo-ra    (6)
  #
  #   Di-a<s-po-ra
  #   Di-as-po-ra   (1b, syllabisch)
  #
  #   Kaf-ka=ken-.ner
  #   Kaf-ka=kenner  (2)
  #   Kaf-ka-kenner  (6)
  #
  #   al-ge-bra>i-sche
  #   al-ge-bra>ische  (3a)
  #   al-ge-bra-ische  (6)
  #
  #   Ru-i-ne
  #   Rui-ne  (3b)
  #
  #   A<·s-phalt
  #   A<·sphalt  (1a, morphemisch)
  #   Asphalt    (4)
  #
  #   A<·s-phalt
  #   As-phalt  (1b, syllabisch)
  #
  #   ge-ni.al
  #   ge-nial  (5)

  # Schritt 1a.
  $wort =~ s/< \.* $konsonant \K - \.*//gx;
  $wort =~ s/- \.* ($konsonant \.*) (?= <)/$1/gx;

  # Schritt 1b.
  $wort =~ s/(< \.* $vokal) -/$1·/gx;
  $wort =~ s/- (\.* $vokal) (?= <)/·$1/gx;

  # Ausgabe von Wörtern mit unerwünschten Trennungen?
  next if $wort =~ /\./ and $opt_u;

  # Schritt 2.
  $wort =~ s/[·<>=-]+ \.+//gx;

  if ($opt_1) {
    # Schritt 3a: »a<=b-c« wird zu »a-bc«.
    $wort =~ s/[-.]+ (?= $buchstabe [<>=] [·<>=]* )//gx;
    $wort =~ s/[<>=] [·<>=]* $buchstabe \K [-.]+//gx;

    # Schritt 3a: »a-b.c« wird zu »a-bc«.
    $wort =~ s/\. ( $buchstabe - )/$1/gx;
    $wort =~ s/( - $buchstabe ) \./$1/gx;

    # Schritt 3b.
    $wort =~ s/- ( $buchstabe - )/$1/gx;
  }

  # Schritt 4.
  # TODO: Ergänze Option für »Gesangstext-Trennmuster«
  $wort =~ s/($buchstabe) [.·<>=-]* ·+ [.·<>=-]*/$1/gx;

  # Schritt 5.
  $wort =~ s/\./-/gx;

  if ($opt_g > 0) {
    # Berechne Wichtungen.  Wir verwenden folgende Werte:
    #
    #   -2   Wortteil
    #   -1   -
    #    0   --
    #    1   <, >
    #    2   =
    #    3   ==, <=, =>
    #    4   ===, <==, ==>
    #    ..
    #
    # Bei mehrfachem Auftreten von »<« hat das am meisten links stehende
    # den höchsten Rang.  Bei mehrfachem Auftreten von »>« hat das am
    # meisten rechts stehende den höchsten Rang.  Beispiel:
    #
    #   Mit<ver<ant-wort>lich>keit
    #      ^                 ^
    #
    # Das bezieht sich auch auf Ketten mit »=>« u.ä:
    #
    #   Ei-gen=wirt>schaft=>lich>keit
    #                           ^

    my $g;
    my $m;
    my ($r, $r_vorher);
    my ($w, $w_vorher);

    # Wir zerlegen mit `split' unter Beibehaltung der Begrenzer.
    my @zerlegung = split /([<>=-]+)/, $wort;

    # Wir speichern Wichtung und Rang als Felder.
    my @wichtung = (-2) x ($#zerlegung + 1);
    my @rang = (0) x ($#zerlegung + 1);

    # Erster Durchgang: Ermittle Wichtungswerte.

    # Wir starten bei erstem Marker (mit Index 1).
    foreach my $i (1 .. ($#zerlegung - 1)) {
      # Ignoriere Nicht-Marker.
      next if not $i % 2;

      $m = $zerlegung[$i];

      if ($m =~ /^-$/) {
        $w = -1;
      }
      elsif ($m =~ /^--$/) {
        $w = 0;
      }
      elsif ($m =~ /^[<>]$/) {
        $w = 1;
      }
      elsif ($m =~ /^=$/) {
        $w = 2;
      }
      elsif ($m =~ /( ==*>? | <?=*= )/x) {
        $w = length($1) + 1;
      }
      else {
        warn "Zeile $INPUT_LINE_NUMBER:"
             . " unbekannter Marker »$m« behandelt als »-«\n";
        $w = -1;
      }

      $wichtung[$i] = $w;
    }

    # Zweiter Durchgang: Adjustiere Wichtung von »<« und »>«.

    # Behandle »<« von rechts nach links gehend.
    $w_vorher = -2;
    foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
      # Ignoriere Nicht-Marker.
      next if not $i % 2;

      if (index ($zerlegung[$i], "<") >= 0) {
        # Hat der rechte Marker in einer Kette von »<« eine höhere
        # Wichtung, wird diese übernommen.
        $w = $wichtung[$i];

        if ($w_vorher >= $w) {
          $wichtung[$i] = $w_vorher;
        }
        else {
          $w_vorher = $w;
        }
      }
      # »-«-Marker zwischen zwei »<« ändert nicht deren Wichtung.
      elsif ($zerlegung[$i] ne "-") {
        $w_vorher = -2;
      }
    }

    # Behandle »>« von links nach rechts gehend.
    $w_vorher = -2;
    foreach my $i (1 .. ($#zerlegung - 1)) {
      # Ignoriere Nicht-Marker.
      next if not $i % 2;

      if (index ($zerlegung[$i], ">") >= 0) {
        # Hat der linke Marker in einer Kette von »>« eine höhere
        # Wichtung, wird diese übernommen.
        $w = $wichtung[$i];

        if ($w_vorher >= $w) {
          $wichtung[$i] = $w_vorher;
        }
        else {
          $w_vorher = $w;
        }
      }
      # »-«-Marker zwischen zwei »>« ändert nicht deren Wichtung.
      elsif ($zerlegung[$i] ne "-") {
        $w_vorher = -2;
      }
    }

    # Dritter Durchgang: Ermittle Rang von »<« und »>«.

    # Behandle »<« von links nach rechts gehend.
    $r = 0;
    foreach my $i (1 .. ($#zerlegung - 1)) {
      # Ignoriere Nicht-Marker.
      next if not $i % 2;

      if (index ($zerlegung[$i], "<") >= 0) {
        $rang[$i] = $r--;
      }
      # »-«-Marker zwischen zwei »<« ändert nicht den Rang.
      elsif ($zerlegung[$i] ne "-") {
        $r = 0;
      }
    }

    # Behandle »>« von rechts nach links gehend.
    $r = 0;
    foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
      # Ignoriere Nicht-Marker.
      next if not $i % 2;

      if (index ($zerlegung[$i], ">") >= 0) {
        $rang[$i] = $r--;
      }
      # »-«-Marker zwischen zwei »>« ändert nicht den Rang.
      elsif ($zerlegung[$i] ne "-") {
        $r = 0;
      }
    }

    # Sortiere Indexfeld für Marker mit absteigender Wichtung.
    my @wichtungsindices =
      sort {
        # Benutze Rang für Sekundärsortierung.
        if ($wichtung[$a] == $wichtung[$b]) {
          -($rang[$a] <=> $rang[$b]);
        }
        else {
          -($wichtung[$a] <=> $wichtung[$b]);
        }
      } (0 .. $#zerlegung);

    # Entferne Trennstellen unter Berücksichtigung des Arguments von »-g«.
    $g = 0;
    $w_vorher = -2;
    $r_vorher = 0;

    foreach my $i (@wichtungsindices) {
      # Alle Wortteile haben einen geraden Index und sind stets am Schluß
      # von @wichtungsindices.
      last if not $i % 2;

      $w = $wichtung[$i];
      $r = $rang[$i];

      if ($w_vorher == $w) {
        $g++ if $r_vorher != $r;
      }
      else {
        $g++;
      }

      $w_vorher = $w;
      $r_vorher = $r;

      # Entferne Trennung mit zu geringer Wichtung.
      $zerlegung[$i] = "" if $g > $opt_g || $w < 0;
    }

    $wort = join '', @zerlegung;
  }
  elsif ($opt_g < 0) {
    # Schritt 6.
    $wort =~ s/$marker+/-/g;
  }
  return $wort;
}

# Wenn Option »-U« gesetzt ist, müssen wir erkennen können, ob Wörter in
# Umschrift in der Wortliste existieren.  Wir benutzen dafür zwei Hashes.
my %wortliste;
my %wortliste_umschrift;

while (<<>>) {
  # Gebe Kommentarzeilen direkt aus, falls verlangt.
  if (/^ \s* \#/x) {
    print if $opt_x;
    next;
  }

  chop;

  # Isoliere Kommentare.
  s/(\# .*) $//x;

  my $kommentar = $1 // "";

  # Entferne Leerzeichen aller Art.
  s/\s+//g;

  # Speichere Komplettzeile der Wortliste zur späteren Übergabe ans
  # Lang-s-Transformationsskript.
  my $komplettzeile = $_;

  my @feld = split(';');
  next if $#feld < 1;

  # reformiert:           Felder 2, 4, 5, 7
  # traditionell:         Felder 2, 3, 5, 6
  # traditionell Schweiz: Felder 2, 3, 5, 6, 8
  #
  # Beachte: Feld n hat Index n-1.
  my $zeile = "";
  my $versal = 0; # wichtig für Lang-s-Skript
  $zeile = $feld[2] if defined $feld[2]
                       && $feld[2] ne "-3-" && ($opt_t || $opt_s);
  $zeile = $feld[3] if defined $feld[3]
                       && $feld[3] ne "-4-" && !($opt_t || $opt_s);
  if (!$zeile) {
    # Wir nehmen Versalformen nur dann, wenn es keine normalen Formen (in
    # Feld 2 oder 3) gibt.
    $zeile = $feld[4] if defined $feld[4]
                         && $feld[4] ne "-5-" && !$opt_v;
    $zeile = $feld[5] if defined $feld[5]
                         && $feld[5] ne "-6-" && ($opt_t || $opt_s) && !$opt_v;
    $zeile = $feld[6] if defined $feld[6]
                         && $feld[6] ne "-7-" && !($opt_t || $opt_s) && !$opt_v;
    $versal = 1 if $zeile;
  }

  $zeile = $feld[7] if defined $feld[7] && $opt_s;

  if (!$zeile) {
    $zeile = $feld[1];
  }

  next if $zeile eq "-2-";

  if (!$opt_x) {
    $zeile = markiere_trennstellen($zeile);
  }

  print "$zeile";
  print " " . $kommentar if $kommentar && $opt_x;
  print "\n";

  # Wenn die Option -L gewählt wurde, erzeugen wir die Schreibvariante
  # mit Lang-s durch das Python-Skript »s2long-s.py«.
  if ($opt_L && !$versal && index($zeile, "s") != -1) {
    my $lang_s_option = "de-1996";

    if ($opt_t || $opt_s) {
      $lang_s_option = "de-1901";
    }

    my $lang_s_wort = `echo '$komplettzeile' | skripte/spezialmuster/lang_s/s2long-s.py -k -l '$lang_s_option' - 2>/dev/null`;

    # Entferne Zeilenumbruch.
    $lang_s_wort =~ s/\n//;

    if (!$opt_x) {
      $lang_s_wort = markiere_trennstellen($lang_s_wort);
    }

    print "$lang_s_wort\n" if $lang_s_wort ne $zeile;
  }

  # Der Schlüssel im Hash ist das ungetrennte Wort, konvertiert zu
  # Kleinbuchstaben; Wert wird keiner gebraucht.
  $wortliste{lc($feld[0])} = ();

  if ($opt_U) {
    my $orig_zeile = $zeile;

    $zeile =~ tr[ÀàÁáÂâÃãÇçÈèÉéÊêËëÌìÍíÎîÏïÑñÒòÓóÔôÕõŠšÙùÚúÛûÝýŸÿŽž]
                [AaAaAaAaCcEeEeEeEeIiIiIiIiNnOoOoOoOoSsUuUuUuYyYyZz];

    $zeile =~ s/Ä/Ae/g;
    $zeile =~ s/ä/ae/g;
    $zeile =~ s/Å/Aa/g;
    $zeile =~ s/å/aa/g;
    $zeile =~ s/Æ/Ae/g;
    $zeile =~ s/æ/Ae/g;

    $zeile =~ s/Ö/Oe/g;
    $zeile =~ s/ö/oe/g;
    $zeile =~ s/Ø/Oe/g;
    $zeile =~ s/ø/oe/g;
    $zeile =~ s/Œ/Oe/g;
    $zeile =~ s/œ/oe/g;

    $zeile =~ s/Ü/Ue/g;
    $zeile =~ s/ü/ue/g;

    $wortliste_umschrift{lc($feld[0])} = $zeile if $orig_zeile ne $zeile;
  }
}

if ($opt_U) {
  # Wir geben nur Wörter aus, die nicht bereits in der originalen Wortliste
  # existieren.
  foreach my $wort (sort(keys %wortliste_umschrift)) {
    my $umschrift = $wortliste_umschrift{$wort};
    my $test = lc(entferne_marker($umschrift));

    print "$umschrift\n" if not exists ($wortliste{$test});
  }
}

# eof
