home *** CD-ROM | disk | FTP | other *** search
/ Audio 4.94 - Over 11,000 Files / audio-11000.iso / msdos / modplay / vtsrc12b / font / getfont.pas < prev    next >
Pascal/Delphi Source File  |  1992-09-13  |  3KB  |  149 lines
  1. PROGRAM CCurs;
  2.  
  3. USES Video;
  4.  
  5.  
  6.  
  7.  
  8. TYPE
  9.    PVGA13Screen = ^TVGA13Screen;
  10.  
  11.    PCelHeader = ^TCelHeader;
  12.    TCelHeader = RECORD
  13.                   Ident : WORD;
  14.                   HRez  : WORD;
  15.                   VRez  : WORD;
  16.                   Resto : ARRAY [3..15] OF WORD
  17.                END;
  18.    PCelFile = ^TCelFile;
  19.    TCelFile = RECORD
  20.                  Header : TCelHeader;
  21.                  Pal    : TVGAPalette;
  22.                  Scr    : PVGA13Screen
  23.               END;
  24.  
  25.  
  26.  
  27. FUNCTION LoadCel(s: STRING) : PCelFile;
  28.   VAR
  29.     f : FILE;
  30.     c : PCelFile;
  31.   BEGIN
  32.  
  33.     NEW(c);
  34.     Assign(f, s);
  35.     Reset(f, 1);
  36.     BlockRead(f, c^, SIZEOF(c^.Header) + SIZEOF(c^.Pal));
  37.     GETMEM(c^.Scr, c^.Header.HRez * c^.Header.VRez);
  38.     BlockRead(f, c^.Scr^, c^.Header.HRez * c^.Header.VRez);
  39.     Close(f);
  40.     LoadCel := c;
  41.  
  42.   END;
  43.  
  44.  
  45.  
  46.  
  47. TYPE
  48.   THexString = STRING[4];
  49.  
  50. FUNCTION HexWord(w: WORD) : THexString;
  51.   CONST
  52.     tabla : STRING[16] = '0123456789ABCDEF';
  53.   BEGIN
  54.  
  55.     HexWord[0] := #4;
  56.     HexWord[1] := tabla[ (w SHR 12)         + 1];
  57.     HexWord[2] := tabla[((w SHR  8) AND $F) + 1];
  58.     HexWord[3] := tabla[((w SHR  4) AND $F) + 1];
  59.     HexWord[4] := tabla[( w         AND $F) + 1];
  60.  
  61.   END;
  62.  
  63.  
  64. TYPE
  65.   TArrayByte = ARRAY[0..64000] OF BYTE;
  66.   PArrayByte = ^TArrayByte;
  67.  
  68. VAR
  69.   cel,
  70.   celx : PCelFile;
  71.   f    : BOOLEAN;
  72.   t    : FILE;
  73.   v,
  74.   i, j,
  75.   k, l,
  76.   cnt,
  77.   dotx,
  78.   doty,
  79.   nx,
  80.   ny,
  81.   linl,
  82.   acct,
  83.   accm : WORD;
  84.   p    : PArrayByte;
  85.   a    : ARRAY[0..7] OF BYTE;
  86. LABEL
  87.   Do32, Fin;
  88. BEGIN
  89.  
  90.   cel  := LoadCel(ParamStr(1));
  91. {  celx := LoadCel(ParamStr(2));}
  92.   nx   := (cel^.Header.HRez SHR 3);
  93.   ny   := (cel^.Header.VRez SHR 3);
  94.   linl := cel^.Header.HRez;
  95.  
  96.   Assign(t, ParamStr(3));
  97.   Rewrite(t, 1);
  98.  
  99. {
  100.   p   := PArrayByte(celx^.Scr);
  101.   cnt := 0;
  102.  
  103.   FOR i := 1 TO 1 DO
  104.     FOR j := 1 TO 32 DO BEGIN
  105.  
  106.       FOR k := 0 TO 7 DO BEGIN
  107.         acct := 0;
  108.         accm := 0;
  109.         FOR l := 0 TO 7 DO BEGIN
  110.           v := p^[(((i-1)*8) + k)*32*8 + (j-1)*8 + l];
  111.           IF v = 31 THEN acct := acct + 1 SHL (7-l)
  112.         END;
  113.         a[k]    := NOT acct;
  114.       END;
  115.  
  116.       BlockWrite(t, a[0], 8, v);
  117.       INC(cnt);
  118.       IF cnt >= 32 THEN GOTO Do32;
  119.  
  120.     END;
  121.  
  122. }
  123. Do32:
  124.   p   := PArrayByte(cel^.Scr);
  125.   cnt := 0;
  126.  
  127.   FOR i := 1 TO ny DO
  128.     FOR j := 1 TO nx DO BEGIN
  129.  
  130.       FOR k := 0 TO 7 DO BEGIN
  131.         acct := 0;
  132.         accm := 0;
  133.         FOR l := 0 TO 7 DO BEGIN
  134.           v := p^[(((i-1)*8) + k)*linl + (j-1)*8 + l];
  135.           IF v = 31 THEN acct := acct + 1 SHL (7-l)
  136.         END;
  137.         a[k]    := NOT BYTE(acct);
  138.       END;
  139.  
  140.       BlockWrite(t, a[0], 8, v);
  141.       INC(cnt);
  142.       IF cnt >= 256 THEN GOTO Fin;
  143.  
  144.     END;
  145.  
  146. Fin:
  147.   Close(t)
  148.  
  149. END.