skripte/extract-tex.pl

   1 #! /usr/bin/perl -w
   2 #
   3 # extract-tex.pl
   4 #
   5 # Dieses Perl-Skript extrahiert einfache Wortlisten aus der
   6 # »wortliste«-Datenbank im Langformat (oder ähnlichen Dateien mit gleichem
   7 # Dateiformat), die beispielsweise als Eingabedateien für »patgen« verwendet
   8 # werden können.
   9 #
  10 # Aufruf:
  11 #
  12 #   perl extract-tex.pl [Optionen...] [liste1 liste2 ...] > input.patgen
  13 #
  14 # Die Eingabedateien müssen in UTF-8 kodiert sein; ist keine Eingabedatei
  15 # angegeben, verwendet das Skript die Standardeingabe.  Beispiele:
  16 #
  17 #   perl extract-tex.pl -l < ../wortliste > wortliste.ref.latin9
  18 #   perl extract-tex.pl -t ../wortliste > wortliste.trad.utf8
  19 #
  20 # Die Aufrufe
  21 #
  22 #   perl extract-tex.pl -1 ...
  23 #   perl extract-tex.pl -t -1 ...
  24 #   perl extract-tex.pl -s -1 ...
  25 #
  26 # liefern jeweils die gleiche Ausgabe wie
  27 #
  28 #   sprachauszug.py -l de-1996-x-versal,de-1996 ...
  29 #   sprachauszug.py -l de-1901-x-versal,de-1901 ...
  30 #   sprachauszug.py -l de-CH-1901,de-1901 ...
  31 #
  32 #
  33 # Optionen
  34 # --------
  35 #
  36 # -t
  37 # -s  Option »-t« wählt die traditionelle deutsche Rechtschreibung aus,
  38 #     Option »-s« die traditionelle (deutsch)schweizerische Rechtschreibung.
  39 #     Wenn weder »-s« noch »-t« gesetzt ist, wird die reformierte deutsche
  40 #     Rechtschreibung ausgewählt.
  41 #
  42 # -x  Ignoriere Optionen »-g«, »-u« sowie »-1« und gib die
  43 #     sprachspezifischen Felder unbearbeitet aus (inklusive Kommentare).
  44 #
  45 # -g  Gib Wörter mit gewichteten Trennstellen aus.  Optional kann ein
  46 #     ganzzahliges Argument angegeben werden: Wert 0 gibt alle gewichtete
  47 #     Trennstellen aus inklusive »-« (das ist der Standardwert), Wert 1 nur
  48 #     die Trennstellen mit der höchsten Wichtung (ohne »-«), Wert 2 die
  49 #     Trennstellen mit der höchsten und zweithöchsten Wichtung (ohne »-«),
  50 #     usw.
  51 #
  52 #     Beachte, dass bei nahe beieinanderstehenden Trennstellen derzeit keine
  53 #     zusätzliche Wichtung vorgenommen wird.  Beispielsweise ist in dem Wort
  54 #
  55 #       ab<be<ru-fen
  56 #
  57 #     die Trennung »abbe-rufen« schlecht, weil ganz nahe der optimalen
  58 #     Trennstelle (nach »ab«).  Das Skript gibt trotzdem diese Trennstelle
  59 #     als zweitbeste aus.
  60 #
  61 # -u  Verhindere die Ausgabe von Wörtern mit Markern für unerwünschte
  62 #     Trennungen (z.B. »An<=al-.pha=bet«).  Wenn nicht gesetzt, werden als
  63 #     ungünstig markierte Trennstellen entfernt (z.B. »An<=alpha=bet«).
  64 #
  65 # -1  (Ziffer 1) Verhindere einbuchstabige Trennungen.  Ist die Option
  66 #     gesetzt, wird die erste dieser Trennungen unterdrückt, falls beide
  67 #     Trennstellen gleichwertig sind (z.B. »eu-ro-päi-sche« statt
  68 #     »eu-ro-pä-i-sche«), anderenfalls bleibt die stärkere erhalten (z.B.
  69 #     »päd<ago-gisch« statt »pä-d<a-go-gisch«).
  70 #
  71 # -v  Verhindere die Ausgabe von Versalformen, wo »ß« durch »ss« ersetzt
  72 #     ist.
  73 #
  74 # -l  (Kleinbuchstabe L) Konvertiere die Ausgabe von UTF-8 nach latin-9.
  75
  76 use strict;
  77 use warnings;
  78 use English '-no_match_vars';
  79 use utf8;                              # String-Literals direkt als UTF-8.
  80 use open qw(:std :utf8);
  81 use Getopt::Long qw(:config bundling);
  82
  83
  84 my ($opt_g, $opt_l, $opt_s, $opt_t, $opt_u, $opt_v, $opt_x, $opt_1);
  85 $opt_g = -1;
  86
  87 GetOptions("g:i" => \$opt_g,
  88            "l"   => \$opt_l,
  89            "s"   => \$opt_s,
  90            "t"   => \$opt_t,
  91            "u"   => \$opt_u,
  92            "v"   => \$opt_v,
  93            "x"   => \$opt_x,
  94            "1"   => \$opt_1);
  95
  96
  97 my $prog = $0;
  98 $prog =~ s@.*/@@;
  99
 100
 101 # Kodierung:
 102 binmode(STDOUT, ":encoding(iso-8859-15)") if $opt_l;
 103
 104
 105 # Zwei Konstanten für reguläre Ausdrücke, um die Lesbarkeit zu erhöhen.
 106 my $marker = qr/[.·<>=-]/x;
 107 my $buchstabe = qr/(?: [^.·<>=-] | ch)/x;
 108
 109
 110 sub entferne_marker {
 111   my $arg = shift;
 112   $arg =~ s/$marker//g;
 113   return $arg;
 114 }
 115
 116
 117 while (<>) {
 118   # Gebe Kommentarzeilen direkt aus, falls verlangt.
 119   if (/^ \s* \#/x) {
 120     print if $opt_x;
 121     next;
 122   }
 123
 124   next if /^#/;
 125   chop;
 126
 127   # Entferne Kommentare.
 128   s/(\# .*) $//x;
 129
 130   my $kommentar = $1 // "";
 131
 132   # Entferne Leerzeichen aller Art.
 133   s/\s+//g;
 134
 135   my @feld = split(';');
 136   next if $#feld < 1;
 137
 138   # reformiert:           Felder 2, 4, 5, 7
 139   # traditionell:         Felder 2, 3, 5, 6
 140   # traditionell Schweiz: Felder 2, 3, 5, 6, 8
 141   #
 142   # Beachte: Feld n hat Index n-1.
 143   my $zeile = "";
 144   $zeile = $feld[2] if defined $feld[2]
 145                        && $feld[2] ne "-3-" && ($opt_t || $opt_s);
 146   $zeile = $feld[3] if defined $feld[3]
 147                        && $feld[3] ne "-4-" && !($opt_t || $opt_s);
 148   if (!$zeile) {
 149     # Wir nehmen Versalformen nur dann, wenn es keine normalen Formen (in
 150     # Feld 2 oder 3) gibt.
 151     $zeile = $feld[4] if defined $feld[4]
 152                          && $feld[4] ne "-5-" && !$opt_v;
 153     $zeile = $feld[5] if defined $feld[5]
 154                          && $feld[5] ne "-6-" && ($opt_t || $opt_s) && !$opt_v;
 155     $zeile = $feld[6] if defined $feld[6]
 156                          && $feld[6] ne "-7-" && !($opt_t || $opt_s) && !$opt_v;
 157     $zeile = $feld[7] if defined $feld[7]
 158                          && $feld[7] ne "-8-" && $opt_s && !$opt_v;
 159   }
 160   if (!$zeile) {
 161     $zeile = $feld[1];
 162   }
 163
 164   next if $zeile eq "-2-";
 165
 166   if (!$opt_x) {
 167     # Entferne spezielle Trennungen.
 168     $zeile =~ s|\{ (.*?) / .*? \}|$1|gx;
 169
 170     # Entferne Doppeldeutigkeiten.
 171     $zeile =~ s|\[ (.*?) / .*? \]|entferne_marker($1)|egx;
 172
 173     # Ausgabe von Wörtern mit unerwünschten Trennungen?
 174     next if $zeile =~ /\./ and $opt_u;
 175
 176     # Entferne einbuchstabige Trennstellen, falls verlangt.
 177     #
 178     # * Die »stärkere« Gruppe von Markern gewinnt; z.B. werden sowohl
 179     #   »a-b.c« als auch »a<=b-c« zu »a-bc«.
 180     # * Bei Gleichwertigkeit gewinnt der rechte Marker, außer er ist als
 181     #   ungünstig markiert.  Daraus folgt, daß »a-b-c« zu »ab-c« wird,
 182     #   während »a-b-.c« sich zu »a-bc« auflöst.
 183     # * »ch« wird wie ein Buchstabe behandelt.
 184     if ($opt_1) {
 185       $zeile =~ s/[-.]+ (?= $buchstabe [<>=] [.·<>=]* )//gx;
 186       $zeile =~ s/[<>=] [.·<>=]* $buchstabe \K [-.]+//gx;
 187
 188       $zeile =~ s/-?\. ( $buchstabe - )/$1/gx;
 189       $zeile =~ s/( - $buchstabe ) -?\./$1/gx;
 190
 191       $zeile =~ s/- ( $buchstabe - )/$1/gx;
 192     }
 193
 194     # Entferne Markierungen für unerwünschte Trennungen (»-.«, »=..«, etc.).
 195     $zeile =~ s/[·<>=-]+ \.+//gx;
 196
 197     # Wir erlauben Trennung bei allen übrigen Schwankungsfällen.
 198     $zeile =~ s/\./-/gx;
 199
 200     # Entferne Gesangstrennstellen.
 201     # TODO: Ergänze Option für »Gesangstext-Trennmuster«
 202     $zeile =~ s/($buchstabe) [.·<>=-]* ·+ [.·<>=-]*/$1/gx;
 203
 204     if ($opt_g > 0) {
 205       # Berechne Wichtungen.  Wir verwenden folgende Werte:
 206       #
 207       #   -2   Wortteil
 208       #   -1   -
 209       #    0   --
 210       #    1   <, >
 211       #    2   =
 212       #    3   ==, <=, =>
 213       #    4   ===, <==, ==>
 214       #    ..
 215       #
 216       # Bei mehrfachem Auftreten von »<« hat das am meisten links stehende
 217       # den höchsten Rang.  Bei mehrfachem Auftreten von »>« hat das am
 218       # meisten rechts stehende den höchsten Rang.  Beispiel:
 219       #
 220       #   Mit<ver<ant-wort>lich>keit
 221       #      ^                 ^
 222       #
 223       # Das bezieht sich auch auf Ketten mit »=>« u.ä:
 224       #
 225       #   Ei-gen=wirt>schaft=>lich>keit
 226       #                           ^
 227
 228       my $g;
 229       my $m;
 230       my ($r, $r_vorher);
 231       my ($w, $w_vorher);
 232
 233       # Wir zerlegen mit `split' unter Beibehaltung der Begrenzer.
 234       my @zerlegung = split /([<>=-]+)/, $zeile;
 235
 236       # Wir speichern Wichtung und Rang als Felder.
 237       my @wichtung = (-2) x ($#zerlegung + 1);
 238       my @rang = (0) x ($#zerlegung + 1);
 239
 240       # Erster Durchgang: Ermittle Wichtungswerte.
 241
 242       # Wir starten bei erstem Marker (mit Index 1).
 243       foreach my $i (1 .. ($#zerlegung - 1)) {
 244         # Ignoriere Nicht-Marker.
 245         next if not $i % 2;
 246
 247         $m = $zerlegung[$i];
 248
 249         if ($m =~ /^-$/) {
 250           $w = -1;
 251         }
 252         elsif ($m =~ /^--$/) {
 253           $w = 0;
 254         }
 255         elsif ($m =~ /^[<>]$/) {
 256           $w = 1;
 257         }
 258         elsif ($m =~ /^=$/) {
 259           $w = 2;
 260         }
 261         elsif ($m =~ /( ==*>? | <?=*= )/x) {
 262           $w = length($1) + 1;
 263         }
 264         else {
 265           warn "Zeile $INPUT_LINE_NUMBER:"
 266                . " unbekannter Marker »$m« behandelt als »-«\n";
 267           $w = -1;
 268         }
 269
 270         $wichtung[$i] = $w;
 271       }
 272
 273       # Zweiter Durchgang: Adjustiere Wichtung von »<« und »>«.
 274
 275       # Behandle »<« von rechts nach links gehend.
 276       $w_vorher = -2;
 277       foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
 278         # Ignoriere Nicht-Marker.
 279         next if not $i % 2;
 280
 281         if (index ($zerlegung[$i], "<") >= 0) {
 282           # Hat der rechte Marker in einer Kette von »<« eine höhere
 283           # Wichtung, wird diese übernommen.
 284           $w = $wichtung[$i];
 285
 286           if ($w_vorher >= $w) {
 287             $wichtung[$i] = $w_vorher;
 288           }
 289           else {
 290             $w_vorher = $w;
 291           }
 292         }
 293         # »-«-Marker zwischen zwei »<« ändert nicht deren Wichtung.
 294         elsif ($zerlegung[$i] ne "-") {
 295           $w_vorher = -2;
 296         }
 297       }
 298
 299       # Behandle »>« von links nach rechts gehend.
 300       $w_vorher = -2;
 301       foreach my $i (1 .. ($#zerlegung - 1)) {
 302         # Ignoriere Nicht-Marker.
 303         next if not $i % 2;
 304
 305         if (index ($zerlegung[$i], ">") >= 0) {
 306           # Hat der linke Marker in einer Kette von »>« eine höhere
 307           # Wichtung, wird diese übernommen.
 308           $w = $wichtung[$i];
 309
 310           if ($w_vorher >= $w) {
 311             $wichtung[$i] = $w_vorher;
 312           }
 313           else {
 314             $w_vorher = $w;
 315           }
 316         }
 317         # »-«-Marker zwischen zwei »>« ändert nicht deren Wichtung.
 318         elsif ($zerlegung[$i] ne "-") {
 319           $w_vorher = -2;
 320         }
 321       }
 322
 323       # Dritter Durchgang: Ermittle Rang von »<« und »>«.
 324
 325       # Behandle »<« von links nach rechts gehend.
 326       $r = 0;
 327       foreach my $i (1 .. ($#zerlegung - 1)) {
 328         # Ignoriere Nicht-Marker.
 329         next if not $i % 2;
 330
 331         if (index ($zerlegung[$i], "<") >= 0) {
 332           $rang[$i] = $r--;
 333         }
 334         # »-«-Marker zwischen zwei »<« ändert nicht den Rang.
 335         elsif ($zerlegung[$i] ne "-") {
 336           $r = 0;
 337         }
 338       }
 339
 340       # Behandle »>« von rechts nach links gehend.
 341       $r = 0;
 342       foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
 343         # Ignoriere Nicht-Marker.
 344         next if not $i % 2;
 345
 346         if (index ($zerlegung[$i], ">") >= 0) {
 347           $rang[$i] = $r--;
 348         }
 349         # »-«-Marker zwischen zwei »>« ändert nicht den Rang.
 350         elsif ($zerlegung[$i] ne "-") {
 351           $r = 0;
 352         }
 353       }
 354
 355       # Sortiere Indexfeld für Marker mit absteigender Wichtung.
 356       my @wichtungsindices =
 357         sort {
 358           # Benutze Rang für Sekundärsortierung.
 359           if ($wichtung[$a] == $wichtung[$b]) {
 360             -($rang[$a] <=> $rang[$b]);
 361           }
 362           else {
 363             -($wichtung[$a] <=> $wichtung[$b]);
 364           }
 365         } (0 .. $#zerlegung);
 366
 367       # Entferne Trennstellen unter Berücksichtigung des Arguments von »-g«.
 368       $g = 0;
 369       $w_vorher = -2;
 370       $r_vorher = 0;
 371
 372       foreach my $i (@wichtungsindices) {
 373         # Alle Wortteile haben einen geraden Index und sind stets am Schluß
 374         # von @wichtungsindices.
 375         last if not $i % 2;
 376
 377         $w = $wichtung[$i];
 378         $r = $rang[$i];
 379
 380         if ($w_vorher == $w) {
 381           $g++ if $r_vorher != $r;
 382         }
 383         else {
 384           $g++;
 385         }
 386
 387         $w_vorher = $w;
 388         $r_vorher = $r;
 389
 390         # Entferne Trennung mit zu geringer Wichtung.
 391         $zerlegung[$i] = "" if $g > $opt_g || $w < 0;
 392       }
 393
 394       $zeile = join '', @zerlegung;
 395     }
 396     elsif ($opt_g < 0) {
 397       # Reduziere Trennstellenmarker zu »-«.
 398       $zeile =~ s/$marker+/-/g;
 399     }
 400   }
 401
 402   print "$zeile";
 403   print " " . $kommentar if $kommentar && $opt_x;
 404   print "\n";
 405 }
 406
 407 # eof