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