листинг 1

interface

procedure SetTextParm(color,bkcolor,typetext:byte);
         { установка параметров вывода текста }
{       color    - цвет текста                        }
{       bkcolor  - цвет фона                          }
{       typetext = 0 - прозрачный фон                 }
{       typetext = 1 - непрозрачный фон               }
procedure GetTextParm(var color,bkcolor,typetext:byte);
            { запрос текущих параметров }
procedure PutText(x,y:word;text:string);
 {вывод текста по координатам x,y (верхний левый угол)}
procedure PutChar(x,y:word;chr:char);
{вывод символа по координатам x,y (верхний левый угол)}

implementation
uses dos;
type
   FTType = array[0..255,0..7]of byte;     {для шрифта}
const
   Colors : array[0..15]of byte =
           (  0,  2, 20, 22,160,162,172,182,
            109,111,125,127,237,239,253,255);
                   {цвета, соответствующие номерам 0—15}
var
   FontTable : ^FTType;                {таблица шрифта}
   Color1,bkColor1 : byte;
            {номера «стандартных» цветов текста и фона}
   Color2,bkColor2 : byte;
      {номера цветов текста и фона в выбранной палитре}
   TextType : byte; {способ вывода (прозрачно или нет)}

procedure SetTextParm(color,bkcolor,typetext:byte);
begin
   Color1   := color;
   bkColor1 := bkcolor;
   TextType := typetext;
   Color2   := Colors[Color1];
   bkColor2 := Colors[bkColor1];
end;

procedure GetTextParm(var color,bkcolor,typetext:byte);
begin
   color    := Color1;
   bkcolor  := bkColor1;
   typetext := TextType;
end;

procedure PutText(x,y:word;text:string);
var
   i:word;
begin
   if(byte(text[0])>0)then
      for i := 1 to byte(text[0]) do
         putchar(x+8*(i-1),y,text[i])
end;

procedure PutPixel(x,y:word;c:byte);     {вывод точки}
begin
   mem[SegA000:x+y*320] := c;
end;

function getpixel(x,y:word):byte; {запрос цвета точки}
begin
   getpixel := mem[SegA000:x+y*320];
end;

procedure putchar(x,y:word;chr:char);
var
   i,j,k,l : word;
   cc,bb : byte;
begin
   l := byte(chr);
   case TextType of
      0: for i := 0 to 7 do          { прозрачный фон }
            for j := 0 to 7 do
               if (FontTable^[l,i] and
                     (1 shl (7-j)) <> 0) then
                  putpixel(x+j,y+i,Color2);
      1: for i := 0 to 7 do        { непрозрачный фон }
            for j := 0 to 7 do
               if (FontTable^[l,i] and
                     (1 shl (7-j)) <> 0) then
                  putpixel(x+j,y+i,Color2)
               else putpixel(x+j,y+i,bkColor2);
   end;
end;

var r : registers;

begin  {инициализация — получаем адрес таблицы шрифтов}
   r.ax := $1130;
   r.bh := 3;
   intr($10,r);
   FontTable := ptr(r.es,r.bp);
   Color1   := 15;      {заносим величины по умолчанию}
   bkColor1 :=  0;
   TextType :=  1;
   Color2   := Colors[Color1];
   bkColor2 := Colors[bkColor1];
end.