Program FontConverter;
{$G+,E-,N+}
var
  Source, Destin : array[0..16383] of Byte;
  Schar, Dchar : array[0..64] of Byte;
  S, D : array[0..64] of Byte;
  NameSrc, NameDst : String;
  fs, fd : file;
  FsSz, FdSz : Longint;
  Hs, Hd : Byte;
  i, j, k : Word;
  t, dt : Extended;
begin
  if ParamCount=0 then
  begin
    WriteLn('Нужны параметры!');
    Halt;
  end;
  NameSrc := ParamStr(1);
  if ParamCount = 1 then
  begin
    Write('Введите имя файла отконвертированного файла: ');
    ReadLn(NameDst);
  end
    else NameDst := ParamStr(2);
  Write('Введите высоту шрифта, которую хотите получить: ');
  ReadLn(Hd);
  if not (Hd in [0..64]) then
  begin
   WriteLn('Высота шрифта должна быть в пределах от 1 до 64');
   Halt;
  end;
  Assign(fs, NameSrc);
  Reset(fs, 1);
  FsSz := FileSize(fs);
  Seek(fs, 0);
  BlockRead(fs, Source, FsSz);
  Close(fs);
  Hs := FsSz shr 8;
  FdSz := Hd shl 8;
  if ParamCount=3 then
    begin
      if ParamStr(3) = '/@'
      then dt := 1E-3;
      if ParamStr(3) = '/!'
      then dt := 7E-4;
    end else
  if Hd>Hs then
    dt := 1/(Hd+1)
  else
    dt := 1/(Hs+1);
  for i := 0 to 255 do
  begin
    FillChar(Schar, 64, 0);
    FillChar(Dchar, 64, 0);

    for j := 0 to Hs-1 do
      Schar[j] := Source[i*Hs+j];

    for k := 0 to 7 do
     begin
      for j := 0 to Hs-1 do
        S[j] := Schar[j] and ($80 shr k);
      t := dt;
      While t <= 1.0 do
        begin
          D[Round(t*Hd)] := S[Round((t-dt)*Hs)];
          t := t + dt;
        end;
      for j := 0 to Hd-1 do
        Dchar[j] := Dchar[j] or D[j];
     end;

    for j := 0 to Hd-1 do
      Destin[i*Hd+j] := Dchar[j];
  end;
  Assign(fd, NameDst);
  ReWrite(fd, 1);
  BlockWrite(fd, Destin, FdSz);
  Close(fd);
end.

Назад