home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / soundpot / p / xprint.lbr / XPRINTDB.PZS / XPRINTDB.PAS
Encoding:
Pascal/Delphi Source File  |  1993-10-25  |  5.4 KB  |  224 lines
  1. PROGRAM CREATEDB;    {Create or Modify data base for CROSSPRINT}
  2. {$R+}
  3. {$U+}
  4.  
  5. CONST
  6.   FormFeed= ^L;
  7.   LineFeed= ^J;
  8.   CompPrtOn= #15;
  9.   CompPrtOff= #18;
  10.   ClrEol= #24;
  11.   ClrEos= #17;
  12.   ClrScrn= #26;
  13.   Escape= #27;
  14.  
  15. TYPE
  16.   CharData= Record
  17.               PinCode: 0..255;
  18.             End;  {CharData}
  19.  
  20. VAR
  21.   Ascii, I, J: Byte;
  22.   Resp: Char;
  23.   K: Integer;
  24.   FontData: File of CharData;
  25.   Ltrs: Array[32..127, 1..20] of Byte;
  26.   Letter: CharData;
  27.   Cursor: String[2];
  28.  
  29. PROCEDURE GETFONT;    {Read data base to create sideways letters}
  30.  
  31. VAR
  32.   OK: Boolean;
  33.  
  34. Begin
  35.   Assign(FontData, 'XPRINT.FNT');
  36.   Repeat
  37.     {$I-}
  38.     Reset(FontData);
  39.     {$I+}
  40.     OK:= (IOResult= 0);
  41.     If Not OK Then
  42.     Begin
  43.       Writeln(LineFeed, 'Can''t find ''XPRINT.FNT'' on default drive.':60);
  44.       Write('Press RETURN when ready.  ':53);
  45.       Readln(Resp);
  46.     End; {If Not OK}
  47.   Until OK;
  48.   K:= 0;
  49.   For I:= 32 to 127 Do            {ASCII values from 32 to 127}
  50.     For J:= 1 to 20 Do            {20 bytes per character}
  51.     Begin
  52.       Seek(FontData, K);
  53.       Read(FontData, Letter);
  54.       Ltrs[I,J]:= Letter.PinCode;
  55.       K:= K + 1;
  56.     End; {For J ...}
  57.   Close(FontData);
  58. End;  {Procedure GetFont}
  59.  
  60. PROCEDURE PUTFONT;     {Write data base file: XPRINT.FNT}
  61.  
  62. Begin
  63.   Assign(FontData, 'XPRINT.FNT');
  64.   Rewrite(FontData);
  65.   K:= 0;
  66.   For I:=32 to 127 Do
  67.     For J:=1 to 20 Do
  68.     Begin
  69.       Letter.PinCode:= Ltrs[I,J];
  70.       Seek(FontData, K);
  71.       Write(FontData, Letter);
  72.       K:= K + 1;
  73.     End;   {For J ...}
  74.   Close(FontData);
  75. End;  {PutFont}
  76.  
  77. PROCEDURE PRINTFONT;    {Print XPRINT.FNT}
  78.  
  79. Begin
  80.   Writeln(Lst, 'CROSSPRINT Data Base':50, LineFeed, LineFeed);
  81.   Write(Lst, CompPrtOn);
  82.   Write(Lst, 'ASCII   ':25);
  83.   For J:=1 to 20 Do
  84.   Begin
  85.     Write(Lst, J:4);
  86.     If J= 10 Then Write(Lst, ' ':4);
  87.   End; {For J ...}
  88.   Writeln(Lst, 'Character':12, LineFeed);
  89.  
  90.   For I:=32 to 127 Do
  91.   Begin
  92.     Write(Lst, I:21, '    ');
  93.     For J:= 1 to 20 Do
  94.     Begin
  95.       Write(Lst, Ltrs[I,J]:4);
  96.       If J= 10 Then Write(Lst, ' ':4);
  97.     End;  {For J ...}
  98.     If I< 127 Then
  99.       Writeln(Lst, '(':7, CHR(I), ')')
  100.       Else
  101.         Writeln(Lst, '(Del)':11);
  102.     If I= 90 Then Writeln(Lst, FormFeed);
  103.   End; {For I ...}
  104.   Write(Lst, CompPrtOff, FormFeed);
  105. End; {Procedure PrintFont}
  106.  
  107. PROCEDURE VIEWFONT;    {Write XPRINT.FNT to screen}
  108.  
  109. Begin
  110.   I:= 32;
  111.   Repeat
  112.     Writeln(ClrScrn, 'CROSSPRINT Data Base':45);
  113.     Write('   ');
  114.     For J:=1 to 20 Do
  115.     Begin
  116.       Write(J:3);
  117.       If J = 10 Then Write(' ':3)
  118.     End;  {For J ...}
  119.     Writeln(LineFeed);
  120.  
  121.     Repeat
  122.       Write(I:3);
  123.       For J:= 1 to 20 Do
  124.       Begin
  125.         Write(Ltrs[I,J]:3);
  126.           If J = 10 Then Write(' ':3);
  127.       End;  {For J ...}
  128.       Writeln(LineFeed);
  129.       I:= I + 1;
  130.     Until ((I Mod 10 = 0) or (I > 127));
  131.     Write('Press RETURN to continue. ':45);
  132.     Readln(Resp);
  133.   Until I > 127;
  134. End; {Procedure ViewFont}
  135.  
  136. PROCEDURE GETCODE;   {Get code for ASCII character}
  137.  
  138. Begin
  139.   Write(Cursor, '( ', ClrEol,
  140.         'Enter code for ASCII: ', Ascii, ', Character: ', CHR(Ascii));
  141.    For J:= 1 to 20 Do
  142.    Begin
  143.      Repeat
  144.        Write(Cursor, '.', CHR(33+4*(J-1)), ClrEol);
  145.        Readln(Ltrs[Ascii, J]);
  146.      Until Ltrs[I, J] in [0..255];
  147.  
  148.    Write(Cursor, '.', CHR(32+4*(J-1)), ClrEol, Ltrs[Ascii, J]:4);
  149.  End;  {For J ...}
  150. End; {Procedure GetCode}
  151.  
  152. Begin
  153.   Cursor:= Escape + '=';
  154.   Repeat
  155.     Writeln(ClrScrn, 'Maintain Data Base for CROSSPRINT':50);
  156.     Writeln(Cursor, '&6', 'Create data base.');
  157.     Writeln(Cursor, ')6', 'Modify data base.');
  158.     Writeln(Cursor, ',6', 'Print data base.');
  159.     Writeln(Cursor, '/6', 'View data base.');
  160.     Writeln(Cursor, '26', 'eXit.');
  161.     Repeat
  162.       Write(Cursor, '60', ClrEos, 'Enter your choice (C, M, P, V, X): ');
  163.       Readln(Resp);
  164.       Resp:= UpCase(Resp);
  165.     Until Resp In ['C', 'M', 'P', 'V', 'X'];
  166.     Write(ClrScrn);
  167.  
  168.     Case Resp of
  169.  
  170.     'C':Begin
  171.           Writeln('Create Data Base':46);
  172.           For I:= 32 to 127 Do
  173.             For J:= 1 to 20 Do
  174.               Ltrs[I, J]:= 0;
  175.  
  176.           Writeln(Cursor, '* ', 'Byte Number':44);
  177.           For J:= 1 to 20 Do
  178.             Write(J:4);
  179.  
  180.           For Ascii:= 32 to 127 Do
  181.             GetCode;
  182.  
  183.           PutFont;        {Write XPRINT.FNT file}
  184.         End;  {Case 'C'}
  185.  
  186.     'M':Begin
  187.           Writeln('Modify Existing Data Base':48);
  188.           GetFont;
  189.           Repeat
  190.             Repeat
  191.               Write(Cursor, '# ', ClrEos, Cursor, '6 ',
  192.                     'Enter ASCII value of character to modify (0 to end): ');
  193.               Readln(Ascii);
  194.               Write(Cursor, '6 ', ClrEol);
  195.             Until Ascii in [0, 32..127];
  196.  
  197.             If Ascii > 31 Then
  198.             Begin
  199.               Writeln(Cursor, '* ', 'Byte Number':44);
  200.               For J:= 1 to 20 Do
  201.                 Write(J:4);
  202.  
  203.               GetCode;
  204.             End; {If Ascii > 31}
  205.           Until Ascii< 32;
  206.           PutFont;        {Write XPRINT.FNT file}
  207.         End;   {Case 'M'}
  208.  
  209.     'P':Begin
  210.           Writeln('Printing CROSSPRINT Data Base':50);
  211.           GetFont;
  212.           PrintFont;
  213.         End;  {Case 'P'}
  214.  
  215.     'V':Begin
  216.           Writeln('View CROSSPRINT Data Base':47);
  217.           GetFont;
  218.           ViewFont;
  219.         End;  {Case 'V'}
  220.  
  221.     End;  {Case}
  222.   Until UpCase(Resp)= 'X';
  223.   Write(ClrScrn);
  224. End.