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       #    4   ===, <==, ==>
 151       #    ..
 152       #
 153       # Bei mehrfachem Auftreten von »<« hat das am meisten links stehende
 154       # den höchsten Rang.  Bei mehrfachem Auftreten von »>« hat das am
 155       # meisten rechts stehende den höchsten Rang.  Beispiel:
 156       #
 157       #   Mit<ver<ant-wort>lich>keit
 158       #      ^                 ^
 159       #
 160       # Das bezieht sich auch auf Ketten mit »=>« u.ä:
 161       #
 162       #   Ei-gen=wirt>schaft=>lich>keit
 163       #                           ^
 164
 165       my $g;
 166       my $m;
 167       my ($r, $r_vorher);
 168       my ($w, $w_vorher);
 169
 170       # Wir zerlegen mit `split' unter Beibehaltung der Begrenzer.
 171       my @zerlegung = split /([<>=-]+)/, $zeile;
 172
 173       # Wir speichern Wichtung und Rang als Felder.
 174       my @wichtung = (-2) x ($#zerlegung + 1);
 175       my @rang = (0) x ($#zerlegung + 1);
 176
 177       # Erster Durchgang: Ermittle Wichtungswerte.
 178
 179       # Wir starten bei erstem Marker (mit Index 1).
 180       foreach my $i (1 .. ($#zerlegung - 1)) {
 181         # Ignoriere Nicht-Marker.
 182         next if not $i % 2;
 183
 184         $m = $zerlegung[$i];
 185
 186         if ($m =~ /^-$/) {
 187           $w = -1;
 188         }
 189         elsif ($m =~ /^--$/) {
 190           $w = 0;
 191         }
 192         elsif ($m =~ /^[<>]$/) {
 193           $w = 1;
 194         }
 195         elsif ($m =~ /^=$/) {
 196           $w = 2;
 197         }
 198         elsif ($m =~ /( ==*>? | <?=*= )/x) {
 199           $w = length($1) + 1;
 200         }
 201         else {
 202           warn "Zeile $INPUT_LINE_NUMBER:"
 203                . " unbekannter Marker »$m« behandelt als »-«\n";
 204           $w = -1;
 205         }
 206
 207         $wichtung[$i] = $w;
 208       }
 209
 210       # Zweiter Durchgang: Adjustiere Wichtung von »<« und »>«.
 211
 212       # Behandle »<« von rechts nach links gehend.
 213       $w_vorher = -2;
 214       foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
 215         # Ignoriere Nicht-Marker.
 216         next if not $i % 2;
 217
 218         if (index ($zerlegung[$i], "<") >= 0) {
 219           # Hat der rechte Marker in einer Kette von »<« eine höhere
 220           # Wichtung, wird diese übernommen.
 221           $w = $wichtung[$i];
 222
 223           if ($w_vorher >= $w) {
 224             $wichtung[$i] = $w_vorher;
 225           }
 226           else {
 227             $w_vorher = $w;
 228           }
 229         }
 230         # »-«-Marker zwischen zwei »<« ändert nicht deren Wichtung.
 231         elsif ($zerlegung[$i] ne "-") {
 232           $w_vorher = -2;
 233         }
 234       }
 235
 236       # Behandle »>« von links nach rechts gehend.
 237       $w_vorher = -2;
 238       foreach my $i (1 .. ($#zerlegung - 1)) {
 239         # Ignoriere Nicht-Marker.
 240         next if not $i % 2;
 241
 242         if (index ($zerlegung[$i], ">") >= 0) {
 243           # Hat der linke Marker in einer Kette von »>« eine höhere
 244           # Wichtung, wird diese übernommen.
 245           $w = $wichtung[$i];
 246
 247           if ($w_vorher >= $w) {
 248             $wichtung[$i] = $w_vorher;
 249           }
 250           else {
 251             $w_vorher = $w;
 252           }
 253         }
 254         # »-«-Marker zwischen zwei »>« ändert nicht deren Wichtung.
 255         elsif ($zerlegung[$i] ne "-") {
 256           $w_vorher = -2;
 257         }
 258       }
 259
 260       # Dritter Durchgang: Ermittle Rang von »<« und »>«.
 261
 262       # Behandle »<« von links nach rechts gehend.
 263       $r = 0;
 264       foreach my $i (1 .. ($#zerlegung - 1)) {
 265         # Ignoriere Nicht-Marker.
 266         next if not $i % 2;
 267
 268         if (index ($zerlegung[$i], "<") >= 0) {
 269           $rang[$i] = $r--;
 270         }
 271         # »-«-Marker zwischen zwei »<« ändert nicht den Rang.
 272         elsif ($zerlegung[$i] ne "-") {
 273           $r = 0;
 274         }
 275       }
 276
 277       # Behandle »>« von rechts nach links gehend.
 278       $r = 0;
 279       foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
 280         # Ignoriere Nicht-Marker.
 281         next if not $i % 2;
 282
 283         if (index ($zerlegung[$i], ">") >= 0) {
 284           $rang[$i] = $r--;
 285         }
 286         # »-«-Marker zwischen zwei »>« ändert nicht den Rang.
 287         elsif ($zerlegung[$i] ne "-") {
 288           $r = 0;
 289         }
 290       }
 291
 292       # Sortiere Indexfeld für Marker mit absteigender Wichtung.
 293       my @wichtungsindices =
 294         sort {
 295           # Benutze Rang für Sekundärsortierung.
 296           if ($wichtung[$a] == $wichtung[$b]) {
 297             -($rang[$a] <=> $rang[$b]);
 298           }
 299           else {
 300             -($wichtung[$a] <=> $wichtung[$b]);
 301           }
 302         } (0 .. $#zerlegung);
 303
 304       # Entferne Trennstellen unter Berücksichtigung des Arguments von »-g«.
 305       $g = 0;
 306       $w_vorher = -2;
 307       $r_vorher = 0;
 308
 309       foreach my $i (@wichtungsindices) {
 310         # Alle Wortteile haben einen geraden Index und sind stets am Schluß
 311         # von @wichtungsindices.
 312         last if not $i % 2;
 313
 314         $w = $wichtung[$i];
 315         $r = $rang[$i];
 316
 317         if ($w_vorher == $w) {
 318           $g++ if $r_vorher != $r;
 319         }
 320         else {
 321           $g++;
 322         }
 323
 324         $w_vorher = $w;
 325         $r_vorher = $r;
 326
 327         # Entferne Trennung mit zu geringer Wichtung.
 328         $zerlegung[$i] = "" if $g > $opt_g || $w < 0;
 329       }
 330
 331       $zeile = join '', @zerlegung;
 332     }
 333     elsif ($opt_g < 0) {
 334       # Reduziere Trennstellenmarker zu »-«.
 335       $zeile =~ s/[·<>=-]+/-/g;
 336     }
 337   }
 338
 339   print "$zeile\n";
 340 }
 341
 342 # eof