листинг 1

unit pal; {работа с 256-цветной палитрой}
interface

procedure SetPal(var pal:byte;nbegpal,lenpal:integer);
                       {установка 256-цветной палитры}
procedure GetPal(var pal:byte;nbegpal,lenpal:integer);
                          {чтение 256-цветной палитры}
procedure WaitVerticalRetrace;
            {ожидание вертикально обратного хода луча}
procedure BlackPal;       {установка «черной» палитры}
procedure FadeOut(p:array of byte);
                             {плавное гашение палитры}
procedure FadeIn(p:array of byte);
                           {плавная установка палитры}
implementation
uses dos;

{установка 256-цветной палитры}
procedure SetPal(var pal:byte;nbegpal,lenpal:integer);
var r:registers;
begin
   r.ax := $1012;
   r.bx := nbegpal;
   r.cx := lenpal;
   r.dx := ofs(pal);
   r.es := seg(pal);
   intr($10,r);
end;

{чтение 256-цветной палитры}
procedure GetPal(var pal:byte;nbegpal,lenpal:integer);
var r:registers;
begin
   r.ax := $1017;
   r.bx := nbegpal;
   r.cx := lenpal;
   r.dx := ofs(pal);
   r.es := seg(pal);
   intr($10,r);
end;

{ожидание вертикально обратного хода луча}
procedure WaitVerticalRetrace;
begin
   while (port[$3da] and 8) = 0 do;
end;

{установка «черной» палитры}
procedure BlackPal;
var p : array[0..767]of byte;
begin
   fillchar(p,sizeof(p),0);
   SetPal(p[0],0,256);
end;

{плавная установка палитры}
procedure FadeIn(p:array of byte);
var
   p1 : array[0..767]of byte;
   i,j : integer;
begin
   BlackPal;
   for i := 0 to 63 do begin
      for j := 0 to 767 do    {«поднимаем» цвета до }
         p1[j] := round(p[j]/63*i);{ нужной палитры }
      WaitVerticalRetrace;
      SetPal(p1[0],0,256);
   end;
end;

{плавное гашение палитры}
procedure FadeOut(p:array of byte);
var
   p1 : array[0..767]of byte;
   i,j : integer;
begin
   for i := 0 to 767 do
      p1[i] := p[i];
   for i := 63 downto 0 do begin
      for j := 0 to 767 do    {«опускаем» цвета}
          p1[j] := round(p[j]/63*i); { до 0  }
      WaitVerticalRetrace;
      SetPal(p1[0],0,256);
   end;
end;

end.