5 # Dieses Perl-Skript extrahiert einfache Wortlisten aus der
6 # »wortliste«-Datenbank, die beispielsweise als Eingabedateien für »patgen«
7 # verwendet werden können.
9 # Aufruf: perl extract-tex.pl [Optionen...] < wortliste > input.patgen
11 # Die »wortliste«-Datei muss in UTF-8 kodiert sein.
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.
22 # -x Ignoriere Optionen »-g« und »-u« und gebe die sprachspezifischen
23 # Felder unbearbeitet aus.
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.
32 # Beachte, dass bei nahe beieinanderstehenden Trennstellen derzeit keine
33 # zusätzliche Wichtung vorgenommen wird. Beispielsweise ist in dem Wort
37 # die Trennung »abbe-rufen« schlecht, weil ganz nahe der optimalen
38 # Trennstelle (nach »ab«). Das Skript gibt trotzdem diese Trennstelle
41 # -u Verhindere die Ausgabe von Wörtern mit Markern für unerwünschte
42 # Trennungen (z.B. »An-al.pha-bet«).
44 # -v Verhindere die Ausgabe von Versalformen, wo »ß« durch »ss« ersetzt
47 # -l Konvertiere die Ausgabe von UTF-8 nach latin-1 (wie von »patgen«
52 use English
'-no_match_vars';
53 use utf8
; # String-Literals direkt als UTF-8.
54 use Getopt
::Long
qw(:config bundling);
57 my ($opt_g, $opt_l, $opt_s, $opt_t, $opt_u, $opt_v, $opt_x);
60 GetOptions
("g:i" => \
$opt_g,
74 binmode(STDIN
, ":encoding(utf8)");
77 binmode(STDOUT
, ":encoding(latin1)");
80 binmode(STDOUT
, ":encoding(utf8)");
95 # Entferne Kommentare.
98 # Entferne Leerzeichen aller Art.
101 my @feld = split(';');
104 # reformiert: Felder 2, 4, 5, 7
105 # traditionell: Felder 2, 3, 5, 6
106 # traditionell Schweiz: Felder 2, 3, 5, 6, 8
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;
123 next if $zeile eq "-2-";
126 # Entferne spezielle Trennungen.
127 $zeile =~ s
|\
{ (.*?
) / .*? \
}|$1|gx
;
129 # Entferne Doppeldeutigkeiten.
130 $zeile =~ s
|\
[ (.*?
) / .*? \
]|entferne_marker
($1)|egx
;
132 # Ausgabe von Wörtern mit unerwünschten Trennungen?
133 next if $zeile =~ /\./ and $opt_u;
135 # Entferne Markierungen für unerwünschte Trennungen.
136 $zeile =~ s/[·<>=-]* \.+ [·<>=-]*//gx;
138 # Ausgabe von Wörtern mit ungewichteten Trennstellen?
139 next if $zeile =~ /·/ and $opt_g >= 0;
142 # Berechne Wichtungen. Wir verwenden folgende Werte:
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:
156 # Mit<ver<ant-wort>lich>keit
159 # Das bezieht sich auch auf Ketten mit »=>« u.ä:
161 # Ei-gen=wirt>schaft=>lich>keit
169 # Wir zerlegen mit `split' unter Beibehaltung der Begrenzer.
170 my @zerlegung = split /([<>=-]+)/, $zeile;
172 # Wir speichern Wichtung und Rang als Felder.
173 my @wichtung = (-2) x
($#zerlegung + 1);
174 my @rang = (0) x
($#zerlegung + 1);
176 # Erster Durchgang: Ermittle Wichtungswerte.
178 # Wir starten bei erstem Marker (mit Index 1).
179 foreach my $i (1 .. ($#zerlegung - 1)) {
180 # Ignoriere Nicht-Marker.
188 elsif ($m =~ /^[<>]$/) {
191 elsif ($m =~ /^=$/) {
194 elsif ($m =~ /( ==*>? | <?=*= )/x) {
198 warn "Zeile $INPUT_LINE_NUMBER:"
199 . " unbekannter Marker »$m« behandelt als »-«\n";
206 # Zweiter Durchgang: Adjustiere Wichtung von »<« und »>«.
208 # Behandle »<« von rechts nach links gehend.
210 foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
211 # Ignoriere Nicht-Marker.
214 if (index ($zerlegung[$i], "<") >= 0) {
215 # Hat der rechte Marker in einer Kette von »<« eine höhere
216 # Wichtung, wird diese übernommen.
219 if ($w_vorher >= $w) {
220 $wichtung[$i] = $w_vorher;
226 # »-«-Marker zwischen zwei »<« ändert nicht deren Wichtung.
227 elsif ($zerlegung[$i] ne "-") {
232 # Behandle »>« von links nach rechts gehend.
234 foreach my $i (1 .. ($#zerlegung - 1)) {
235 # Ignoriere Nicht-Marker.
238 if (index ($zerlegung[$i], ">") >= 0) {
239 # Hat der linke Marker in einer Kette von »>« eine höhere
240 # Wichtung, wird diese übernommen.
243 if ($w_vorher >= $w) {
244 $wichtung[$i] = $w_vorher;
250 # »-«-Marker zwischen zwei »>« ändert nicht deren Wichtung.
251 elsif ($zerlegung[$i] ne "-") {
256 # Dritter Durchgang: Ermittle Rang von »<« und »>«.
258 # Behandle »<« von links nach rechts gehend.
260 foreach my $i (1 .. ($#zerlegung - 1)) {
261 # Ignoriere Nicht-Marker.
264 if (index ($zerlegung[$i], "<") >= 0) {
267 # »-«-Marker zwischen zwei »<« ändert nicht den Rang.
268 elsif ($zerlegung[$i] ne "-") {
273 # Behandle »>« von rechts nach links gehend.
275 foreach my $i (reverse(1 .. ($#zerlegung - 1))) {
276 # Ignoriere Nicht-Marker.
279 if (index ($zerlegung[$i], ">") >= 0) {
282 # »-«-Marker zwischen zwei »>« ändert nicht den Rang.
283 elsif ($zerlegung[$i] ne "-") {
288 # Sortiere Indexfeld für Marker mit absteigender Wichtung.
289 my @wichtungsindices =
291 # Benutze Rang für Sekundärsortierung.
292 if ($wichtung[$a] == $wichtung[$b]) {
293 -($rang[$a] <=> $rang[$b]);
296 -($wichtung[$a] <=> $wichtung[$b]);
298 } (0 .. $#zerlegung);
300 # Entferne Trennstellen unter Berücksichtigung des Arguments von »-g«.
305 foreach my $i (@wichtungsindices) {
306 # Alle Wortteile haben einen geraden Index und sind stets am Schluß
307 # von @wichtungsindices.
313 if ($w_vorher == $w) {
314 $g++ if $r_vorher != $r;
323 # Entferne Trennung mit zu geringer Wichtung.
324 $zerlegung[$i] = "" if $g > $opt_g || $w < 0;
327 $zeile = join '', @zerlegung;
330 # Reduziere Trennstellenmarker zu »-«.
331 $zeile =~ s/[·<>=-]+/-/g;