home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / list / tsigns41.ark / MAKEFONT.PAS < prev    next >
Pascal/Delphi Source File  |  1986-12-24  |  6KB  |  170 lines
  1. PROGRAM MakeFont;
  2.  
  3. {******************************************************************************
  4. **
  5. **  Author: Robert W. Bloom
  6. **
  7. **  Function:  This program reads input from the file 'CHARS.ASC' and creates
  8. **             a file 'CHARS.DAT.'  CHARS.DAT is used by the program 'SIGNS'
  9. **             to create signs or banners.  See Signs.DOC for more info.
  10. **
  11. *****************************************************************************}
  12.  
  13. CONST
  14.           Date = 'v2.3, 27 Oct 86';    {date of last revision of this prog}
  15.      Input_DFN = 'Font';     {default input file}
  16.     Output_DFN = 'Font';     {default output file}
  17.      Max_Width = 40;              {these must be no greater then input file}
  18.     Max_Height = 24;              {and match CONSTs in signs.pas!}
  19.      Bit_Width = 5;               {Max_Width/8}
  20.  
  21. TYPE
  22.     CHAR_RECORD = RECORD           {record type used for random access}
  23.         character : CHAR;
  24.             width : INTEGER;
  25.            height : INTEGER;
  26.           bit_map : ARRAY[1..Max_height,1..Bit_Width] OF BYTE
  27.     END; {record}
  28.     IN_FILE_TYPE = TEXT;
  29.     OUT_FILE_TYPE = FILE OF CHAR_RECORD;
  30.  
  31. LABEL   restart;                   {for error recovery}
  32.  
  33. VAR           c : CHAR;
  34.     ans,ifn,ofn : STRING[14];
  35.        input_fn : IN_FILE_TYPE;
  36.       output_fn : OUT_FILE_TYPE;
  37.       trans_chr : CHAR_RECORD;
  38.   i,j,count,err : INTEGER;
  39. max_f_h,max_f_w : INTEGER;
  40.             pic : ARRAY[1..Max_Height,1..Max_Width] OF CHAR;
  41.         bit_tot : BYTE;
  42. BEGIN
  43.     WRITELN('<<< MakeFont ',Date,' >>>');
  44.     WRITELN;
  45.  
  46. restart:
  47.     WRITELN('Filenames starting with an ''X'' will terminate program.');
  48.     WRITELN('Maximum size of font that can be read is ',Max_Height,
  49.         ' high and ',Max_Width,' wide.');
  50.     WRITELN('Size of the output records will be ',Max_Height,' by ',Bit_Width);
  51.     WRITELN;
  52.  
  53.     WRITELN('If not specified, an extension of .ASC will be assumed.');
  54.     WRITE('Enter filename of input file, <cr> for the default ''',
  55.                  Input_DFN,''' -->');
  56.     READLN(ans);
  57.     IF ans = '' THEN
  58.        ifn := Input_DFN
  59.     ELSE
  60.        ifn := ans;
  61.     IF ans[1] IN ['X','x'] THEN HALT;
  62.     i := POS('.',ifn);
  63.     IF i = 0 THEN ifn := ifn + '.ASC';     {add extension if not given}
  64.  
  65.     WRITELN;
  66.     WRITELN('If not specified, an extension of .DAT will be assumed.');
  67.     WRITE('Enter filename of output file, <cr> for the default ''',
  68.                  Output_DFN,''' -->');
  69.     READLN(ans);
  70.     IF ans = '' THEN
  71.        ofn := Output_DFN
  72.     ELSE
  73.        ofn := ans;
  74.     IF ans[1] IN ['X','x'] THEN HALT;
  75.     i := POS('.',ofn);
  76.     IF i = 0 THEN ofn := ofn + '.DAT';     {add extension if not given}
  77.  
  78.     ASSIGN(input_fn,ifn);
  79.     {$I-} RESET(input_fn); {$I+}
  80.     err := IORESULT;
  81.     IF err <> 0 THEN BEGIN
  82.         WRITELN('ERR:',err,' Problem opening input file!'^G);
  83.         GOTO restart
  84.     END;
  85.  
  86.     ASSIGN(output_fn,ofn);
  87.     {$I-} REWRITE(output_fn); {$I+}
  88.     err := IORESULT;
  89.     IF err <> 0 THEN BEGIN
  90.         WRITELN('ERR:',err,' Problem in opening output file - try a different name!'^G);
  91.         GOTO restart
  92.     END;
  93.  
  94.     WRITELN;
  95.     WRITE('Date of font file --> ');
  96.     FOR i := 1 TO 10 DO BEGIN
  97.         READ(input_fn,c);
  98.         WRITE(c);
  99.     END; {output date of file}
  100.     READLN(input_fn);  {skip rest of line}
  101.     WRITELN;
  102.  
  103.     WRITE('Maximum size of is font is ');
  104.     READ(input_fn,max_f_w,max_f_h);
  105.     WRITELN(max_f_w,' Wide and ',max_f_h,'high.');
  106.     READLN(input_fn);  {skip rest of line}
  107.     WRITELN;
  108.  
  109.     IF (Max_f_w > Max_Width) OR (max_f_h > Max_Height) THEN BEGIN
  110.        WRITELN('ERROR -> defined font is larger than can be accepted'^G);
  111.        GOTO restart;
  112.     END;
  113.  
  114.     WRITE('defining characters --> ');
  115.     count := 0;
  116.     WHILE NOT EOF(input_fn) DO
  117.         WITH trans_chr DO BEGIN
  118.  
  119.             FOR i := 1 TO Max_Height DO
  120.                 FOR j := 1 TO Max_Width DO
  121.                     pic[i,j] := ' ';          {fill input map with all spaces}
  122.  
  123.             FOR i := 1 TO Max_Height DO
  124.                 FOR j := 1 TO Bit_Width DO
  125.                     bit_map[i,j] := 0;         {fill output map with all spaces}
  126.  
  127.             READLN(input_fn,character,width,height);
  128.             FOR i := 1 TO height DO BEGIN
  129.                 FOR j := 1 TO width DO
  130.                     READ(input_fn,pic[i,j]);
  131.                 READLN(input_fn)
  132.             END;
  133.  
  134.             FOR i := 1 TO Max_Height DO BEGIN
  135.                 j := 1;
  136.                 WHILE j <= Max_Width DO BEGIN
  137.                     bit_tot := 0;
  138.                     IF pic[i,j  ] <> ' ' THEN bit_tot := bit_tot + 1;
  139.                     IF pic[i,j+1] <> ' ' THEN bit_tot := bit_tot + 2;
  140.                     IF pic[i,j+2] <> ' ' THEN bit_tot := bit_tot + 4;
  141.                     IF pic[i,j+3] <> ' ' THEN bit_tot := bit_tot + 8;
  142.                     IF pic[i,j+4] <> ' ' THEN bit_tot := bit_tot + 16;
  143.                     IF pic[i,j+5] <> ' ' THEN bit_tot := bit_tot + 32;
  144.                     IF pic[i,j+6] <> ' ' THEN bit_tot := bit_tot + 64;
  145.                     IF pic[i,j+7] <> ' ' THEN bit_tot := bit_tot + 128;
  146.                     bit_map[i,ROUND((j+7)/8)] := bit_tot;
  147.                     j := j + 8
  148.                 END
  149.             END;
  150.  
  151.             WRITE(output_fn,trans_chr);         {write out record to file}
  152.             WRITE(character);                   {echo char just processed}
  153.  
  154.             count := count + 1;
  155.         END; {with trans_chr}
  156.     {END while}
  157.     WRITELN;
  158.     WRITELN;
  159.     WRITELN('Number of characters defined in font file --> ',count);
  160.     IF count < 96 THEN BEGIN
  161.         WRITELN('Error!  Font file must have at least 96 characters in it'^G);
  162.         GOTO restart
  163.     END;
  164.  
  165.     CLOSE(input_fn);
  166.     CLOSE(output_fn);
  167.     WRITELN;
  168.     WRITELN('<<< MakeFont completed >>>')
  169. END.
  170.