Листинг 1

unit Text256;
interface

procedure SetTextParm(color,bkcolor,typetext:byte);
                 { установка параметров вывода текста }
{       color    - цвет текста                        }
{       bkcolor  - цвет фона                          }
{       typetext = 0 - прозрачный фон                 }
{       typetext = 1 - непрозрачный фон               }
procedure GetTextParm(var color,bkcolor,typetext:byte);
                          { запрос текущих параметров }

procedure PutText(x,y:longint; txt:string);
 {вывод текста по координатам x,y (верхний левый угол)}
procedure PutChar(x,y:longint; chr:char);
{вывод символа по координатам x,y (верхний левый угол)}

implementation
uses dos,graph;
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 : array[0..255,0..7]of byte;
                                       {таблица шрифта}
   Color1,bkColor1 : byte;
            {номера ?стандартных? цветов текста и фона}
   Color2,bkColor2 : byte;
      {номера цветов текста и фона в выбранной палитре}
   TextType : byte; {способ вывода (прозрачно или нет)}
   i,j,l    : longint;     {вспомогательные переменные}

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:longint; txt:string);
begin
   if(byte(txt[0])>0)then
      for i := 1 to byte(txt[0]) do
         putchar(x+8*(i-1),y,txt[i]);
end;

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

var r : registers;

begin  {инициализация — получаем адрес таблицы шрифтов}
   r.ax := $1130;
   r.bh := 3;
   intr($10,r);
   for j := 0 to 255 do
      for i := 0 to 7 do
         FontTable[j,i] := mem[r.es:r.bp + i + j*8];
   SetTextParm(15,0,1);
end.