home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1988 / 05 / ttext.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-02-09  |  12.2 KB  |  381 lines
  1. PROGRAM TurboText;
  2.  
  3. { Dieses Program erzeugt ein Turbo Pascal Programmstueck   }
  4. { aus einem mit einem beliebigen Editor erzeugten Text.    }
  5.  
  6. {     -   Copyright (c) 1988 Pascal International   -      }
  7. {     -          Autor  :   Heinz Hagemeyer         -      }
  8.  
  9. { -------------------------------------------------------- }
  10.  
  11. CONST literal = ''''           ;{ oder auch #96            }
  12.       CR      =  13            ;{ ASCII von Carrige Return }
  13.       tab_w   = '         '    ;
  14.       zeilenlaenge = 60        ;{ Anzahl der Zeichen einer }
  15.                                 { Zeile.                   }
  16. TYPE filename   = STRING [ 80] ;
  17.      str40      = STRING [ 40] ;
  18.      str15      = STRING [ 15] ;
  19.      buchstaben = SET OF CHAR  ;
  20.  
  21. VAR ziel, quelle    : TEXT     ;
  22.     procedure_name  : str40    ;
  23.     trans           : ARRAY [1..6, 1..3] OF str15;
  24.     target          : INTEGER  ;
  25.     ws              : BOOLEAN  ;
  26.  
  27. { ---------------------------------------------------------}
  28.  
  29. FUNCTION Tasten_Code
  30.  (echo : BOOLEAN ; welche : buchstaben ) : CHAR ;
  31.  
  32. { gibt den Tastencode einer Taste zurueck, wenn diese in   }
  33. { der Menge WELCHE enthalten ist.                          }
  34. { Echo = true  ==> Anzeige auf dem Bildschirm;             }
  35. { Echo = false ==> keine Anzeige                           }
  36.  
  37. VAR c : CHAR ;
  38.  
  39. BEGIN
  40.   REPEAT
  41.     Read (kbd,c);
  42.   UNTIL c IN welche ;
  43.  
  44.   IF echo THEN WriteLn (c);
  45.   tasten_code := c;
  46. END;
  47.  
  48. { -------------------------------------------------------- }
  49.  
  50. PROCEDURE maske;
  51.  
  52. BEGIN
  53.   Write('╔══════════════════════════════════════════',
  54.            '══════════════════════════════════╗'); WriteLn;
  55.   Write('║                             TurboText    ',
  56.            '                                  ║'); WriteLn;
  57.   Write('╠══════════════════════════════════════════',
  58.            '══════════════════════════════════╣'); WriteLn;
  59.   Write('║        ┌─────────────────────────────────',
  60.            '─────────────────────────┐        ║'); WriteLn;
  61.   Write('║        │  Geben Sie den Namen der Quellda',
  62.            'tei ein :                │        ║'); WriteLn;
  63.   Write('║        │  Ist die Quelldatei WS-Datei (J/',
  64.            'N)      :                │        ║'); WriteLn;
  65.   Write('║        │  Jetzt den Namen Ihres Pascal-Pr',
  66.            'ogramms :                │        ║'); WriteLn;
  67.   Write('║        │  Bitte den Namen der Prozedur ei',
  68.            'ngeben  :                │        ║'); WriteLn;
  69.   Write('║        └─────────────────────────────────',
  70.            '─────────────────────────┘        ║'); WriteLn;
  71.   Write('║        ┌─────────────────────────────────',
  72.            '─────────────────────────┐        ║'); WriteLn;
  73.   Write('║        │  Wird die Eingabe der Prozedur m',
  74.            'it  <CR>  übergangen,    │        ║'); WriteLn;
  75.   Write('║        │  wird ein Pascal-Quellcode erzeu',
  76.            'gt, der in ein Pro-      │        ║'); WriteLn;
  77.   Write('║        │  gramm eingebunden werden kann. ',
  78.            '                         │        ║'); WriteLn;
  79.   Write('║        │  Andernfalls wird eine lauffähig',
  80.            'e Prozedur erzeugt, die  │        ║'); WriteLn;
  81.   Write('║        │  mittels {$I} eingeschlossen wir',
  82.            'd.                       │        ║'); WriteLn;
  83.   Write('║        └─────────────────────────────────',
  84.            '─────────────────────────┘        ║'); WriteLn;
  85.   Write('║        ┌─────────────────────────────────',
  86.            '─────────────────────────┐        ║'); WriteLn;
  87.   Write('║        │  Zielsprache [1] Pascal..       ',
  88.            '                         │        ║'); WriteLn;
  89.   Write('║        │              [2] BASIC...       ',
  90.            '                         │        ║'); WriteLn;
  91.   Write('║        │              [3] C....... bitte ',
  92.            'wählen  :                │        ║'); WriteLn;
  93.   Write('║        │  Wieviele Spalten einrücken ....',
  94.            '........?                │        ║'); WriteLn;
  95.   Write('║        └─────────────────────────────────',
  96.            '─────────────────────────┘        ║'); WriteLn;
  97.   Write('║                                          ',
  98.            '                                  ║'); WriteLn;
  99.   Write('╚══════════════════════════════════════════',
  100.            '══════════════════════════════════╝');
  101. END;
  102.  
  103. { -------------------------------------------------------- }
  104.  
  105. PROCEDURE init;
  106.  
  107. BEGIN
  108.   { Pascal-Syntax }
  109.   trans[1,1] := 'Write(''';
  110.   trans[2,1] := '''); WriteLn;';
  111.   trans[3,1] := ''',';
  112.   trans[4,1] := 'WriteLn('''')';
  113.   trans[5,1] := 'WriteLn;';
  114.   trans[6,1] := '''';
  115.   { BASIC-Syntax  }
  116.   trans[1,2] := 'PRINT " ';
  117.   trans[2,2] := ' " ';
  118.   trans[3,2] := ' "; ';
  119.   trans[4,2] := 'PRINT " ';
  120.   trans[5,2] := 'PRINT';
  121.   trans[6,2] := 'PRINT ';
  122.   { C-Syntax      }
  123.   trans[1,3] := 'printf(" ';
  124.   trans[2,3] := ' \n");';
  125.   trans[3,3] := ' ")';
  126.   trans[4,3] := 'printf(" ';
  127.   trans[5,3] := 'printf("\n")';
  128.   trans[6,3] := 'printf(" ';
  129. END;
  130.  
  131. { -------------------------------------------------------- }
  132.  
  133. PROCEDURE oeffne_quell_datei (VAR quelle : TEXT);
  134.  
  135. { Oeffnet die Quelldatei zum Lesen. Ueberprueft gleichzei- }
  136. { tig, ob diese ueberhaupt vorhanden ist. Falls nicht,     }
  137. { erfolgt Programmabbruch !                                }
  138.  
  139. VAR quell_name : filename  ;
  140.     taste      : CHAR      ;
  141.  
  142. BEGIN
  143.   GotoXY (54, 5);
  144.   ReadLn (quell_name);
  145.  
  146.   Assign (quelle, quell_name);
  147.  
  148.   {$I-}                         { Fehlerueberwachung aus   }
  149.     Reset (quelle);
  150.   {$I+}                         { und wieder ein.          }
  151.  
  152.   IF IOResult <> 0 THEN BEGIN   { Falls Fehler aufgetreten }
  153.     ClrScr;
  154.     WriteLn ('** Oben eingegebene Quelldatei existiert',
  155.              ' nicht ! **': 68);
  156.     WriteLn ('**       Programm wird daher abgebrochen ',
  157.              '!       **': 68);
  158.     HALT;
  159.   END;
  160.  
  161.   REPEAT
  162.     GotoXY (54, 6);
  163.     Read (kbd, taste);
  164.     Write (taste);
  165.   UNTIL (taste = 'j') or (taste = 'J') or (taste = 'n') or
  166.         (taste = 'N');
  167.   taste := upcase (taste);
  168.  
  169.   ws := false;
  170. { Ist WS auf false gesetzt, erfolgt keine Ausblendung des  }
  171. { Bit 7 und keine Auswertung der von Wordstar benutzten    }
  172. { Steuerzeichen.                                           }
  173.   IF taste = 'J' THEN ws := true;
  174.  
  175. END; { Oeffne_quell_datei }
  176.  
  177. { -------------------------------------------------------- }
  178.  
  179. PROCEDURE oeffne_ziel_datei ( VAR ziel           : TEXT ;
  180.                               VAR procedure_name : str40 );
  181.  
  182. CONST egal_welcher : buchstaben = [#0 .. #255];
  183.  
  184. VAR ziel_name : filename ;
  185.             c : CHAR     ;
  186. BEGIN
  187.   GotoXY (54, 7);
  188.   ReadLn (ziel_name);
  189.  
  190.   Assign (ziel, ziel_name);
  191.  
  192.   {$I-}                          { Siehe oeffne quelldatei }
  193.     Reset (ziel  );
  194.   {$I+}
  195.  
  196.   IF IOResult = 0 THEN BEGIN
  197.  
  198.           { Wenn kein Fehler auftritt, ist die Zieldatei   }
  199.           { vorhanden. Sicherheitshalber wird dann abge-   }
  200.           { fragt, ob diese ueberschrieben werden darf.    }
  201.           { Wenn nicht, erfolgt Programmabbruch.           }
  202.  
  203.     GotoXY(10,25);
  204.     Write ('Zieldatei ',Ziel_name,' existiert bereits.');
  205.     Write ('Ueberschreiben (J/N) ? ');
  206.     REPEAT
  207.       Read (kbd, c);
  208.       Write (c);
  209.     UNTIL (c = 'j') or (c = 'J') or (c = 'n') or
  210.           (c = 'N');
  211.     c := upcase (c);
  212.  
  213.     IF c = 'N' THEN BEGIN
  214.       ClrScr;
  215.       WriteLn ('** Programm wird abgebrochen ! **' : 58);
  216.       HALT;
  217.     END;
  218.     GotoXY (1,25);
  219.     Write ('                                      ');
  220.     Write ('                                      ');
  221.   END;
  222.  
  223.   ReWrite (ziel) ;
  224.   GotoXY (54, 8);
  225.   ReadLn (procedure_name);
  226.   GotoXY (54,20);
  227.   ReadLn (target);
  228.   IF target >= 3 THEN target := 3;
  229.   IF target <= 1 THEN target := 1;
  230. END { Oeffne_Quell_Datei } ;
  231.  
  232. { ---------------------------------------------------------}
  233.  
  234. PROCEDURE Arbeite
  235.  (VAR Quelle, Ziel : TEXT ; Procedure_Name : str40 );
  236.  
  237. TYPE Zeile   = STRING [255];
  238.  
  239. CONST BTX    = TRUE ;
  240.  
  241. { Wird BTX (Bild_Schirm_Text) auf false gesetzt, erfolgt   }
  242. { keine Ausgabe auf dem Bildschirm. Geht schneller -       }
  243. { dafuer sieht man nicht's .                               }
  244.  
  245. VAR tab      : filename ;
  246.     anzahl,
  247.     ascii    : INTEGER ;
  248.     CR_da    : BOOLEAN;
  249.     c        : CHAR;
  250.     z        : Zeile;
  251.  
  252. BEGIN
  253.   IF procedure_name <> '' THEN BEGIN
  254.     tab := '       ';
  255.     WriteLn (ziel,'PROCEDURE ',procedure_name,';');
  256.     WriteLn (ziel,'BEGIN');
  257.     IF BTX THEN BEGIN
  258.       ClrScr;
  259.       WriteLn ('PROCEDURE ',procedure_name,';');
  260.       WriteLn ('BEGIN');
  261.     END;
  262.   END
  263.   ELSE BEGIN
  264.     tab := '';
  265.     GotoXY(54,21);
  266.     ReadLn (anzahl);
  267.     FOR anzahl := anzahl DOWNTO 1 DO tab := tab + ' ';
  268.   END;
  269.  
  270.   ClrScr;
  271.   anzahl := 0;
  272.   Z      := Tab + trans[1,target];
  273.   CR_da  := FALSE;
  274.  
  275.   WHILE NOT EoF (quelle) DO BEGIN
  276.     IF NOT CR_da THEN Read (quelle,c);
  277.  
  278.     ascii := ord (c);
  279.  
  280.      { Fuer  Wordstar - Muffel : Bei bestehenden Texten,   }
  281.      { welche nicht durch Wordstar unter CP/M erzeugt      }
  282.      { wurden, sind die folgenden Zeilen dann zu entfer-   }
  283.      { nen bzw. geeignet zu aendern, wenn das verwendete   }
  284.      { Textprogramm das 7.te Bit anders nutzt.             }
  285.      { Am Einfachsten geht dies durch Aendern der Konstan- }
  286.      { ten  WS. Bei Benutzung des Turbo Pascal Editors ist }
  287.      { dies nicht noetig, es sei denn, man benutzt das ^P- }
  288.      { Steuerzeichen.                                      }
  289.  
  290.     IF WS THEN BEGIN
  291.       WHILE ascii > $7F DO ascii := ascii - $80;
  292.       c := Chr (ascii);
  293.       IF ascii = $1F THEN Z := Z + '-' ;
  294.                                   { "weiches" Trennzeichen }
  295.     END;
  296.  
  297.       IF ascii = CR THEN BEGIN            { Carrige Return }
  298.                                           { = Zeilenende   }
  299.         CR_da := TRUE;
  300.         Z := Z + trans[2,target];
  301.  
  302.         { Die folgende Anweisung wandelt "WriteLn ('''');" }
  303.         { um in "WriteLn ;"                                }
  304.  
  305.         IF z = tab + trans[4,target] THEN
  306.            z := tab + trans[5,target];
  307.  
  308.         WriteLn (ziel,z);
  309.         IF BTX THEN WriteLn (z);
  310.  
  311.         Read (quelle,c);
  312.         anzahl  := 0;
  313.  
  314.         IF NOT EoF (quelle) THEN      { Kein Textende      }
  315.           Z := tab + trans[1,target];
  316.         END
  317.         ELSE BEGIN
  318.           CR_da := FALSE;
  319.           IF ascii > $1F THEN BEGIN   { kein Steuerzeichen }
  320.             Z := Z + c ;
  321.             anzahl := Succ (anzahl);
  322.  
  323.             IF (anzahl >= zeilenlaenge - Length(tab) - 15)
  324.                 AND (c <> literal) THEN BEGIN
  325.  
  326.        { Zur besseren Uebersichtlichkeit des erzeugten     }
  327.        { Programmtextes werden die maximal auf dem Bild-   }
  328.        { schirm darstellbaren Zeichen in einer Zeile in 2  }
  329.        { Zeilen aufgeteilt, wobei das Literalzeichen '     }
  330.        { nicht zerhackt werden darf. (Siehe auch weiter    }
  331.        { unten.)                                           }
  332.  
  333.               Z := Z + trans[3,target];
  334.               WriteLn (ziel,Z);
  335.               IF BTX THEN WriteLn (z);
  336.               IF target = 1 THEN
  337.                 Z := tab + tab_w + trans[6,target];
  338.               IF (target = 2) or (target = 3) THEN
  339.                 Z := tab + trans[4,target];
  340.               anzahl := 0;
  341.             END;
  342.           END;
  343.         END;
  344.  
  345.        { Steht das Literalbegrenzungszeichen inerhalb      }
  346.        { eines Literals, so muss es 2 mal geschrieben      }
  347.        { werden. Soll z.B. der Text "Das war's." auf dem   }
  348.        { Bildschirm ausgegeben werden, so lautet die ent-  }
  349.        { sprechende Schreibanweisung in Pascal :           }
  350.        { WriteLn ('Das war''s.');                          }
  351.        { Daher muessen die Literale doppelt geschrieben    }
  352.        { werden.                                           }
  353.  
  354.         IF c = literal THEN BEGIN
  355.           Z := Z + literal;
  356.           Anzahl := Succ (Anzahl);
  357.         END;
  358.     END { WHILE } ;
  359.  
  360.     IF procedure_name <> '' THEN BEGIN
  361.       WriteLn (ziel,'END;');
  362.       IF BTX THEN WriteLn ('END;');
  363.     END;
  364.  
  365. END { ARBEITE };
  366.  
  367. { -------------------------------------------------------- }
  368.  
  369. BEGIN   { ** Hauptprogramm ** }
  370.  
  371.   init;
  372.   ClrScr;
  373.   maske;
  374.   Oeffne_Quell_Datei (quelle);
  375.   Oeffne_Ziel_Datei  (ziel, procedure_name);
  376.   Arbeite (quelle, ziel, procedure_name);
  377.   Close (quelle);
  378.   Close (ziel  );
  379.  
  380. END.
  381.