Turbo Toolbox/Turbo_Toolbox.iso/spezial/07/silben/silben2.pas

Pascal/Delphi Source File | 1989-03-02 | 12.6 KB | 434 lines

(* -------------------------------------------- *)
(*               SILBEN2.PAS                    *)
(* Fügt in eine Textdatei beliebige Zeichen-    *)
(* sequnzen als Trennstellen ein.               *)
(*    (C) 1989 Matthias Uphoff & TOOLBOX        *)
(* -------------------------------------------- *)

USES Crt, Turbo3;(* Für Turbo 3.0 auskommentieren *)

CONST MaxTS = 40;  (* Max. Anzahl registrierter *)
                   (* Trennungen pro Textzeile  *)

TYPE Str255 = STRING[255];
     Str80  = STRING[80];
     TSArray = ARRAY[1..MaxTS] OF INTEGER;

VAR Dateiname: Str80;
    Ausdateiname : Str80;
    TrennStr : Str80;


(* -------------------------------------------- *)
(* Ermittelt alle Silbentrennungen im String    *)
(* Zeile, gibt die Anzahl und  weiterhin eine   *)
(* Liste der Trennstellen Positionen der nach-  *)
(* folgenden Buchstaben ) zurück                *)
(* -------------------------------------------- *)

PROCEDURE SilbenTrennung(Zeile: Str255;
                         VAR Anzahl: INTEGER;
                         VAR Trennstelle: TSArray);

(* Wortfragmentlisten einbinden *)
(*$I FRAGMENT.INC *)

CONST Vokale: SET OF CHAR =
            ['A','E','I','O','U','Y','Ä','Ö','Ü'];
      Buchstaben: SET OF CHAR =
                       ['A'..'Z','Ä','Ö','Ü','ß'];

VAR p,   (* momentane Suchposition in der Zeile *)
    Laenge,
    (* Länge eines von der Funktion InListe     *)
    (* identifizierten Wortfragments            *)
    Startp,Endp,   (* Anfang u. Ende des *)
                   (* aktuellen Wortes   *)
    linksp:      INTEGER;
    Konsonanten: SET OF CHAR;
    getrennt:    BOOLEAN;
    (* zeigt an, ob im aktuellen Wort schon eine*)
    (* Trennstelle registriert wurde            *)


(* -------------------------------------------- *)
(* Zunächst einige lokale Prozeduren/Funktionen *)
(* -------------------------------------------- *)

(* Umwandlung in Großbuchstaben mit Umlauten *)

PROCEDURE UpperCase(VAR Zeile: Str255);
          VAR i: INTEGER;

BEGIN
   FOR i := 1 TO Length(Zeile) DO
      CASE Zeile[i] OF
        'a'..'z': Zeile[i]
                        := Chr(Ord(Zeile[i])-$20);
             'ä': Zeile[i] := 'Ä';
             'ö': Zeile[i] := 'Ö';
             'ü': Zeile[i] := 'Ü';
      END;
END;


(* Diese Funktion sucht das Wortfragment ab     *)
(* Zeilenposition p in der (untypisiert über-   *)
(* gebenen) Liste. Ist die Suche erfolgreich, so*)
(* wird true zurückgegeben, und die Variable    *)
(* Laenge  enthält  die Anzahl der übereinstim- *)
(* menden  Buchstaben.  Ansonsten  liefert  die *)
(* Funktion false, und Laenge enthält 0.        *)

FUNCTION InListe(VAR NoType; p: INTEGER): BOOLEAN;

VAR Liste: ARRAY[0..999] OF CHAR ABSOLUTE NoType;
               i,q: INTEGER;
             found: BOOLEAN;
BEGIN
   i := 0;
   q := p;
   found := FALSE;
   WHILE (Liste[i] <= Zeile[q])
         AND (NOT found) DO BEGIN
                    (* Test auf Übereinstimmung *)
      WHILE (Liste[i] = Zeile[q])
             AND (Liste[i] <> ' ') DO BEGIN
         i := i + 1; q := q + 1;
      END;
      IF Liste[i] = ' ' THEN(*Fragment gefunden *)
         found := TRUE
      ELSE BEGIN(* i auf nächsten Fragmentanfang*)
         REPEAT
            i := i + 1;
         UNTIL Liste[i] = ' ';
         i := i + 1;
         q := p;
      END;
   END;
   Laenge := q - p;
   InListe := found;
END;


(* Hier  wird  die  Position  einer Trennstelle *)
(* p registriert. Einbuchstabige Silben werden  *)
(* nicht erfaßt.                                *)

PROCEDURE Registriere(p: INTEGER);

BEGIN
   IF (p > Startp+1) AND (p < Endp-1)  THEN BEGIN
                      (* mehr als ein Buchstabe *)
      IF Anzahl < MaxTS THEN BEGIN
         Anzahl := Anzahl + 1;
         Trennstelle[Anzahl] := p;
      END;
      Startp := p; (* Neue Startposition merken *)
   END;
   getrennt := TRUE;
END;


(* Gibt true zurück, wenn in der Zeile ab       *)
(* Position p ein plausibler Silbenanfang       *)
(* vorliegt.                                    *)

FUNCTION Silben_Start(p: INTEGER): BOOLEAN;
BEGIN
  IF (Zeile[p] IN Vokale)
     OR (Zeile[p+1] IN Vokale)
        THEN Silben_Start := TRUE
  ELSE IF InListe(Konsonant_Beginn,p)
          AND (Zeile[p+Laenge] IN Vokale)
          AND (Zeile[p-1] <> 'C')
             THEN Silben_Start := TRUE
  ELSE Silben_Start := FALSE;
END;


(* Diese  Prozedur untersucht den Wortanfang ab *)
(* Zeilenposition  p. Falls eine Vorsilbe er-   *)
(* kannt wird, setzt sie p auf den Anfang der   *)
(* nächsten Silbe.                              *)

PROCEDURE Wortbeginn(VAR p: INTEGER);

(*Vorsilbe der Länge lng nur abtrennen, wenn ein*)
(*plausibler Silbenanfang folgt:                *)
     PROCEDURE Vor_Test(lng: INTEGER);
     BEGIN
        IF Silben_Start(p+lng) THEN BEGIN
           p := p + lng;
           Registriere(p);
        END;
     END;

BEGIN  (* Wortbeginn *)
   IF NOT InListe(Beginn_Ausnahmen,p) THEN BEGIN
      IF InListe(Vorsilben,p) THEN BEGIN
         Vor_Test(Laenge);
         IF InListe (Vorsilben,p) THEN
           Vor_Test(Laenge);
      END;
      IF InListe(Beginn_Spezial,p) AND
         (Zeile[p+Laenge] <> 'E') THEN
           Vor_Test(Laenge)
      ELSE IF InListe(Beginn_5,p) THEN
             Vor_Test(5)
      ELSE IF InListe(Beginn_4,p) THEN
             Vor_Test(4)
      ELSE IF InListe(Beginn_3,p) THEN
             Vor_Test(3)
      ELSE IF InListe(Beginn_2,p) THEN
             Vor_Test(2)
   END;
END;   (* Wortbeginn *)


(* Hier  werden  Trennstellen zwischen Vokalen *)
(* behandelt. linksp gibt die Position des     *)
(* ersten Vokals an, rechtsp die Position des  *)
(* nächsten Konsonanten                        *)

PROCEDURE Vokal_Vokal(linksp,rechtsp: INTEGER);

BEGIN
   IF rechtsp - linksp >= 2 THEN
      (* 2 oder mehr Vokale *)
      IF InListe(Vokal_Trenn,linksp)
         AND (Zeile[linksp-1] <> 'Q') THEN
         Registriere(linksp+1)
      ELSE IF rechtsp - linksp >= 3 THEN
              IF InListe(Diphthong,linksp) THEN
                 Registriere(linksp+2)
END;


(* Diese Prozedur ermittelt die Trennstelle bei *)
(* einem Konsonant-Vokal-Übergang. linksp gibt  *)
(* die Position des ersten  von eventuell       *)
(* mehreren Konsonanten an, rechtsp die Position*)
(* des nachfolgenden Vokals.                    *)

PROCEDURE Konsonant_Vokal(linksp: INTEGER);
        VAR p, rechtsp: INTEGER;

BEGIN

   (* Trennstellen-Intervall linksp..rechtsp *)
   (* ermitteln                              *)
   rechtsp := linksp;
   WHILE NOT Silben_Start(linksp) DO
     linksp := linksp + 1;
   IF InListe(Konsonant_Ende,rechtsp)
      THEN rechtsp := rechtsp + Laenge;

   IF linksp < rechtsp THEN BEGIN
   (* Weitere  Tests,  falls  die Trennstelle *)
   (* nicht eindeutig feststeht:              *)
      p := linksp;
      REPEAT
         IF InListe(Nachsilben,p)
            OR (getrennt
                AND InListe(Silben_Ende,p-4))
            OR InListe(Vokal_Silben,p)
               THEN linksp := p
         ELSE p := p + 1;
      UNTIL (p > rechtsp) OR (p = linksp)
   END;

   Registriere(linksp);

END; (* Konsonant_Vokal *)


(* -------------------------------------------- *)

BEGIN  (* der Prozedur Silbentrennung *)
   (* Konsonanten als Differenzmenge, *)
   (* erspart Tipparbeit:             *)
   Konsonanten := Buchstaben - Vokale;
   (* Zeile in Großbuchstaben wandeln:*)
   UpperCase(Zeile);
   (* Zeilenende mit Nicht-Buchstabe  *)
   (* kennzeichnen:                   *)
   Zeile[Length(Zeile)+1] := #0;
   Anzahl := 0;
   Endp := 1;

   REPEAT

      (* Hier  wird Startp auf den    *)
      (* Anfang und Endp hinter       *)
      (* das Ende des nächsten Wortes *)
      (* der Zeile gesetzt:           *)
      Startp := Endp;
      WHILE NOT (Zeile[Startp] IN Buchstaben)
            AND (Startp <= Length(Zeile)) DO
                Startp := Startp + 1;
      Endp := Startp;
      WHILE Zeile[Endp] IN Buchstaben DO
        Endp := Endp + 1;

      IF Endp - Startp >= 4 THEN BEGIN
         (* Wort lang genug, nach Sil-*)
         (* bentrennungen suchen      *)
         getrennt := FALSE;
         p := Startp;
         (* Wortanfang auf Vorsilben *)
         (* untersuchen:             *)
         Wortbeginn(p);
         (* Nächsten Vokal oder      *)
         (* Wortende suchen:         *)
         WHILE Zeile[p] IN Konsonanten DO
           p := p + 1;
         (* und jetzt weiter bis zum *)
         (* Wortende:                *)
         WHILE Zeile[p] IN Buchstaben DO BEGIN

         (* Nächsten Konsonant oder  *)
         (* Wortende suchen, Trenn-  *)
         (* stelle zwischen Vokalen  *)
         (* finden:                  *)
            linksp := p;
            WHILE Zeile[p] IN Vokale DO
              p := p + 1;
            Vokal_Vokal(linksp,p);

            (* Nächsten Vokal oder Wortende *)
            (* suchen, Trennstelle bei      *)
            (* Konsonant-Vokal-Übergang:    *)
            linksp := p;
            WHILE Zeile[p] IN Konsonanten DO
              p := p + 1;
            IF Zeile[p] IN Vokale THEN
               Konsonant_Vokal(linksp);

         END;  (* While *)
      END;   (* if *)

   UNTIL  Startp = Endp;
   (* bis kein Wort mehr vorhanden *)

END;  (* von Silbentrennung *)


(* -------------------------------------------- *)
(* Die folgenden Prozeduren zeigen die Anwendung*)
(* der Silbentrennung in Testroutinen           *)
(* -------------------------------------------- *)

(* Hier werden im String Zeile Trennstriche     *)
(* eingefügt und die  Anzahl  der Trennstellen  *)
(* zurückgegeben. Bei einer ck-Trennung wird das*)
(* c durch k ersetzt.                           *)

PROCEDURE Trennstriche(VAR Zeile: Str255;
                       VAR Anzahl: INTEGER);

          VAR i,j,k:       INTEGER;
              Trennstelle: TSArray;

BEGIN
  SilbenTrennung(Zeile,Anzahl,Trennstelle);
  k := 0;
  FOR i := 1 TO Anzahl DO BEGIN
      j := Trennstelle[i] + k;
      Insert(TrennStr,Zeile,j);
      IF (UpCase(Zeile[j-1]) = 'C')
         AND (UpCase(Zeile[j+1]) = 'K')
            THEN Zeile[j-1]
                      := Chr(Ord(Zeile[j-1])+8);
      k := k + 1;
  END;
END;



(* Ausgabe  einer  ASCII-Textdatei  auf  dem   *)
(* Drucker mit sämtlichen Silbentrennungen     *)

PROCEDURE DateiUmwandlung(Dateiname,
                          Ausdateiname: Str80);
        VAR Zeile:          Str255;
            AsciiFile:      TEXT;
            AusFile : TEXT;
            gesamt, Anzahl: INTEGER;

BEGIN
   Assign(AsciiFile,Dateiname);
   ReSet(AsciiFile);
   Assign(AusFile,Ausdateiname);
   ReWrite(AusFile);
   (* Schmalschrift ein *)
   gesamt := 0;

   WHILE NOT Eof(AsciiFile) DO BEGIN
      ReadLn(AsciiFile,Zeile);
      Trennstriche(Zeile,Anzahl);
      gesamt := gesamt + Anzahl;
      WriteLn(AusFile,Zeile);
   END;
   (* Schmalschrift aus *)
   WriteLn(gesamt,
           ' Silbentrennungen vorgenommen');
   Close(AsciiFile);
END;

PROCEDURE LiesTrennStr;
VAR ic, count, ErrorCode : INTEGER;
    c : CHAR;
    EinStr : STRING[40];


BEGIN
  TrennStr := '';
  WriteLn('>    Eingabe der Trennzeichensequenz     <');
  WriteLn('> ASCII-Codes mit führendem "#" eingeben <');
  WriteLn('>      oder normale Zeichen eingeben     <');
  WriteLn('>   Ende der Eingabe mit "leerem" RETURN <');
  WriteLn; WriteLn;
  count := 1;
  REPEAT
    Write('Zeichen ',count,':');
    ReadLn(EinStr);
    IF EinStr <> '' THEN BEGIN
      IF EinStr[1] = '#' THEN BEGIN
        EinStr := Copy(EinStr,2,Length(EinStr)-1);
        Val(EinStr,ic,ErrorCode);
        IF ErrorCode = 0 THEN BEGIN
          TrennStr := TrennStr + CHR(ic);

        END
        ELSE BEGIN
          WriteLn('>>>> Fehler bei ASCII-Werteingabe <<<<');
          WriteLn('>>>>     Eingabe wiederholen      <<<<');
          count := count - 1;
        END;
      END
      ELSE BEGIN
        TrennStr := TrennStr + EinStr[1];
      END;
    END;
    count := count + 1;
 UNTIL EinStr = '';
END;
(* ------------------- Main ------------------ *)

BEGIN
   WriteLn('--------------------------------');
   WriteLn('          SILBENTRENNER');
   WriteLn('  (C) 1989 TOOLBOX & M.Uphoff');
   WriteLn('--------------------------------');
   WriteLn; WriteLn; WriteLn;
   Write('Eingabe-Datei: ');
   ReadLn(Dateiname);
   Write('Ausgabe-Datei: ');
   ReadLn(Ausdateiname);
   LiesTrennStr;
   DateiUmwandlung(Dateiname,Ausdateiname);
END.

(* ------------------------------------------- *)