{
  Модуль, предназначенный для чтения BMP картинок из файла.
  Поддерживаются 16-тицветные картинки без сжатия
}
Unit bmp;

interface

Procedure BMPDisplay(const FileName: String; x,y: Integer; Kill: Boolean);

implementation

Uses Graph;

Type
 TBitMapHeader =
  Record
   bfType :             Word;        { Метка файла BM }
   bfSize :             LongInt;     { Длина файла в байтах }
   bfReserved :         LongInt;     { Резервные должны быть = 0 }
   bfOffBits :          LongInt;     { Смещение области данных }
   biSize :             LongInt;     { Длина BITMAP_INFO заголовка }
   biWidth :            LongInt;     { Ширина изображения в пикселах }
   biHeight :           LongInt;     { Высота изображения в пикселах }
   biPlanes :           Word;        { Цветовые плоскости = 1 }
   biBitCount :         Word;        { Количество битов на пиксел 1,4,8,24 }
   biCompression :      LongInt;     { Тип сжатия данных }
   biSizeImage :        LongInt;     { Размер изображения в байтах }
   biXPelsPerMeter :    LongInt;     { Разрешение по горизонтали }
   biYPelsPerMeter :    LongInt;     { Разрешение по вертикали }
   biClrUsed :          LongInt;     { Количество используемых цветов }
   biClrImportant :     LongInt;     { Количество основных цветов }
  End;

 TRGBQuad =                   { Описание цвета }
  Record
   rgbBlue,                   { Интенсивность голубого }
   rgbGreen,                  { Интенсивность зеленого }
   rgbRed,                    { Интенсивность красного }
   rgbReserved :        Byte; { Резервный }
  End;

Type TByteArray = Array[0..50000] of byte;

Procedure Display1 (Var f : File; const BitMapHeader : TBitMapHeader);
Begin
 WriteLn ('Монохромный режим не поддерживается.');
End;

Procedure Display4 (Var f : File; const BitMapHeader : TBitMapHeader; x,y: Integer; Kill: Boolean);
Var i,j : Integer;
Var RGBQuad : TRGBQuad;
Var TwoPixel : Byte;
Var Black : Byte;
Var Line : ^TByteArray;
Var number : Word;
Var BeginX,BeginY,EndY : Integer;
    CurrentX: Integer;
Begin
 If GetMaxColor < 15 then
  Begin
   WriteLn ('В данном видеорежиме невозможно отображение 16 цветов.');
   Exit;
  End;

 Black := 16;
 With BitMapHeader do
  begin
   For i:= 0 to 15 do         { Чтение и изменение палитры }
    Begin
     BlockRead(f,RGBQuad,SizeOf(RGBQuad));
     If (LongInt(RGBQuad)=0) then Black := i;
     With RGBQuad do
      SetRGBPalette(i, rgbRed shr 2, rgbGreen shr 2, rgbBlue shr 2);
     SetPalette(i,i);
    End;

   Number := (biWidth div 2 + 3) and not 3;  { Длина одной строки в байтах }
   BeginX := x+1; {(GetMaxX - biWidth) div 2;}
   BeginY := y+biHeight;{GetMaxY - (GetMaxY - biHeight) div 2;}
   EndY := y+1;
  End;

 GetMem (Line,number+1);          { Выводим изображение }
 For j:=BeginY downto EndY do
  Begin
   BlockRead(f,Line^[1],number);
   CurrentX := BeginX;
   For i:=1 to number do
    Begin
     TwoPixel := Line^[i];
     If Not Kill Then
     Begin
     If TwoPixel shr 4 <> Black then { Черный цвет считаем прозрачным }
      PutPixel(CurrentX,j,TwoPixel shr 4);
     Inc(CurrentX);
     If TwoPixel and 15 <> Black then
      PutPixel(CurrentX,j,TwoPixel and 15);
     Inc(CurrentX);
     End
     Else
     Begin
     If TwoPixel shr 4 <> Black then { Черный цвет считаем прозрачным }
      PutPixel(CurrentX,j,Black);
     Inc(CurrentX);
     If TwoPixel and 15 <> Black then
      PutPixel(CurrentX,j,Black);
     Inc(CurrentX);
     End;
    End;
  End;
 FreeMem (Line,number+1);
End;

Procedure Display8 (Var f : File; const BitMapHeader : TBitMapHeader);
Begin
 WriteLn ('Режим 256 цветов не поддерживается.');
End;

Procedure Display24 (Var f : File; const BitMapHeader : TBitMapHeader);
Begin
 WriteLn ('Режим 24 битного цвета не поддерживается.');
End;

Procedure BMPDisplay(const FileName: String; x,y: Integer; Kill: Boolean);
Var f: File;
    BitMapHeader : TBitMapHeader;
Begin
 Assign(f,FileName);
 {$I-}
 FileMode:=0;  { Открываем файл для чтения }
 Reset(f,1);
 {$I+}

 If IOResult<>0 Then
  Begin
   WriteLn ('Нет такого файла.');
   Exit;
  End;

 BlockRead(f,BitMapHeader,SizeOf(BitMapHeader));
 With BitMapHeader do
  Begin
   If (bfType<>19778) or (bfReserved<>0) or (biPlanes<>1) then
    Begin
     WriteLn ('Неверный формат BMP файла.');
     Close(f);
     Exit;
    End;
   If biCompression<>0 Then
    Begin
     WriteLn ('Файл сохранен со сжатием данных.');
     Close(f);
     Exit;
    End;
   {ClearDevice;}
   Case biBitCount of
    1  : Display1  (f, BitMapHeader);
    4  : Display4  (f, BitMapHeader, x,y, Kill);
    8  : Display8  (f, BitMapHeader);
    24 : Display24 (f, BitMapHeader);
   else
    Begin
     WriteLn ('Неверный формат BMP файла.');
     Close(f);
     Exit;
    End;
   End;
  End;
 Close(f);
End;
End.