Turbo Toolbox/Turbo_Toolbox.iso/sonderh1/strings.pas

Pascal/Delphi Source File | 1986-10-12 | 19.4 KB | 616 lines

(*---------------------------------------------------------------------------*)
(*                        Strings in Standard-Pascal
                         ----------------------------
  Implementation des String-Types als ein ARRAY [0..max] OF CHAR.
  Implementiert sind folgende Prozeduren/Funktionen:
    AssignStr, Length, ReadStr, ReadLnStr, WriteStr, WriteLnStr, Concat,
    Copy, Pos, Delete, Insert, Val, Str.
  Zur Fehlerbehandlung
  Bei allen werden ev. moegliche Laengenueberschreitungen abgefangen und
  fuehren zu keiner Fehlermeldung (z.B. Index-Bereich)

  String-Struktur: Index = 0 : n, Laenge des Strings (0<n<256)
                           1 : 1. Zeichen
                           .
                           .
                           n : n. Zeichen
                          n+1: ungenutzt
                           .
                           .
                          max: ungenutzt

  Folgende Deklarationen muessen im Haupt-Programm an entsprechender Stelle
  vorgenommen werden:                                                        *)


CONST
     (* max. moegliche Laenge des String-Types; ist den Beduerfnissen im
        Haupt-Programm entsprechend anzupassen (s. String-Struktur):     *)

      StMaxLen = 255;

     (* Laenge von Zeichenketten-Parametern (PACKED ARRAY OF CHAR) der
        Prozedur 'AssignStr'; ist ebenfalls entsprechend anzupassen.     *)

      StrParLen = 25;

     (* Schalter zur Unterdrueckung von Laufzeitfehlern bei der String-
        Verarbeitung. Ist 'StErrFg'=TRUE, werden Fehler unterdrueckt,
        in dem z.B. Zeichen abgeschnitten werden. Andernfalls muesste
        das Laufzeitsystem 'Index ausserhalb des zulaessigen Bereichs'
        melden. Der 'StErrFg' behandelnde Quell-Code kann, um z.B. weniger
        Objekt-Code zu erhalten, ganz entfallen (generelle Fehlermeldung)
        oder zur generellen Fehlerbehandlung modifiziert werden. Der je-
        weilige Code zur Fehlerbehandlung ist mit 'StErrBeg' und
        'StErrEnd' gekennzeichnet.                                       *)

     StErrFg = FALSE;

TYPE
     (* Der String-Typ:                   *)

     String = ARRAY [0..StMaxLen] OF CHAR;

     (* Der 'String-Parameter-Typ':       *)

     StrPar = PACKED ARRAY [1..StrParLen] OF CHAR;

(*---------------------------------------------------------------------------*)
(* Zuweisung von 'Num' Zeichen der Zeichenkette 'PAChar' an den String 'St'.
   'PAChar' darf hoechstens 'StrParLen' Zeichen enthalten. Enthaelt die zu-
   zuweisende Zeichenkette weniger Zeichen, muessen die restlichen Stellen
   bis 'StrParLen' aufgefuellt werden.
   Bsp.: Annahme: 'StrParLen = 8'
         'AssignStr(stvar,'Halloxxx',5)' weist der String-Variablen 'stvar'
         die Zeichenkette 'Hallo' zu.                                        *)

PROCEDURE AssignStr (VAR St: String; PAChar: StrPar; Num: INTEGER);

VAR i: INTEGER;

BEGIN
  (* StErrBeg *)
  IF StErrFg THEN
    IF Num > StMaxLen THEN                       (* Anzahl der zuzuweisenden *)
      Num := StMaxLen                            (* Zeichen korrigieren.     *)
    ELSE IF Num < 1 THEN
      Num := 1;
  (* StErrEnd *)
  FOR i := 1 TO Num DO
    St[i] := PAChar[i];
  St[0] := Chr(Num);
END;

(*---------------------------------------------------------------------------*)
(* Ermitteln der aktuellen Laenge des Strings 'St':                          *)

FUNCTION Length (VAR St: String): INTEGER;

BEGIN
  Length := Ord(St[0]);
END;

(*---------------------------------------------------------------------------*)
(* Zeichen aus der Datei 'InFile' lesen und dem String 'St' zuweisen. Dabei
   werden fuehrende Leerzeichen ueberlesen und die Zuweisung beendet, wenn
   wieder ein Leerzeichen oder Eingabeende auftritt.
   Bsp.: 'ReadStr(Input, stvar)' liest die Zeichenkette 'Hallo' in die
         Stringvar. 'stvar' bei folgender Eingabe:
                 Hallo Welt <CR>
         Ein zweites 'ReadStr' wuerde dann 'Welt' in 'stvar' einlesen.
   ACHTUNG:
   Als Editierfunktion fuer Tastatureingabe ist hier nur die Backspace-
   Taste vorgesehen. Der in der Konstanten 'bs' definierte Wert ist an den
   Code der entspr. Taste des benutzten Rechners anzupassen!                 *)

PROCEDURE ReadStr (VAR InFile: TEXT; VAR St: String);

CONST bs = 8;                (* ASCII-Code der Backspace-Taste, hier 8(dez.) *)

VAR ch: CHAR;
    i,
    StErrLen: INTEGER;                    (* Hilfsvar. fuer Fehlerbehandlung *)

BEGIN
  (* StErrBeg *)
  IF StErrFg THEN
    StErrLen := StMaxLen
  ELSE
    StErrLen := Succ(StMaxLen);
  (* StErrEnd *)
  i := 0;
  REPEAT
    Read(InFile, ch);
  UNTIL ch <> ' ';
  WHILE (NOT(Eoln(InFile))) AND (ch <> ' ')
  (* StErrBeg : je nach Modus ist 'StErrLen' passend zum Typ 'String' oder
                zu gross -> Fehlerabbruch                                    *)
  AND (i < StErrLen)
  (* StErrEnd *)
  DO
  BEGIN
    IF (Ord(ch) = bs) AND (i > 0) THEN
      i := Pred(i)
    ELSE
    BEGIN
      i := Succ(i);
      St[i] := ch;
    END;
    Read(InFile, ch);
  END;
  St[0] := Chr(i);
END;

(*---------------------------------------------------------------------------*)
(* Zeichen aus der Datei 'InFile' lesen und dem String 'St' zuweisen bis
   Eingabeende 'Eoln'. Es werden  a l l e  Zeichen in 'St' gespeichert bis
   auf Backspace und 'Eoln' (s. ReadStr).                                    *)

PROCEDURE ReadLnStr (VAR InFile: TEXT; VAR St: String);

CONST bs = 8;

VAR ch: CHAR;
    i,
    StErrLen : INTEGER;                                      (* s. 'ReadStr' *)

BEGIN
  (* StErrBeg *)
  IF StErrFg THEN
    StErrLen := StMaxLen
  ELSE
    StErrLen := Succ(StMaxLen);
  (* StErrEnd *)
  i := 0;
  Read(InFile, ch);
  WHILE NOT(Eoln(InFile))
  (* StErrBeg : s. 'ReadStr' *)
  AND (i < StErrLen)
  (* StErrEnd *)
  DO
  BEGIN
    IF (Ord(ch) = bs) AND (i > 0) THEN
      i := Pred(i)
    ELSE
    BEGIN
      i := Succ(i);
      St[i] := ch;
    END;
    Read(InFile, ch);
  END;
  St[0] := Chr(i);
END;

(*---------------------------------------------------------------------------*)
(* String 'St' in die Datei 'OutFile' ausgeben.                              *)

PROCEDURE WriteStr (VAR OutFile: TEXT; VAR St: String);

VAR i: INTEGER;

BEGIN
  FOR i := 1 TO Ord(St[0]) DO
    Write(OutFile, St[i])
END;

(*---------------------------------------------------------------------------*)
(* Wie WriteStr, jedoch mit CR/LF.                                           *)

PROCEDURE WriteLnStr (VAR OutFile: TEXT; VAR St: String);

BEGIN
  WriteStr(OutFile, St);
  WriteLn(OutFile);
END;

(*---------------------------------------------------------------------------*)
(* Den String 'St2' an den String 'St1' anhaengen und das Ergebnis in 'Dest'
   ausgeben.                                                                 *)

PROCEDURE Concat (VAR Dest, St1, St2: String);

VAR i, len1, geslen: INTEGER;

BEGIN
  len1 := Ord(St1[0]);
  geslen := len1+Ord(St2[0]);
  (* StErrBeg *)
  IF StErrFg AND (geslen > StMaxLen) THEN
    geslen := StMaxLen                                      (* Abschneiden ? *)
  ELSE IF NOT(StErrFg) AND (geslen > STMaxLen) THEN
    geslen := Succ(StMaxLen);
  (* StErrEnd *)
  Dest := St1;
  FOR i := Succ(len1) TO geslen DO
    Dest[i] := St2[i-len1];
  Dest[0] := Chr(geslen)
END;

(*---------------------------------------------------------------------------*)
(* Einen Teilstring aus 'St' ab der Position 'Pos' mit 'Num' Zeichen in den
   String 'Dest' kopieren. Ist 'Pos' groesser als die Laenge von 'St', ent-
   steht ein leerer Teilstring. Ist 'Num' zu gross, werden nur die in 'St'
   ab 'Pos' vorraetigen Zeichen kopiert!                                     *)

PROCEDURE Copy (VAR Dest, St: String; Pos, Num: integer);

VAR i, n, len: INTEGER;

BEGIN
  Dest[0] := Chr(0);
  len := Ord(St[0]);
  IF Pos <= len THEN
  BEGIN
    (* StErrBeg *)
    IF StErrFg AND (Pos < 1) THEN
      Pos := 1;
    (* StErrEnd *)
    Num := Pred(Num);
    IF Pos+Num > len THEN
      Num := len-Pos;
    i := 1;
    FOR n := Pos TO Pos+Num DO
    BEGIN
      Dest[i] := St[n];
      i := Succ(i);
    END;
    Dest[0] := Chr(Succ(Num));
  END;
END;

(*---------------------------------------------------------------------------*)
(* Der Teilstring 'Part' wird ab der Position 'Start' im String 'Main' ge-
   sucht. Wird er nicht in 'Main' gefunden, liefert die Funktion den Wert 0,
   sonst die Position des 1. Zeichens von 'Part', die der Teilstring in
   'Main' innehat.                                                           *)

FUNCTION Pos (Start: INTEGER; VAR Part, Main: String): INTEGER;

VAR p, lenp, lenm, stop: INTEGER;
    found: BOOLEAN;

BEGIN
  found := FALSE;
  Pos := 0;
  lenm := Ord(Main[0]);
  lenp := Ord(Part[0]);
  (* StErrBeg *)
  IF StErrFg THEN
    IF Start < 1 THEN
      Start := 1
    ELSE IF Start > StMaxLen THEN
      Start := StMaxLen;
  (* StErrEnd *)
  stop := Succ(lenm-lenp);
  IF Start <= stop THEN
    REPEAT
      p := 1;
      WHILE (p <= lenp) AND (Part[p] = Main[Pred(Start+p)]) DO
        p := Succ(p);
      IF p < lenp THEN
        Start := Succ(Start)
      ELSE
        found := TRUE;
    UNTIL (Start > stop) OR found;
  IF found THEN
    Pos := Start;
END;

(*---------------------------------------------------------------------------*)
(* Aus dem String 'St' ab der Position 'Pos' 'Num' zeichen loeschen. Die Zei-
   chen hinter 'Pos'+'Num'-1 ruecken auf, falls vorhanden.                   *)

PROCEDURE Delete (VAR St: String; Pos, Num: INTEGER);

VAR i, len: INTEGER;

BEGIN
  (* StErrBeg *)
  IF StErrFg THEN
    IF Pos > StMaxLen THEN
      Pos := StMaxLen
    ELSE IF Pos < 1 THEN
      Pos := 1;
  (* StErrEnd *)
  len := Ord(St[0]);
  IF Pos <= len THEN
  BEGIN
    IF Pred(Pos+Num) > len THEN
      Num := Succ(len-Pos);
    FOR i := Pos+Num TO len DO
      St[i-Num] := St[i];
    St[0] := Chr(len-Num);
  END;
END;

(*---------------------------------------------------------------------------*)
(* Den String 'St' an Position 'Pos' in den String 'Dest' einfuegen. Ist
   'Pos' groesser als Length(Dest), wird 'St' angefuegt. Ist die neue Laenge
   groesser als 'StMaxLen', werden die ueberzaehligen Zeichen abgeschnitten. *)

PROCEDURE Insert (St: String; VAR Dest: String; Pos: INTEGER);

VAR rest: String;
     len: INTEGER;

BEGIN
  (* StErrBeg *)
  IF StErrFg THEN
    IF Pos < 1 THEN
      Pos := 1
    ELSE IF Pos > StMaxLen THEN
      Pos := StMaxLen;
  (* StErrEnd *)
  len := Ord(Dest[0]);
  IF Pos > len THEN
    Pos := Succ(len);
  Copy(rest, Dest, Pos, Succ(len-Pos));
  Delete(Dest, Pos, len);
  FOR len := 1 TO 2 DO
  BEGIN
    IF Ord(Dest[0])+Ord(St[0]) > StMaxLen THEN
      St[0] := Chr(StMaxLen-Ord(Dest[0]));
    Concat(Dest, Dest, St);
    St := rest;
  END;
END;

(*---------------------------------------------------------------------------*)
(* Den String 'St' in den REAL-Wert 'Rvar' umwandeln. Dabei werden fuehrende
   Leerzeichen ueberlesen, die Umwandlung beim Auftreten eines nicht zur Zahl
   gehoerenden Zeichens abgebrochen. Konnte keine Zahl erkannt werden, wird
   in 'Code' die Position in 'St' zurueckgegeben, an der die Umwandlung abge-
   brochen wurde und 'Rvar' ist undefiniert. Andernfalls erhaelt 'Code' den
   Wert 0 und 'Rvar' den entspr. REAL-Wert.
   Bsp.: '  1.5'=1.5  '-.3333'=-0.3333  ' +1E10'=1.0E10  ' 2.1e-4'=2.1E-4
         ' 40xy'=40.0 ' a123 '=???????  '10+300'=10.0                        *)

PROCEDURE Val (VAR St: String; VAR Rvar: REAL; VAR Code: INTEGER);

VAR p, len, eval: INTEGER;
    mval, ds    : REAL;
    neg         : BOOLEAN;

  (* Ganzzahlige Zeichenkette in REAL-Wert wandeln.                          *)
  FUNCTION IntVal : REAL;

  VAR ival : REAL;

  BEGIN
    ival := 0;
    neg := FALSE;
    IF (St[p] IN ['+','-']) AND (p <= len) THEN
    BEGIN
      neg := St[p] = '-';                                       (* negativ ? *)
      p := Succ(p);
    END;
    WHILE (St[p] IN ['0'..'9']) AND (p <= len) DO
    BEGIN
      ival := ival*10+Ord(St[p])-Ord('0');
      p := Succ(p);
    END;
    IntVal := ival;
  END;


BEGIN
  Code := 1;
  IF Ord(St[0]) > 0 THEN
  BEGIN
    len := Ord(St[0]);
    p := 1;
    WHILE (St[p] = ' ') AND (p <= len) DO         (* Leerzeichen ueberlesen. *)
      p := Succ (p);
    IF St[p] IN ['0'..'9','+','-','.'] THEN
    BEGIN
      Code := 0;
      mval := IntVal;                      (* ganzzahligen Anteil umwandeln. *)
      IF (St[p] = '.') AND (p <= len) THEN        (* Dezimalteil vorhanden ? *)
      BEGIN
        p := Succ(p);
        ds := 10;
        WHILE (St[p] IN ['0'..'9']) AND (p <= len) DO
        BEGIN
          mval := mval+(Ord(St[p])-Ord('0'))/ds;
          ds := ds*10;
          p := Succ(p);
        END;
      END;
      IF neg THEN
        mval := -mval;
      IF (St[p] IN ['E','e']) AND (p <= len) THEN
      BEGIN
        p := Succ(p);
        eval := TRUNC(IntVal);
        IF neg THEN
          FOR p := 1 TO eval DO        (* Iteration: Grund s. Str-Funktion ! *)
            mval := mval/10
        ELSE
          FOR p := 1 TO eval DO
            mval := mval*10;
      END;
    END
    ELSE
      Code := p;
  END;
  Rvar := mval;
END;

(*---------------------------------------------------------------------------*)
(* Den numerischen Wert 'Value' in den String 'St' umwandeln.
   'n' gibt die Anzahl der 'Zeichenstellen' an, die die Zahl als String haben
   soll. Ist 'n'=0 wird die Exponential-Darstellung gewaehlt und 'AnzSig'
   Mantissenstellen ausgegeben ('AnzSig '= Mantissenstellen der Implementa-
   tion - 1). 'm' gibt bei 'n'<>0 die Anzahl der Nachkommastellen an (s.a.
   Write).                                                                   *)

PROCEDURE Str (Value: REAL; n, m: INTEGER; VAR St: String);

CONST AnzSig = 10;                              (* sig. Mantissenstellen - 1 *)
      Fehler = 1.0E-10;     (* Fehlergrenze fuer Vergleiche und Korrektur bei
                               Subtraktion.                                  *)

VAR p, exex, tmp: INTEGER;
    ex: REAL;                   (* muss REAL sein, wg. Aufruf von 'StrPart'. *)

  (* Fuer die Normalisierung auf eine Vorkommastelle wurde folg. iteratives
     Verfahren gewaehlt, da 'ex:=Trunc(ln(Value)/ln(10))' und 'Value:=
     Value/Exp(ex*ln(10))' bei der zum Test verwendeten Implementation, die
     n i c h t  mit BCD-Arithmetik arbeitet, zu Fehlern fuehrte!
     (z.B. bei Value=100)                                                    *)

  FUNCTION exponent (VAR Value: REAL): INTEGER;

  VAR mp: REAL;
      ex: INTEGER;

  BEGIN
    ex := 0;
    IF Value <> 0.0 THEN
      WHILE Value+Fehler < 1.0 DO
      BEGIN
        Value := Value*10.0;
        ex := Pred(ex);
      END;
    WHILE Value >= 10.0 DO
    BEGIN
      Value := Value/10.0;
      ex := Succ(ex);
    END;
    exponent := ex;
  END;

  (* Auch lieferte die 'Trunc'-Funktion in bestimmten Faellen ein falsches
     Ergebnis, so dass die Vorkommastelle auf folgende, umstaendlich er-
     scheinende, aber funktionierente Weise ermittelt wird.                  *)

  Function MyTrunc (Value: REAL): INTEGER;

  BEGIN
    IF Value+Fehler < 1.0 THEN
      MyTrunc := 0
    ELSE IF Value+Fehler < 2.0 THEN
      MyTrunc := 1
    ELSE IF Value+Fehler < 3.0 THEN
      MyTrunc := 2
    ELSE IF Value+Fehler < 4.0 THEN
      MyTrunc := 3
    ELSE IF Value+Fehler < 5.0 THEN
      MyTrunc := 4
    ELSE IF Value+Fehler < 6.0 THEN
      MyTrunc := 5
    ELSE IF Value+Fehler < 7.0 THEN
      MyTrunc := 6
    ELSE IF Value+Fehler < 8.0 THEN
      MyTrunc := 7
    ELSE IF Value+Fehler < 9.0 THEN
      MyTrunc := 8
    ELSE IF Value+Fehler < 10.0 THEN
      MyTrunc := 9;
  END;

  (* Hier werden 'digits' Stellen des REAL-Wertes in eine Zeichenkette umge-
     wandelt! Da die Subtraktion die 'gefaehrlichste' numerische Operation
     ist, musste - um Fehler zu vermeiden - auch hier eine Vorsichtsmass-
     nahme her (s.u.)                                                        *)

  PROCEDURE StrPart (VAR Value: REAL; digits: INTEGER; VAR St: String);

  VAR i, j, ch: INTEGER;
      tmpval: REAL;

  BEGIN
    FOR i := 1 TO digits DO
    BEGIN
      ch := MyTrunc(Value);
      St[p] := Chr(ch+Ord('0'));
      p := Succ(p);
      Value := Value-ch+Fehler*0.1;                         (* VORSICHT !!!! *)
      Value := Value*10;
    END;
  END;


BEGIN
  p := 1;
  IF Value < 0 THEN                                        (* Wert negativ ? *)
  BEGIN
    St[1] := '-';
    p := Succ(p);
  END;
  Value := Abs(Value);
  ex := exponent(Value);                            (* Wert 'normalisieren'. *)
  IF n <> 0 THEN                  (* keine Exponential-Darstellung, ist dass *)
  BEGIN                           (*  mit angegebener Stellenzahl moeglich ? *)
    tmp := Succ(Trunc(ex));     (* Wieviel Vorkommastellen sind auszugeben ? *)
    IF St[1] = '-' THEN              (* Vorzeichen bei neg. Zahlen beruecks. *)
      tmp := Succ(tmp);
    IF m <> 0 THEN                         (* Nachkommastellen gewuenscht,   *)
      tmp := Succ(tmp);                    (* Dezimalpunkt beruecksichtigen. *)
    IF tmp > n-m THEN              (* passt nicht, Exp.-Darstellung nehmen ! *)
      n := 0;
  END;
  IF n = 0 THEN                     (* Exponential-Darstellung ist gewaehlt! *)
  BEGIN
    StrPart(Value,1,St);                        (* Vorkommastelle umwandeln. *)
    St[p] := '.';
    p := Succ(p);
    StrPart(Value,AnzSig,St);       (* soviel Nachkommastellen, wie Implemen-
                                       tation erlaubt, umwandeln.            *)
    IF ex <> 0 THEN                                 (* Exponent darstellen ? *)
    BEGIN
      St[p] := 'E';
      p := succ(p);
      IF ex < 0 THEN                                   (* Exponent negativ ? *)
      BEGIN
        St[p] := '-';
        p := Succ(p);
      END;
      ex := Abs(ex);
      exex := exponent(ex);                      (* Exponent 'normalisieren' *)
      StrPart(ex,Succ(exex),St);                 (* und umwandeln.           *)
    END;
  END
  ELSE                           (* Umwandlung in Vor- und Nachkommastellen! *)
  BEGIN
    StrPart(Value,Succ(Trunc(ex)),St);         (* Vorkommastellen umwandeln. *)
    IF m > 0 THEN                                      (* Nachkommastellen ? *)
    BEGIN
      St[p] := '.';
      p := Succ(p);
      StrPart(Value,m,St);
    END;
  END;
  St[0] := Chr(Pred(p));
END;

(*---------------------------------------------------------------------------*)
(* Den String 'St1' mit dem String 'St2' vergleichen. Ist 'St1' kleiner als
   'St2', ist das Ergebnis -1. Ist 'St1' groesser 'St2', ist das Ergebnis 1.
   Sind beide gleich, wird der Wert 0 geliefert.                             *)

FUNCTION Compare(Var St1, St2 : String): integer;

VAR i: INTEGER;

BEGIN
  IF St1[0] < St2[0] THEN
    Compare := -1
  ELSE IF St1[0] > St2[0] THEN
    Compare := +1
  ELSE
  BEGIN
    i := 1;
    WHILE (St1[i] = St2[i]) AND (i <= Ord(St1[0])) DO
      i := Succ(i);
    IF i > Ord(St1[0]) THEN
      Compare := 0
    ELSE IF St1[i] < St2[i] THEN
      Compare := -1
    ELSE
      Compare := +1;
  END;
END;

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