Turbo Toolbox/Turbo_Toolbox.iso/spezial/05/pascal/strukto2.pas

Pascal/Delphi Source File | 1989-01-02 | 14.5 KB | 418 lines

(*----------------------------------------------------------------------*)
(*                       STRUKTO2.PAS                                   *)
(*          Struktogrammerzeugung, Interpretation von Struktur-Dateien  *)

procedure Zeichne_Strich (Rand : Text110; Form : Ort);
var  i : integer;

   procedure Einbauen (vorn, hinten : char);
   begin
     Strichrand [1]                   := vorn;
     Strichrand [length (Strichrand)] := hinten;
   end;    (* Einbauen *)

begin
  if TEO_Status = aktiv
    then if TEO_Erste
           then begin
                  TEO_Erste := false;
                  Form      := T_unten;
                end
           else Form := centrum;
  if Beginn_Neu = Zeile1
    then begin
           Form       := erste;
           Beginn_Neu := Zeile2;
         end
    else if Beginn_Neu = Zeile2
           then begin
                  Form       := oben;
                  Beginn_Neu := nein;
                end;
  if While_offen
    then begin
           Form        := oben;
           While_offen := false;
         end;
  case Form of
       oben    :  Einbauen (Obenlinks, Kreuzrechts);
       erste   :  Einbauen (Obenlinks, Obenrechts);
       mitte   :  Einbauen (Kreuzlinks, Kreuzrechts);
       unten   :  Einbauen (Untenlinks, Kreuzrechts);
       letzte  :  Einbauen (Untenlinks, Untenrechts);
       T_unten :  Einbauen (Kreuzoben, Kreuzrechts);
       centrum :  Einbauen (Kreuz, Kreuzrechts);
  end;
  writeln (Destination, ' ' : Links, Rand, Strichrand);
  if TEO_Status = aktiv
    then begin
           TEO_Status := ausdrucken;
           Textrand   := copy (Textrand, 1, length (Textrand)
                                         - length (Verbleib)) + Verbleib;
         end;
  while Repeat_offen > 0 do
  begin
    Textrand     := Textrand + Strich_Blank;
    Repeat_offen := Repeat_offen - 2;
  end;
  Strichrand := copy (Strich, 1, Akt_Laenge + 2);
end;    (* Zeichne_Strich *)

procedure Update_Var (Sign : char);
var Differenz  :  integer;
begin
  if Schleife^.Last = nil
    then Fehler_Meldung (Zeile, 104)
    else begin
           Schleife := Schleife^.Last;
           with Schleife^ do
             if Zeichen = Sign
               then begin
                      Differenz  := Laenge - Akt_Laenge;
                      Akt_Laenge := Laenge;
                      Textrand   := copy (Textrand, 1,
                                           length (Textrand) - Differenz);
                      Strichrand := copy (Strich, 1, Differenz) + Strichrand;
                    end
               else Fehler_Meldung (Zeile, 105);
           case Sign of
                'W'  :  Strichrand [ 3] := Kreuzunten;
                'I'  :  Strichrand [ 8] := Kreuzunten;
                'C'  :  Strichrand [14] := Kreuzunten;
           end;
         end;
end;    (* Update_Var *)

procedure Text_Ausgabe (Ausgabe, Druckzeile : Text110; Beginn, Laenge : integer;
                        Form : Ort; Linie, Zentrieren, UProg : boolean);
var  Anzahl              : real;
     Zahl, Position      : integer;
     Druckzeile_Zwischen : Text110;

   procedure Aufteilen (var Rest, Original : Text110);
   var Zaehl  : integer;
   begin
     Original := '';
     Zaehl    := pos (' ', Rest);
     while (length (Original) + Zaehl < Laenge - 2) and (Zaehl > 0) do
     begin
       Original := Original + copy (Rest, 1, Zaehl);
       Rest     := copy (Rest, Zaehl + 1, 255);
       Zaehl    := pos (' ', Rest);
     end;
     if (length (Rest) > 0) and (length (Original) = 0)
      then begin
             Zaehl  := Laenge - 4;
             if Zaehl >= 0
               then begin
                      Original := Original + copy (Rest, 1, Zaehl);
                      Rest     := copy (Rest, Zaehl + 1, 255);
                    end;
           end;
   end;    (* Aufteilen *)

begin    (* Textausgabe *)
  if length (Ausgabe) < 1
    then begin
           Fehler_Meldung (Zeile, 107);
           Ausgabe := ' ';
         end;
  Druckzeile_zwischen := Druckzeile;
  Rest                := Ausgabe;
  if UProg
    then begin
           Position := length (Strichrand) - 5;
           Zahl     := 7 + Repeat_offen;
           if Strichrand [Zahl] = Waagerecht
             then Strichrand [Zahl]     := Kreuzoben
             else Strichrand [Zahl]     := Kreuz;
           if Strichrand [Position] = Waagerecht
             then Strichrand [Position] := Kreuzoben
             else Strichrand [Position] := Kreuz;
           Laenge := Laenge - 12;
         end;
   Position := Position - Repeat_offen;
   if Linie
     then Zeichne_Strich (Textrand, Form);
   repeat
     Druckzeile := Druckzeile_Zwischen;
     if length (Rest) > Laenge - 2
       then Aufteilen (Rest, Ausgabe)
       else begin
              Ausgabe := Rest;
              Rest    := '';
            end;
     Zahl   := length (Ausgabe);
     if Zahl = 0
       then begin
              Ausgabe := Rest;
              Rest    := '';
              Zahl    := length (Ausgabe);
              if Zahl > 0
                then Fehler_Meldung (Zeile, 106);
            end;
     insert (Ausgabe, Druckzeile, Beginn);
     if Zentrieren
       then begin
              Anzahl := (Breite - length (Druckzeile) -
                                            length (Textrand)) / 2 + 1;
              if Anzahl > 0
                then begin
                       insert (copy (Blank, 1, round (Anzahl)), Druckzeile,
                                                                Beginn);
                       insert (copy (Blank, 1, trunc (Anzahl)), Druckzeile,
                                          round (Anzahl) + Beginn + Zahl);
                     end;
            end
       else begin
              Anzahl := Breite - length (Druckzeile) - length (Textrand) + 2;
              if Anzahl > 0
                then insert (copy (Blank, 1, trunc (Anzahl)), Druckzeile,
                                               Beginn + Zahl);
            end;
     if Anzahl <= 0
       then Fehler_Meldung (Zeile, 108);
     if UProg
       then begin
              Anzahl                      := length (Druckzeile) - 5;
              if Anzahl - 7 <= Zahl
                then Fehler_Meldung (Zeile, 106);
              Druckzeile [7]              := Senkrecht;
              Druckzeile [trunc (Anzahl)] := Senkrecht;
            end;
     writeln (Destination, ' ' : Links, Textrand, Druckzeile);
     if TEO_Status = ausdrucken
       then begin
              Zahl       := pos (Verbleib, Textrand);
              delete (Textrand, Zahl, length (Verbleib));
              insert (copy (Blank, 1, length (Verbleib)), Textrand, Zahl);
              TEO_Status := passiv;
            end;
     Zentrieren := true;
     Linie      := false;
   until length (Rest) = 0;
   if UProg
     then begin
            Strichrand [7]        := Kreuzunten;
            Strichrand [Position] := Kreuzunten;
          end;
end;    (* Textausgabe *)

procedure Ablegen (Sign : char; Anzahl : integer);
var  Zwischen : Schleifenpointer;
begin
  Zwischen := Schleife;
  with Schleife^ do
  begin
    Zeichen := Sign;
    Laenge  := Anzahl;
  end;
  new (Schleife);
  Schleife^.Last := Zwischen;
end;    (* Ablegen *)

procedure Name_Schreiben (Bezeichnung : Text110);
begin
  Zeichne_Strich (Textrand, erste);
  Beginn_Neu := Zeile2;
  Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht, 3, Akt_Laenge,
                                                erste, false, false, false);
  Ablegen ('P', Akt_Laenge);
  Textrand   := Strich_Blank;
  Akt_Laenge := Akt_Laenge - 2;
  delete (Strichrand, 1, 2);
end;    (* Name_Schreiben *)

procedure While_auf (Satz : Text110);
begin
  Text_Ausgabe (Satz, Strich_Blank + Senkrecht, 3, Akt_Laenge,
                                           mitte, true, false, false);
  Ablegen ('W', Akt_Laenge);
  Textrand    := Textrand + Strich_Blank;
  Akt_Laenge  := Akt_Laenge - 2;
  delete (Strichrand, 1, 2);
  While_offen := true;
end;    (* While_auf *)

procedure Repeat_auf;
begin
  Repeat_offen := Repeat_offen  + 2;
  if Strichrand [1 + Repeat_offen] = Waagerecht
    then Strichrand [1 + Repeat_offen] := Kreuzoben
    else Strichrand [1 + Repeat_offen] := Kreuz;
  Ablegen ('R', Akt_Laenge);
  Akt_Laenge   := Akt_Laenge - 2;
end;    (* Repeat_auf *)

procedure Repeat_schliessen (Satz : Text110);
begin
  Zeichne_Strich (Textrand, unten);
  Update_Var ('R');
  Text_Ausgabe (Satz, Strich_Blank + Senkrecht, 3, Akt_Laenge,
                                     unten, false, false, false);
end;    (* Repeat_schliessen *)

procedure If_Case (Sign : char; Satz : Text110);
var   Zwischen : Schleifenpointer;
begin
  Satz      := Satz + '  ?';
  Text_Ausgabe (Satz, Senkrecht + ' ' + Senkrecht, 3, Akt_Laenge,
                                         mitte, true, false, false);
  Ablegen (Sign, Akt_Laenge);
  if Sign = 'I'
    then begin
           Textrand   := Textrand + Senkrecht + '      ';   (* 6 Blanks *)
           Akt_Laenge := Akt_Laenge - 7;
           delete (Strichrand, 1, 7);
         end
    else begin
           Textrand   := Textrand + Senkrecht + '            ';
                                                           (* 12 Blanks *)
           Akt_Laenge := Akt_Laenge - 13;
           delete (Strichrand, 1, 13);
         end;
  TEO_Erste := true;
end;    (* If_Case *)

procedure Then_Else_Of (Fall : Text110; Laenge : integer);
begin
  delete (Textrand, length (Textrand) - 1, 2);
  Textrand    := Textrand + Waagerecht + Waagerecht;
  Verbleib    := ' ' + copy (Fall, 1, Laenge - 1);
  while length (Verbleib) < Laenge do
    Verbleib   := Verbleib + ' ';
  TEO_Status  := aktiv;
end;    (* Then_Else_Of *)

procedure Abschluss;
begin
  Zeichne_Strich (Textrand, unten);
  Update_Var ('P');
  Text_Ausgabe (' ', Strich_Blank + Senkrecht, 3, Akt_Laenge,
                                       unten, false, false, false);
  Zeichne_Strich (Textrand, letzte);
  if Schleife^.Last <> nil
    then Fehler_Meldung (Zeile, 103);
  writeln (Destination, ' ');
  writeln (Destination, ' ');
  writeln (Destination, ' ');
end;    (* Abschluss *)

procedure Symbol_Fts (Verteiler : char);

  procedure While_If_Case_Comment (Sign : char);
  var Schleife_Old           : Schleifenpointer;
      Differenz              : integer;
      TxtRnd_Old, StrRnd_Old : Text110;
  begin
    Schleife_Old := Schleife;
    Schleife     := Schleife^.Last;
    TxtRnd_Old   := Textrand;
    StrRnd_Old   := Strichrand;
    With Schleife^ do
      begin
        IF Zeichen = Sign then
          begin
            Differenz := Laenge - Akt_Laenge;
            Textrand  := Copy (Textrand, 1, Length (Textrand) - Differenz);
            Strichrand := Copy (Strich, 1, Differenz) + Strichrand;
          end
        else Fehler_Meldung (Zeile, 105);
        with Struktur^ do
        if Sign = 'W' then Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht,
                                     3, Laenge, mitte, false, false, false)
                      else Text_Ausgabe (Bezeichnung, Senkrecht + ' ' +
                             Senkrecht, 3, Laenge, mitte, false, false, false);
      end;
    Textrand   := TxtRnd_Old;
    Strichrand := StrRnd_Old;
    Schleife   := Schleife_Old;
  end;     (* While_If_Case_Comment *)

begin
  with Struktur^ do
    case Verteiler of
         'A'   : Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht, 2,
                                  Akt_Laenge, mitte, false, true, false);
         'U'   : Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht, 2,
                                  Akt_Laenge, mitte, false, true, true);
         'R'   : Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht, 3,
                                  Akt_Laenge, unten, false, false, false);
      'W', 'I', 'C': While_If_Case_Comment (Verteiler);
    else      Fehler_Meldung (Zeile, 105);
  end;
end;     (* Symbol_Fts *)

procedure Symbol_auf (Verteiler : char);
var  Beginn    : integer;
begin
  with Struktur^ do
    case Verteiler of
         'A'  :  Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht, 2,
                                  Akt_Laenge, mitte, true, true, false);
         'U'  :  Text_Ausgabe (Bezeichnung, Strich_Blank + Senkrecht, 2,
                                  Akt_Laenge, mitte, true, true, true);
         'I'  :  If_Case (Verteiler, Bezeichnung);
         'T'  :  Then_else_Of ('ja', 6);
         'E'  :  Then_else_Of ('nein', 6);
         'C'  :  If_Case (Verteiler, Bezeichnung);
         'O'  :  Then_else_Of (Bezeichnung, 12);
         'W'  :  While_auf (Bezeichnung);
         'R'  :  Repeat_Auf;
         'P'  :  Name_Schreiben (Bezeichnung);
         'Q'  :  ;
      else    Fehler_Meldung (Zeile, 101);
    end;
end;    (* Symbol_auf *)

procedure Symbol_schliessen (Verteiler : char);
begin
  case Verteiler of
       'W'    :  Update_Var (Verteiler);
       'R'    :  Repeat_Schliessen (Struktur^.Bezeichnung);
    'C', 'I'  :  Update_Var (Verteiler);
       'P'    :  Abschluss;
     else   Fehler_Meldung (Zeile, 105);
  end;
end;    (* Symbol_schliessen *)

procedure Zeile_interpretieren;
begin
  Zeile  := 1;
  if Zu_Lang
    then begin
          {$I-}  reset (STG_Datei);  {$I+}
           Datei_Status (Struktur_Name);
           if Datei_ok
             then Lesen (Zeile_Akt, true);
         end
    else if Anfangs_Pointer = Ende_Pointer
           then Datei_Lesen
           else begin
          {$I-}   reset (STG_Datei);  {$I+}
                  Datei_Status (Struktur_Name);
                end;
  if Datei_ok and (Struktur_Name <> '')
    then begin
           Init_Phase;
           repeat
             with Struktur^ do
               if length (Symbol) > 1
                 then if Symbol [1] = '+'
                        then Symbol_Fts (Symbol [2])
                        else Symbol_schliessen (Symbol [2])
                 else Symbol_auf (Symbol [1]);
             Zeile    := succ (Zeile);
             Struktur := Struktur^.Next;
             if (Zeile >= Zeile_Akt)
               then begin
                      Lesen (Zeile_Akt, false);
                      Struktur := Anfangs_Pointer;
                    end;
           until (Struktur = nil);
           Nachlauf;
         end;
end;    (* Zeile_interpretieren *)
(*----------------------------------------------------------------------*)
(*                    Ende von STRUKTO2.PAS                             *)