home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / signs / mkfntndx.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-09-29  |  10.6 KB  |  272 lines
  1. PROGRAM MkFntNdx;
  2.  
  3. {******************************************************************************
  4. **
  5. **  Author: Robert W. Bloom
  6. **
  7. **  Function:  This program reads a standard HP LaserJet-compatible font file
  8. **             and develops a index to the characters in the file.  This index
  9. **             is output to file to be used by the program 'SIGNS'.
  10. **             See Signs.DOC for more info.
  11. **
  12. *****************************************************************************}
  13.  
  14. CONST
  15.           Date = 'v5.0, 25 Sep 89';    {date of last revision of this prog}
  16.  
  17. TYPE
  18.     CHAR_INDEX_RECORD = RECORD {points to char in soft font file}
  19.     character : CHAR;          {the character}
  20.      position : WORD;          {where found in font file?}
  21.    top_offset : INTEGER;       {how far down does character start}
  22.   left_offset : INTEGER;       {how far left does character start}
  23.         width : INTEGER;       {how wide is it}
  24.        height : INTEGER;       {how high}
  25.       delta_x : INTEGER        {how far should 'cursor' move?}
  26.     END; {record}
  27.  
  28.     IN_FILE_TYPE = FILE OF CHAR;
  29.     OUT_FILE_TYPE = FILE OF CHAR_INDEX_RECORD;
  30.  
  31. VAR
  32.        input_fn : IN_FILE_TYPE;
  33.       output_fn : OUT_FILE_TYPE;
  34.       ndx_array : ARRAY[0..255] OF CHAR_INDEX_RECORD;
  35.       loop_ctrl : BYTE;
  36.  
  37. PROCEDURE init;                                      FORWARD;
  38. PROCEDURE process;                                   FORWARD;
  39. PROCEDURE findheader(VAR cnt : INTEGER);             FORWARD;
  40. PROCEDURE findchar(VAR cnt : INTEGER);               FORWARD;
  41. PROCEDURE outndxfile;                                FORWARD;
  42.  
  43.  
  44. PROCEDURE init;
  45. LABEL   restart;                   {for error recovery}
  46. VAR
  47.     ans,ifn,ofn : STRING[14];
  48.          i,err : INTEGER;
  49. BEGIN
  50. restart:
  51.     IF (paramcount = 0) OR (loop_ctrl > 0) THEN BEGIN
  52.         WRITELN('A <return> without a filename will terminate program.');
  53.         WRITELN;
  54.  
  55.         WRITELN('If not specified, an extension of .FNT will be assumed.');
  56.         WRITE('Enter filename of input file ->');
  57.         READLN(ans);
  58.         IF ans = '' THEN BEGIN
  59.            WRITELN;
  60.            WRITELN('<<< MkFntNdx completed >>>');
  61.            WRITELN;
  62.            halt       {normal exit - not classic pascal!}
  63.         END ELSE
  64.            ifn := ans;
  65.     END ELSE
  66.        ifn := ParamStr(1);
  67.    {end if a input filename was not given as a parameter}
  68.  
  69.     i := POS('.',ifn);
  70.     IF i = 0 THEN BEGIN
  71.        ofn := ifn + '.FNX';     {copy to the output file name}
  72.        ifn := ifn + '.FNT'      {add extension if not given}
  73.     END ELSE
  74.        ofn := COPY(ifn,1,POS('.',ifn)-1) + '.FNX';
  75.  
  76.     ASSIGN(input_fn,ifn);
  77.     {$I-} RESET(input_fn); {$I+}
  78.     err := IORESULT;
  79.     IF err <> 0 THEN BEGIN
  80.         WRITELN('ERROR:',err,' Problem opening input file!'^G);
  81.         GOTO restart
  82.     END;
  83.  
  84.     ASSIGN(output_fn,ofn);
  85.     {$I-} REWRITE(output_fn); {$I+}
  86.     err := IORESULT;
  87.     IF err <> 0 THEN BEGIN
  88.         WRITELN('ERROR:',err,' Problem in opening output file!'^G);
  89.         GOTO restart
  90.     END;
  91.  
  92.     WRITELN;
  93.     WRITELN('Initializing font index array');
  94.     FOR i := 0 TO 255 DO BEGIN
  95.         ndx_array[i].character   := CHR(i);
  96.         ndx_array[i].position    := 0;
  97.         ndx_array[i].top_offset  := 0;
  98.         ndx_array[i].left_offset := 0;
  99.         ndx_array[i].width       := 0;
  100.         ndx_array[i].height      := 0;
  101.         ndx_array[i].delta_x     := 0
  102.     END  {for}
  103. END; {procedure init}
  104.  
  105. PROCEDURE process;
  106. VAR
  107.       cnt : INTEGER; {count in the font file}
  108. BEGIN
  109.     cnt := 0;
  110.     WRITELN;
  111.     WRITELN('Font header info');
  112.     findheader(cnt);
  113.     WRITELN;
  114.     WRITELN('Character processing:');
  115.     WRITELN('Chr Position    Top_Offset  Left_Offset   Width      Height      Delta_X');
  116.     WHILE not EOF(input_fn) DO findchar(cnt);
  117.     ndx_array[32].delta_x := ndx_array[0].delta_x {default pitch for <sp> char}
  118. END; {procedure process}
  119.  
  120. PROCEDURE findheader(VAR cnt:INTEGER);
  121. VAR
  122.     c,hc,lc : char;
  123.     i : INTEGER;
  124. lobyte,hibyte : INTEGER;
  125.  found : BOOLEAN;
  126.  pitch : REAL;
  127. BEGIN
  128.     found := FALSE;
  129.     WHILE not EOF(input_fn) AND not found DO BEGIN
  130.         READ(input_fn,c); cnt := cnt+1;
  131.         IF ORD(c) = 27 THEN BEGIN                 {look for an <esc>}
  132.             READ(input_fn,c); cnt := cnt+1;
  133.             IF c = ')' THEN BEGIN                 {look for an )}
  134.                 READ(input_fn,c); cnt := cnt+1;
  135.                 IF c = 's' THEN BEGIN                    {followed by a 's'}
  136.                     READ(input_fn,c); cnt := cnt+1;
  137.                     WHILE (c >= '0') AND (c <= '9') DO BEGIN
  138.                         READ(input_fn,c);
  139.                         cnt := cnt+1
  140.                     END; {skip over font header size numbers}
  141.                     IF c = 'W' THEN BEGIN             {found it}
  142.                         found := TRUE;
  143.                         FOR i := 1 to 6 DO
  144.                             READ(input_fn,c);  {discard next 6 chars}
  145.                         cnt := cnt + 6;
  146.                         READ(input_fn,hc);   {hi byte of baseline distance}
  147.                         READ(input_fn,lc);   {lo}
  148.                         ndx_array[0].top_offset := 256*ORD(hc)+ORD(lc);
  149.                         WRITELN('   Baseline = ',ndx_array[0].top_offset);
  150.                         READ(input_fn,hc);   {hi byte of max cell width}
  151.                         READ(input_fn,lc);   {lo}
  152.                         ndx_array[0].width := 256*ORD(hc)+ORD(lc);
  153.                         WRITELN('   Maximum cell width = ',ndx_array[0].width);
  154.                         READ(input_fn,hc);   {hi byte of max cell height}
  155.                         READ(input_fn,lc);   {lo}
  156.                         ndx_array[0].height := 256*ORD(hc)+ORD(lc);
  157.                         WRITELN('   Maximum cell Height = ',ndx_array[0].height);
  158.                         cnt := cnt + 6;
  159.                         FOR i := 1 to 4 DO
  160.                             READ(input_fn,c);  {discard next 4 chars}
  161.                         cnt := cnt + 4;
  162.                         READ(input_fn,hc);   {hi byte of default char spacing}
  163.                         READ(input_fn,lc);   {lo}
  164.                         cnt := cnt + 2;
  165.                         pitch := (256*ORD(hc)+ORD(lc)) / 4;
  166.                         ndx_array[0].delta_x := ROUND(pitch);
  167.                         WRITELN('   Default Char spacing = ',ndx_array[0].delta_x)
  168.                     END {end if c='W'}
  169.                 END {end if c='s'}
  170.             END {end if c=')'}
  171.         END {end if c=<esc>}
  172.     END {while not found}
  173. END; {procedure findheader}
  174.  
  175. PROCEDURE findchar(VAR cnt:INTEGER);
  176. VAR
  177.     c,hc,lc : char;
  178.     i : INTEGER;
  179. lobyte,hibyte,fnd_chr_num,errcode : INTEGER;
  180.  found : BOOLEAN;
  181. strnum : STRING[3];
  182. pitch : REAL;
  183. BEGIN
  184.     found := FALSE;
  185.     WHILE not EOF(input_fn) AND not found DO BEGIN
  186.         READ(input_fn,c); cnt := cnt+1;
  187.         IF ORD(c) = 27 THEN BEGIN                 {look for an <esc>}
  188.             READ(input_fn,c); cnt := cnt+1;
  189.             IF c = '*' THEN BEGIN                    {followed by a '*'}
  190.                 READ(input_fn,c); cnt := cnt+1;
  191.                 IF c = 'c' THEN BEGIN                    {followed by a 'c'}
  192.                     READ(input_fn,c); cnt := cnt+1;
  193.                     strnum := '';
  194.                     WHILE (c >= '0') AND (c <= '9') DO BEGIN
  195.                         strnum := strnum + c;
  196.                         READ(input_fn,c); cnt := cnt+1
  197.                     END;
  198.                     val(strnum,fnd_chr_num,errcode);     {maybe this is it}
  199.                     IF c = 'E' THEN BEGIN
  200.                         found := TRUE;
  201.                         WRITE(' ',CHR(fnd_chr_num));
  202.                         READ(input_fn,c);
  203.                         READ(input_fn,c);  {discard next 2 chars}
  204.                         cnt:=cnt+2;
  205.                         READ(input_fn,c); cnt := cnt+1;
  206.                         WHILE c <> 'W' DO BEGIN  {find the 'W'}
  207.                             READ(input_fn,c);
  208.                             cnt := cnt+1
  209.                         END; {skip over font header size numbers}
  210.                         FOR i := 1 to 6 DO
  211.                             READ(input_fn,c);  {discard next 6 chars}
  212.                         cnt := cnt + 6;
  213.                         READ(input_fn,hc);   {hi byte of left offset}
  214.                         READ(input_fn,lc);   {lo}
  215.                         ndx_array[fnd_chr_num].left_offset := 256*ORD(hc)+ORD(lc);
  216.                         READ(input_fn,hc);   {hi byte of topoffset}
  217.                         READ(input_fn,lc);   {lo}
  218.                         ndx_array[fnd_chr_num].top_offset := 256*ORD(hc)+ORD(lc);
  219.                         READ(input_fn,hc);   {hi byte of char width}
  220.                         READ(input_fn,lc);   {lo}
  221.                         ndx_array[fnd_chr_num].width := 256*ORD(hc)+ORD(lc);
  222.                         READ(input_fn,hc);   {hi byte of char height}
  223.                         READ(input_fn,lc);   {lo}
  224.                         ndx_array[fnd_chr_num].height := 256*ORD(hc)+ORD(lc);
  225.                         READ(input_fn,hc);   {hi byte of char delta x}
  226.                         READ(input_fn,lc);   {lo}
  227.                         pitch := (256*ORD(hc)+ORD(lc)) / 4;
  228.                         ndx_array[fnd_chr_num].delta_x := ROUND(pitch);
  229.                         cnt := cnt + 10;
  230.                         ndx_array[fnd_chr_num].position := cnt;
  231.                         WITH ndx_array[fnd_chr_num] DO
  232.                             WRITELN(position:8,Top_Offset:12,left_Offset:12,Width:12,Height:12,Delta_X:12)
  233.                     END {if c='E'}
  234.                 END {if c=the char}
  235.             END {if c='c'}
  236.         END {if c='*'}
  237.     END {if c=<esc>}
  238. END; {procedure findchar}
  239.  
  240. PROCEDURE outndxfile;
  241. VAR
  242.     i : INTEGER;
  243. BEGIN
  244.     WRITELN;
  245.     WRITE('Writing output file ...');
  246.     FOR i:=0 to 255 DO
  247.         WRITE(output_fn,ndx_array[i]);
  248.     CLOSE(input_fn);
  249.     CLOSE(output_fn);
  250.     WRITELN(' completed.');
  251.     WRITELN; WRITELN;
  252.     loop_ctrl := loop_ctrl + 1
  253. END; {procedure outndxfile}
  254.  
  255. BEGIN
  256.     WRITELN('<<< MkFntNdx ',Date,' >>>');
  257.     WRITELN;
  258.     WRITELN('This programs creates a ''index'' file to a HP LaserJet-compatible soft font');
  259.     WRITELN('file to be used by ''Signs''.  Signs uses the fontfile and the associated');
  260.     WRITELN('index to create signs and banners.  The index file will have the same name as');
  261.     WRITELN('the font file but with the extension .FNX.');
  262.     WRITELN;
  263.     loop_ctrl := 0;
  264.     WHILE loop_ctrl < 100 DO BEGIN
  265.         init;                     {'halt' if no filename given}
  266.         process;
  267.         outndxfile
  268.     END; {while}
  269.     WRITELN;
  270.     WRITELN('<<< MkFntNdx completed >>>')
  271. END.
  272.