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