Program SavingCurrentFont;
Uses CRT;
type
  ab = array [0..MaxInt] of Byte;
var
  P : ^ab;
  k, X, Y, B, H : Byte;
  X0, Y0 : Integer;
  F : File;
  S : String;
Procedure PutChar(k : Byte);Assembler;
   asm
     mov        ah, 0Ah
     mov        al, byte ptr k
     mov        bh, 0
     mov        cx, 1
     int        10h
   end;
Procedure PutPixel(x, y : Word; Color : Byte);Assembler;
   asm
     mov        ah, 0Ch
     mov        bh, 0
     mov        dx, word ptr y
     mov        cx, word ptr x
     mov        al, byte ptr Color
     int        10h
   end;
Function GetPixel(x, y : Word):Byte;Assembler;
   asm
     mov        ah, 0Dh
     mov        bh, 0
     mov        dx, word ptr y
     mov        cx, word ptr x
     int        10h
   end;
begin
  H := 16;
  GetMem(P, 256*H);
  asm
    mov ax, 12h
    int 10h
  end;
  X0 := 0;
  Y0 := 20;
  for k := 0 to 255 do PutPixel(k, k, k);
  for k := 0 to 255 do
  begin
   PutChar(k);
   if k mod 16 = 0 then ReadKey;
  end;
  for k := 0 to 255 do PutPixel(k, k, k);
  for k := 0 to 255 do
  begin
   PutChar(k);
   for Y := 0 to H-1 do
     begin
       B := 0;
       for X := 0 to 7 do
       if GetPixel(X, Y) <> 0 then
         begin
           B := B or (128 shr X);
           PutPixel(X, Y, 0);
           PutPixel(X0+X, Y0+Y, Yellow);
         end;
       P^[k*H+Y] := B;
     end;
     inc(X0, 10);
     if X0 > 639 then
      begin
        X0 := 0;
        inc(Y0, 20);
      end;
  end;
  Str(H, S);
  S := '8x'+S+'.fnt';
  Assign(F, S);
  ReWrite(F, 1);
  BlockWrite(F, P^, 256*H);
  Close(F);
  FreeMem(P, 256*H);
  ReadLn;
  asm
    mov ax, 3h
    int 10h
  end;
end.

Назад