home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 03 / tricks / dbtree.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-12-10  |  3.9 KB  |  152 lines
  1. (* ------------------------------------------------------ *)
  2. (*                    DBTREE.PAS                          *)
  3. (*       Darstellung der UP-Verzweigungen in dBASE        *)
  4. (*          (c) 1991 Lutz Froehlich & TOOLBOX             *)
  5. (* ------------------------------------------------------ *)
  6. {$A+,B-,D+,E+,F-,I+,L+,N-,O-,R+,S+,V-}
  7. {$M 16384,0,655360}
  8.  
  9. PROGRAM DBTree;
  10.  
  11. USES Crt, Printer;
  12.  
  13. CONST
  14.   maxg = 25;         { Maximale Anzahl von Unterprogrammen }
  15.  
  16. TYPE
  17.   Zeiger = ^Knoten;
  18.   Knoten = RECORD
  19.              prn  : STRING [8];
  20.              next : ARRAY [1..maxg] OF Zeiger;
  21.            END;
  22.  
  23. VAR
  24.   aus          : CHAR;
  25.   wuna         : STRING[8];
  26.   pfad, dname  : STRING[66];
  27.   rfile, ausei : TEXT;
  28.   puffer       : ARRAY [1..16384] OF CHAR;
  29.   root         : Zeiger;
  30.   erueck       : STRING [80];
  31.   pau, pau1    : BYTE;
  32.   rootb        : BOOLEAN;
  33.  
  34.   PROCEDURE baum(VAR kn : Zeiger);
  35.     { Rekursive Prozedur zum Durchsuchen der Programme }
  36.   VAR
  37.     oname   : STRING [66];
  38.     zeile   : STRING;
  39.     h       : Zeiger;
  40.     i, j, k : INTEGER;
  41.     zlen    : BYTE ABSOLUTE zeile;
  42.   BEGIN
  43.     oname := pfad + kn^.prn + '.PRG';
  44.     Assign(rfile, oname);
  45.     i := 1;
  46.     {$I-}
  47.     Reset(rfile);
  48.     {$I+}
  49.     IF IOResult <> 0 THEN
  50.       kn^.prn := '????????'
  51.     ELSE BEGIN
  52.       WHILE NOT EoF(rfile) DO BEGIN
  53.         ReadLn(rfile,zeile);
  54.         FOR j := 1 TO zlen DO
  55.           zeile[j] := UpCase(zeile[j]);
  56.         j := 1;
  57.         WHILE (j < zlen) AND (zeile[j] = ' ') DO j := j + 1;
  58.         IF (Copy(zeile, j, 3) = 'DO ') AND
  59.            (Copy(zeile,j+3, 4) <> 'WHIL') AND
  60.            (Copy(zeile,j+3,4) <> 'CASE') AND
  61.            (Copy(zeile,j+3,1) <> '&') THEN BEGIN
  62.           New(h);
  63.           kn^.next[i] := h;
  64.           k := j+3;
  65.           WHILE (k < j+11) AND (zeile[k] <> ' ') DO
  66.             k := k + 1;
  67.           k := k - j - 3;
  68.           h^.prn := Copy(zeile, j+3, k);
  69.           i := i + 1;
  70.         END;
  71.       END;
  72.       Close(rfile);
  73.     END;
  74.     IF i > 1 THEN
  75.       FOR j := 1 TO i-1 DO baum(kn^.next[j]);
  76.     FOR j := i TO maxg DO kn^.next[j] := NIL;
  77.   END;
  78.  
  79.   PROCEDURE druck(VAR dr : Zeiger; VAR weg : BOOLEAN);
  80.     { Rekursive Prozedur zum Darstellen der Baumstruktur }
  81.   VAR
  82.     i  : INTEGER;
  83.     h  : Zeiger;
  84.     we : BOOLEAN;
  85.   BEGIN
  86.     i := 1;
  87.     erueck := erueck + '    ';  (* 4 blanks *)
  88.     IF weg THEN
  89.       erueck := erueck + '└'
  90.     ELSE
  91.       erueck := erueck + '├';
  92.     WriteLn(ausei, erueck + '───' + dr^.prn + '.PRG');
  93.     pau := pau - 1;
  94.     IF pau = 0 THEN BEGIN
  95.       ReadLn;
  96.       pau := pau1;
  97.     END;
  98.     erueck := Copy(erueck, 1, Length(erueck) - 1);
  99.     IF weg THEN
  100.       erueck := erueck + ' '
  101.     ELSE
  102.       erueck := erueck + '│';
  103.     WHILE dr^.next[i] <> NIL DO BEGIN
  104.       h := dr^.next[i];
  105.       we := (dr^.next[i+1] = NIL);
  106.       druck(h, we);
  107.       i := i + 1;
  108.     END;
  109.     erueck := Copy(erueck, 1, Length(erueck) - 5);
  110.   END;
  111.  
  112. BEGIN
  113.   WriteLn;
  114.   WriteLn('Darstellung der UP-Verzweigungen in dBase');
  115.   WriteLn('-----------------------------------------');
  116.   WriteLn;
  117.   Write('Ausgabe auf (D)rucker oder (B)ildschirm ? : ');
  118.   ReadLn(aus);
  119.   Write('Laufwerk und Pfad der Programme : ');
  120.   ReadLn(pfad);
  121.   Write('Name des Wurzelprogramms (ohne .PRG) : ');
  122.   ReadLn(wuna);
  123.   dname := pfad + wuna + '.PRG';
  124.   Assign(rfile, dname);
  125.   {$I-}
  126.   Reset(rfile);
  127.   {$I+}
  128.   IF IOResult <> 0 THEN BEGIN
  129.     WriteLn('Datei ', dname, ' nicht gefunden!');
  130.     Halt(1);
  131.   END ELSE
  132.     Close(rfile);
  133.   New(root);
  134.   root^.prn := wuna;
  135.   baum(root);
  136.   erueck := '';
  137.   IF UpCase(aus) = 'D' THEN BEGIN
  138.     pau1 := 55;
  139.     Assign(ausei, 'PRN');
  140.   END ELSE BEGIN
  141.     pau1 := 22;
  142.     Assign(ausei, 'CON');
  143.   END;
  144.   Rewrite(ausei);
  145.   rootb := TRUE;
  146.   pau := pau1;
  147.   druck(root, rootb);
  148.   Close(ausei);
  149. END.
  150. (* ------------------------------------------------------ *)
  151. (*                Ende von DBTREE.PAS                     *)
  152.