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«).  Diese Option wird nach der
  58 #     Behandlung von Ungünstigkeitsmarkern ausgeführt.
  59 #
  60 # -v  Verhindere die Ausgabe von Versalformen, wo »ß« durch »ss« ersetzt
  61 #     ist.
  62 #
  63 # -l  (Kleinbuchstabe L) Konvertiere die Ausgabe von UTF-8 nach latin-9 (wie
  64 #     von »patgen« benötigt).
  65
  66 use strict;
  67 use warnings;
  68 use English '-no_match_vars';
  69 use utf8;                              # String-Literals direkt als UTF-8.
  70 use open qw(:std :utf8);
  71 use Getopt::Long qw(:config bundling);
  72
  73
  74 my ($opt_g, $opt_l, $opt_s, $opt_t, $opt_u, $opt_v, $opt_x, $opt_1);
  75 $opt_g = -1;
  76
  77 GetOptions("g:i" => \$opt_g,
  78            "l"   => \$opt_l,
  79            "s"   => \$opt_s,
  80            "t"   => \$opt_t,
  81            "u"   => \$opt_u,
  82            "v"   => \$opt_v,
  83            "x"   => \$opt_x,
  84            "1"   => \$opt_1);
  85
  86
  87 my $prog = $0;
  88 $prog =~ s@.*/@@;
  89
  90
  91 # Kodierung:
  92 binmode(STDOUT, ":encoding(iso-8859-15)") if $opt_l;
  93
  94
  95 sub entferne_marker {
  96   my $arg = shift;
  97   $arg =~ s/[-=<>·]//g;
  98   return $arg;
  99 }
 100
 101
 102 while (<>) {
 103   # Gebe Kommentarzeilen direkt aus, falls verlangt.
 104   if (/^ \s* \#/x) {
 105     print if $opt_x;
 106     next;
 107   }
 108
 109   next if /^#/;
 110   chop;
 111
 112   # Entferne Kommentare.
 113   s/(\# .*) $//x;
 114
 115   my $kommentar = $1 // "";
 116
 117   # Entferne Leerzeichen aller Art.
 118   s/\s+//g;
 119
 120   my @feld = split(';');
 121   next if $#feld < 1;
 122
 123   # reformiert:           Felder 2, 4, 5, 7
 124   # traditionell:         Felder 2, 3, 5, 6
 125   # traditionell Schweiz: Felder 2, 3, 5, 6, 8
 126   #
 127   # Beachte: Feld n hat Index n-1.
 128   my $zeile = $feld[1];
 129   $zeile = $feld[2] if defined $feld[2]
 130                        && $feld[2] ne "-3-" && ($opt_t || $opt_s);
 131   $zeile = $feld[3] if defined $feld[3]
 132                        && $feld[3] ne "-4-" && !($opt_t || $opt_s);
 133   $zeile = $feld[4] if defined $feld[4]
 134                        && $feld[4] ne "-5-" && !$opt_v;
 135   $zeile = $feld[5] if defined $feld[5]
 136                        && $feld[5] ne "-6-" && ($opt_t || $opt_s) && !$opt_v;
 137   $zeile = $feld[6] if defined $feld[6]
 138                        && $feld[6] ne "-7-" && !($opt_t || $opt_s) && !$opt_v;
 139   $zeile = $feld[7] if defined $feld[7]
 140                        && $feld[7] ne "-8-" && $opt_s && !$opt_v;
 141
 142   next if $zeile eq "-2-";
 143
 144   if (!$opt_x) {
 145     # Entferne spezielle Trennungen.
 146     $zeile =~ s|\{ (.*?) / .*? \}|$1|gx;
 147
 148     # Entferne Doppeldeutigkeiten.
 149     $zeile =~ s|\[ (.*?) / .*? \]|entferne_marker($1)|egx;
 150
 151     # Ausgabe von Wörtern mit unerwünschten Trennungen?
 152     next if $zeile =~ /\./ and $opt_u;
 153
 154     # Entferne Markierungen für unerwünschte Trennungen.
 155     $zeile =~ s/[·<>=-]* \.+ [·<>=-]*//gx;
 156
 157     # Entferne einbuchstabige Trennstellen, falls verlangt.
 158     $zeile =~ s/- ([^·<>=-]) (?= [-<>=])/$1/gx if $opt_1;
 159     $zeile =~ s/([<>=] [^·<>=-]) -/$1/gx if $opt_1;
 160
 161     if ($opt_g > 0) {
 162       # Berechne Wichtungen.  Wir verwenden folgende Werte:
 163       #
 164       #   -2   Wortteil
 165       #   -1   -
 166       #    0   --
 167       #    1   <, >
 168       #    2   =
 169       #    3   ==, <=, =>
 170       #    4   ===, <==, ==>
 171       #    ..
 172       #
 173       # Bei mehrfachem Auftreten von »<« hat das am meisten links stehende
 174       # den höchsten Rang.  Bei mehrfachem Auftreten von »>« hat das am
 175       # meisten rechts stehende den höchsten Rang.  Beispiel:
 176       #
 177       #   Mit<ver<ant-wort>lich>keit
 178       #      ^                 ^
 179       #
 180       # Das bezieht sich auch auf Ketten mit »=>« u.ä:
 181       #
 182       #   Ei-gen=wirt>schaft=>lich>keit
 183       #                           ^
 184
 185       my $g;
 186       my $m;
 187       my ($r, $r_vorher);
 188       my ($w, $w_vorher);
 189
 190       # Wir zerlegen mit `split' unter Beibehaltung der Begrenzer.
 191       my @zerlegung = split /([<>=-]+)/, $zeile;
 192
 193       # Wir speichern Wichtung und Rang als Felder.
 194       my @wichtung = (-2) x ($#zerlegung + 1);
 195       my @rang = (0) x ($#zerlegung + 1);
 196
 197       # Erster Durchgang: Ermittle Wichtungswerte.
 198
 199       # Wir starten bei erstem Marker (mit Index 1).
 200       foreach my $i (1 .. ($#zerlegung - 1)) {
 201         # Ignoriere Nicht-Marker.
 202         next if not $i % 2;
 203
 204         $m = $zerlegung[$i];
 205
 206         if ($m =~ /^-$/) {
 207           $w = -1;
 208         }
 209         elsif ($m =~ /^--$/) {
 210           $w = 0;
 211         }
 212         elsif ($m =~ /^[<>]$/) {
 213           $w = 1;
 214         }
 215         elsif ($m =~ /^=$/) {
 216           $w = 2;
 217         }
 218         elsif ($m =~ /( ==*>? | <?=*= )/x) {
 219           $w = length($1) + 1;
 220         }
 221         else {
 222           warn "Zeile $INPUT_LINE_NUMBER:"
 223                . " unbekannter Marker »$m« behandelt als »-«\n";
 224           $w = -1;
 225         }
 226
 227         $wichtung[$i] = $w;
 228       }
 229
 230       # Zweiter Durchgang: Adjustiere Wichtung von »<« und »>«.
 231
 232       # Behandle »<« von rechts nach links gehend.
 233       $w_vorher = -2;
 234       foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
 235         # Ignoriere Nicht-Marker.
 236         next if not $i % 2;
 237
 238         if (index ($zerlegung[$i], "<") >= 0) {
 239           # Hat der rechte 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       # Behandle »>« von links nach rechts gehend.
 257       $w_vorher = -2;
 258       foreach my $i (1 .. ($#zerlegung - 1)) {
 259         # Ignoriere Nicht-Marker.
 260         next if not $i % 2;
 261
 262         if (index ($zerlegung[$i], ">") >= 0) {
 263           # Hat der linke Marker in einer Kette von »>« eine höhere
 264           # Wichtung, wird diese übernommen.
 265           $w = $wichtung[$i];
 266
 267           if ($w_vorher >= $w) {
 268             $wichtung[$i] = $w_vorher;
 269           }
 270           else {
 271             $w_vorher = $w;
 272           }
 273         }
 274         # »-«-Marker zwischen zwei »>« ändert nicht deren Wichtung.
 275         elsif ($zerlegung[$i] ne "-") {
 276           $w_vorher = -2;
 277         }
 278       }
 279
 280       # Dritter Durchgang: Ermittle Rang von »<« und »>«.
 281
 282       # Behandle »<« von links nach rechts gehend.
 283       $r = 0;
 284       foreach my $i (1 .. ($#zerlegung - 1)) {
 285         # Ignoriere Nicht-Marker.
 286         next if not $i % 2;
 287
 288         if (index ($zerlegung[$i], "<") >= 0) {
 289           $rang[$i] = $r--;
 290         }
 291         # »-«-Marker zwischen zwei »<« ändert nicht den Rang.
 292         elsif ($zerlegung[$i] ne "-") {
 293           $r = 0;
 294         }
 295       }
 296
 297       # Behandle »>« von rechts nach links gehend.
 298       $r = 0;
 299       foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
 300         # Ignoriere Nicht-Marker.
 301         next if not $i % 2;
 302
 303         if (index ($zerlegung[$i], ">") >= 0) {
 304           $rang[$i] = $r--;
 305         }
 306         # »-«-Marker zwischen zwei »>« ändert nicht den Rang.
 307         elsif ($zerlegung[$i] ne "-") {
 308           $r = 0;
 309         }
 310       }
 311
 312       # Sortiere Indexfeld für Marker mit absteigender Wichtung.
 313       my @wichtungsindices =
 314         sort {
 315           # Benutze Rang für Sekundärsortierung.
 316           if ($wichtung[$a] == $wichtung[$b]) {
 317             -($rang[$a] <=> $rang[$b]);
 318           }
 319           else {
 320             -($wichtung[$a] <=> $wichtung[$b]);
 321           }
 322         } (0 .. $#zerlegung);
 323
 324       # Entferne Trennstellen unter Berücksichtigung des Arguments von »-g«.
 325       $g = 0;
 326       $w_vorher = -2;
 327       $r_vorher = 0;
 328
 329       foreach my $i (@wichtungsindices) {
 330         # Alle Wortteile haben einen geraden Index und sind stets am Schluß
 331         # von @wichtungsindices.
 332         last if not $i % 2;
 333
 334         $w = $wichtung[$i];
 335         $r = $rang[$i];
 336
 337         if ($w_vorher == $w) {
 338           $g++ if $r_vorher != $r;
 339         }
 340         else {
 341           $g++;
 342         }
 343
 344         $w_vorher = $w;
 345         $r_vorher = $r;
 346
 347         # Entferne Trennung mit zu geringer Wichtung.
 348         $zerlegung[$i] = "" if $g > $opt_g || $w < 0;
 349       }
 350
 351       $zeile = join '', @zerlegung;
 352     }
 353     elsif ($opt_g < 0) {
 354       # Reduziere Trennstellenmarker zu »-«.
 355       $zeile =~ s/[·<>=-]+/-/g;
 356     }
 357   }
 358
 359   print "$zeile";
 360   print " " . $kommentar if $kommentar && $opt_x;
 361   print "\n";
 362 }
 363
 364 # eof