program Sprite;

uses dos,     {для работы с прерыванием VideoBIOS}
     crt,     {для работы с клавиатурой}
     pal,     {для работы с палитрой}
     text256, {для вывода текста}
     timer18, {для измерения времени и синхронизации}
     sprites; {для работы со спрайтами}
const
   TextColor : byte = 0;         {текущий цвет текста}
   NumSprites = 2;               {количество спрайтов}
   NameSprt : array[1..2{NumSprites}]of string =
          ('sprt01.bmp','sprt02.bmp');
                               {имена файлов спрайтов}
var
   Sprt : array[1..NumSprites]of SpriteType; {спрайты}
   r    : registers;      {для вызова прерывания BIOS}
   i    : integer;                  {счетчик спрайтов}
   s    : string;      {для вывода сообщений на экран}
   FPS  : single;       {темп вывода кадров в секунду}

function sign(a:single):integer;
begin
   if a = 0 then
      sign := 0
   else
      if a > 0 then
         sign := 1
      else
         sign := -1;
end;

begin
   GetPal(p[0],0,256);
   FadeOut(p);
   randomize;
   for i := 1 to NumSprites do
      CreateSprite(NameSprt[(i mod 2)+1],random(320
                -Xsize),random(200-Ysize),1,1,Sprt[i]);
   r.ax := $13;  { устанавливаем режим }
   intr($10,r);  {  320х200х256 цветов }
   BlackPal;
   PutBackGround;      {рисуем фон}
   FadeIn(p);
   for i := 1 to NumSprites do begin
      GetBuffer(Sprt[i]);{сохраняем фон под спрайтом}
      PutSprite(Sprt[i]);{и рисуем на его месте спрайт}
   end;
   repeat   {теперь спрайт будет двигаться по экрану}
           {до тех пор, пока мы не нажмем на клавишу}
      for i := NumSprites downto 1 do
         PutBuffer(Sprt[i]);    {восстанавливаем фон}
      for i := 1 to NumSprites do begin
         CalcSpritePosition(Sprt[i]);
         GetBuffer(Sprt[i]);  {сохраняем фон}
         PutSprite(Sprt[i]);  {выводим спрайт}
      end;
      inc(TextColor);
      SetTextParm(TextColor div 16,
                            (TextColor + 48) div 16,1);
      PutText(56,16,'Демонстрационная');
      SetTextParm(TextColor and $F,0,0);
      PutText(192,16,'программа');
      SetTextParm(15,0,1);
      FPS := GetFPS;
      str(FPS:0:1,s);
      PutText(120,184,' '+s+' fps ');
      if FPS > 1 then      {изменяем приращение}
        for i := 1 to NumSprites do begin
          Sprt[i].dx := sign(Sprt[i].dx)*round(70/FPS);
          Sprt[i].dy := sign(Sprt[i].dy)*round(70/FPS);
        end;
      WaitVerticalRetrace;
        {ожидаем обратный ход луча кадровой развертки}
   until keypressed;
   readkey;                  {чистим буфер клавиатуры}
   FadeOut(p);
   r.ax := $3;
   intr($10,r);       {возвращаемся в текстовый режим}
   for i := NumSprites downto 1 do
      DestroySprite(Sprt[i]);
end.

Листинг 2

unit sprites;
interface

uses  bmpread;

const
   Xsize = 20;                {размеры спрайта, точек}
   Ysize = 20;
   TransparentColor = $FF;         {"прозрачный" цвет}
type
   SpriteArrayType =
             array[0..Ysize-1,0..Xsize-1]of byte;
                    {массив, равный по размеру спрайту}
   SpriteType = record
     x,y  : word;         {текущие координаты спрайта}
     dx,dy : integer;   {приращения координат спрайта}
     Img  : ^SpriteArrayType;
                  {для массива с изображением спрайта}
     Back : ^SpriteArrayType;
             {для массива, хранящего фон под спрайтом}
   end;
   ScreenType = array[0..199,0..319]of byte;
                                          {для экрана}
var
   Scr  : ^ScreenType;                         {экран}
   p    : array[0..767]of byte;

procedure GetBuffer(Sprite:SpriteType);
               {сохранение фона под спрайтом в буфере}
procedure PutBuffer(Sprite:SpriteType);
                                 {восстановление фона}
procedure PutSprite(Sprite:SpriteType);
                              {вывод спрайта на экран}
procedure CreateSprite(s:string; x,y,dx,dy:integer;
         var Sprite:SpriteType);  {"создание" спрайта}
procedure DestroySprite(Sprite:SpriteType);
                               {"уничтожение" спрайта}
procedure CalcSpritePosition(var Sprite:SpriteType);
                  {вычисление новых координат спрайта}
procedure PutBackground;     {создание фона на экране}

implementation

procedure GetBuffer(Sprite:SpriteType);
               {сохранение фона под спрайтом в буфере}
var
   i,j    : word;      {переменные цикла}
begin
   for j := 0 to Ysize-1 do
      for i := 0 to Xsize-1 do
         with Sprite do
            Back^[j,i] := Scr^[j+y,i+x];
end;

procedure PutBuffer(Sprite:SpriteType);
                                 {восстановление фона}
var
   i,j    : word;      {переменные цикла}
begin
   for j := 0 to Ysize-1 do
      for i := 0 to Xsize-1 do
         with Sprite do
            Scr^[j+y,i+x] := Back^[j,i];
end;

procedure PutSprite(Sprite:SpriteType);
                              {вывод спрайта на экран}
var
   i,j    : word;      {переменные цикла}
begin
   for j := 0 to Ysize-1 do
      for i := 0 to Xsize-1 do
         with Sprite do
            if Img^[j,i] <> TransparentColor then
                    {ставим только точки,}
            {цвет которых отличается от "прозрачного"}
               Scr^[j+y,i+x] := Img^[j,i];
end;

procedure CreateSprite(s:string; x,y,dx,dy:integer;
         var Sprite:SpriteType);  {"создание" спрайта}
var
   f : file;      {файл с изображением спрайта}
begin
   getmem(Sprite.Img,sizeof(SpriteArrayType));
                         {выделяем память для спрайта}
   getmem(Sprite.Back,sizeof(SpriteArrayType));
                          {выделяем память для буфера}
   Readbmp(@(Sprite.Img^),Xsize,Ysize,@p,s);
   Sprite.x := x;
   Sprite.y := y;     { задаем начальные значения }
   Sprite.dx := dx;    {  координат и приращений   }
   Sprite.dy := dy;
end;

procedure DestroySprite(Sprite:SpriteType);
                               {"уничтожение" спрайта}
begin
 { возвращаем память }
   freemem(Sprite.Back,sizeof(SpriteArrayType));
   freemem(Sprite.Img,sizeof(SpriteArrayType));
end;

procedure CalcSpritePosition(var Sprite:SpriteType);
                  {вычисление новых координат спрайта}
begin                       { спрайта и их приращений}
 {по достижении границы экрана делаем,}
   { чтобы спрайт "отразился" от нее}
   with Sprite do begin
      if (x + Xsize + dx) >= 319 then
         dx := -dx;       {вычисляем новые приращения}
      if (x + dx) <= 0 then
         dx := -dx;          {реализующие "отражение"}
      if (y + Ysize + dy) >= 199 then
         dy := -dy;                {спрайта от стенок}
      if (y + dy) <= 0 then
         dy := -dy;
      x := x+dx;                {   вычисляем новые  }
      y := y+dy;                { координаты спрайта }
   end;
end;

procedure PutBackground;     {создание фона на экране}
var
   i,j    : word;      {переменные цикла}
begin
   for j := 0 to 199 do
      for i := 0 to 319 do
         Scr^[j,i] := lo(i+j*8);
end;

begin
   scr := ptr(SegA000,0);         {указатель на экран}
end.