Program FontInformer;
var
  f : file of Byte;
  fout, ftab : Text;
  CountDots : array[0..255] of Byte;
  forSort : array[0..255] of Byte;
  i, j, k : Integer;
  br, Cnt, differCnt, differCnt32 : Byte;
  Gre32 : Boolean;
const
  outname : String = 'fontinfo.txt';
  tabname : String = 'tabfont.shu';
{C:\PROGRA~2\BP70\FONTS\normal.fnt}
Function HexB(b : Byte) : String;
const
  HD: array[0..15] of Char = ('0','1','2','3','4','5','6','7',
  '8','9','A','B','C','D','E','F');
begin
  HexB := HD[b shr 4] + HD[b and $F]
end;
Function HowMBits( b : Byte ) : Byte;
var
  i, c : Byte;
begin
  c := 0;
  for i := 0 to 7 do
    c := (b shr i) and 1 + c;
  HowMBits := c
end;
Procedure Sort;
var
  tmp : Byte;
  Flag : Boolean;
begin
  for i := 0 to 255 do forSort[i] := CountDots[i];
  Flag := True;
  Repeat
    Flag := False;
    for i := 1 to 255 do
      if forSort[i-1]>forSort[i] then
       begin
         Flag := True;
         tmp := forSort[i];
         forSort[i] := forSort[i-1];
         forSort[i-1] := tmp;
       end;
  Until not Flag;
end;
begin
  if ParamCount = 0 then
  begin
    WriteLn('Введите в командной строке имя файла, содержащего шрифт 8x16');
    WriteLn('Формат командной строки: fontinfo  [info_out] [tablename]');
    Halt;
  end;
  if ParamCount > 1 then outname := ParamStr(2);
  Assign(f, ParamStr(1));
  Assign(fout, outname);
  Reset(f);
  if FileSize(f)<>$1000 then
  begin
    WriteLn('Шрифт должен быть размером 8x16!');
    Close(f);
  end;
  for i := 0 to 255 do
   begin
    Cnt := 0;
    for j := 0 to 15 do
     begin
       Read(f, br);
       Cnt := Cnt + HowMBits(br);
     end;
     CountDots[i] := Cnt
   end;
  Close(f);
  Sort;
  ReWrite(fout);
  WriteLn(fout, '[Информация о шрифте "', ParamStr(1), '"]');
  WriteLn(fout);
  for i := 0 to 255 do
  begin
    Write(fout, i, ' [', HexB(i),'h]',': ');
    WriteLn(fout, CountDots[i], ' точек, ', 1.0*CountDots[i]/1.28:1:2, '%');
  end;
  WriteLn(fout);
  WriteLn(fout, 'Отсортировано:');
  WriteLn(fout);
  Write(fout, forSort[0]);
  Cnt := 1;
  differCnt := 1;
  differCnt32 := 1;
  for i := 1 to 255 do
    if forSort[i-1]<>forSort[i] then
     begin
      Write(fout, ' * ', Cnt, ': ');
      inc(differCnt);
      Gre32 := False;
      for j := 0 to 255 do
        if CountDots[j] = forSort[i-1] then
         begin
          Gre32 := Gre32 or (j>=32);
          Write(fout, j, '{', HexB(j), 'h}/ ');
         end;
      if Gre32 then inc(differCnt32);
      WriteLn(fout);
      Cnt := 1;
      Write(fout, forSort[i]);
     end else inc(Cnt);
  WriteLn(fout, ' * ', Cnt);
  WriteLn(fout);
  WriteLn(fout, ' Символов, различающихся числом точек: ', differCnt);
  WriteLn(fout, ' Различающихся числом точек, не меньших 32: ', differCnt32);
  Close(fout);
  if ParamCount > 2 then tabname := ParamStr(3);
  Assign(ftab, tabname);
  ReWrite(ftab);
  WriteLn(ftab, 'Все символы');
  WriteLn(ftab, differCnt);
  WriteLn(ftab, 0);
  k := 1;
  Cnt := 1;
  for i := 1 to 255 do
    if forSort[i-1]<>forSort[i] then
     begin
      WriteLn(ftab, Cnt);
      WriteLn(ftab, forSort[i]);
      Cnt := 1;
     end else inc(Cnt);
  WriteLn(ftab, Cnt); {!!! если вдруг максимальных несколько?}
  for j := 0 to 255 do
    if CountDots[j] = forSort[0] then
      Write(ftab, Char(j));
  WriteLn(ftab);
  for i := 1 to 255 do
  if forSort[i-1]<>forSort[i] then
   begin
   for j := 0 to 255 do
    if CountDots[j] = forSort[i] then
      Write(ftab, Char(j));
    WriteLn(ftab);
   end;
  WriteLn(ftab, 'Символы, начиная с 32-ого');
  WriteLn(ftab, differCnt32);
  Gre32 := False;
  Cnt := 0;
  for j := 0 to 255 do
    if CountDots[j] = forSort[0] then
      begin
       if j >= 32 then inc(Cnt);
       Gre32 := Gre32 or (j>=32);
      end;
  if Gre32 then
  begin
   WriteLn(ftab, 0);
   WriteLn(ftab, Cnt);
  end;
  for i := 1 to 255 do
    if forSort[i-1]<>forSort[i] then
     begin
      Gre32 := False;
      Cnt := 0;
      for j := 0 to 255 do
        if CountDots[j] = forSort[i] then
         begin
          if j >= 32 then inc(Cnt);
          Gre32 := Gre32 or (j>=32);
         end;
      if Gre32 then
      begin
       WriteLn(ftab, forSort[i]);
       WriteLn(ftab, Cnt);
      end;
     end;
  Gre32 := False;
  for j := 0 to 255 do
    if CountDots[j] = forSort[0] then
     begin
      Gre32 := Gre32 or (j>=32);
      if j>=32 then
        Write(ftab, Char(j));
     end;
  if Gre32 then WriteLn(ftab);
  for i := 1 to 255 do
  if forSort[i-1]<>forSort[i] then
   begin
   Gre32 := False;
   for j := 0 to 255 do
    if CountDots[j] = forSort[i] then
    begin
     Gre32 := Gre32 or (j>=32);
     if j>=32 then
      Write(ftab, Char(j));
    end;
    if Gre32 then WriteLn(ftab);
   end;
  Close(ftab);
end.

Назад