Program BMP_Multiplier;
{$D-,E-,N+,G+}
const
 HS: array [0..15] of Char = '0123456789ABCDEF';
 ntmp = 'tmpbmpm.tmp';
 ndtmp = 'dtmpbmpm.tmp';
 ntmpr = 'tmpbmpr.tmp';
 ndtmpr = 'dtmpbmpr.tmp';
 ntmpg = 'tmpbmpg.tmp';
 ndtmpg = 'dtmpbmpg.tmp';
 ntmpb = 'tmpbmpb.tmp';
 ndtmpb = 'dtmpbmpb.tmp';
 nhead = 'bmphead.tmp';
var
  SizeX1, SizeY1, SizeX2, SizeY2 : Longint;
  Color1, Color2 : Longint;
  RGBbytes1 : array[0..2] of Byte absolute Color1;
  RGBbytes2 : array[0..2] of Byte absolute Color2;
  Color, dColor : Extended;
  bpp1, bpp2 : Byte;
  f1, f2, fhead, f : file;
  ftmp, fdtmp : file of Extended;
  ftmpr, fdtmpr : file of Extended;
  ftmpg, fdtmpg : file of Extended;
  ftmpb, fdtmpb : file of Extended;
  nm1, nm2, S : String;
  Mode : Byte;
  Buff : array [0..255] of Byte;
  Count : Integer;
  Cnt : Byte;
  i : Longint;
Function UpString(Sra : String) : String;
var
 i : Byte;
 Sr : String;
begin
  Sr := Sra;
  for i := 1 to Length(Sr) do
    Sr[i] := UpCase(Sr[i]);
  UpString := Sr
end;
Function HexW(X: Word; Bl : Boolean): String;
var
  S: String;
  k: Byte;
begin
  S := '';
  for k := 3 downto 0 do
    S := S+HS[(X shr (k*4)) and 15];
  if not Bl then
   While (S[1] = '0') and (Length(S)<>0) do
     Delete(S, 1, 1);
  HexW := S
end;  {HexW}
Procedure Together;
var
  j : Integer;
begin
  WriteLn('Обработка трёх цветов за один раз');
  Assign(ftmp, ntmp);
  ReWrite(ftmp);
  Assign(fdtmp, ndtmp);
  ReWrite(fdtmp);
  inc(Count);
  for i := 1 to SizeX1*SizeY1 do
  begin
    Color1 := 0;
    Color2 := 0;
    BlockRead(f1, Color1, Cnt);
    BlockRead(f2, Color2, Cnt);
    Color := 1.0*Color1;
    dColor := (Color2-Color1)/(1.0*Count);
    Write(ftmp, Color);
    Write(fdtmp, dColor);
  end;
  Close(f1);
  Close(f2);
  Close(fdtmp);
  Close(ftmp);
  Reset(fdtmp);
  Reset(ftmp);
  Reset(fhead, 1);
  for j := 1 to Count-1 do
  begin
    Seek(fhead, 0);
    Seek(ftmp, 0);
    Seek(fdtmp, 0);
    Assign(f, '00'+HexW(j, True)+'.BMP');
    ReWrite(f, 1);
    BlockRead(fhead, Buff, 54);
    BlockWrite(f, Buff, 54);
    for i := 1 to SizeX1*SizeY1 do
    begin
      Read(ftmp, Color);
      Read(fdtmp, dColor);
      Color1 := Round(Color+j*dColor);
      BlockWrite(f, Color1, Cnt);
    end;
    Close(f);
  end;
  Close(fdtmp);
  Close(ftmp);
  Close(fhead);
  Erase(fdtmp);
  Erase(ftmp);
  Erase(fhead);
end;
Procedure RGB;
var
  j : Integer;
begin
  WriteLn('Каждый цвет отдельно');

  Assign(ftmpr, ntmpr);
  ReWrite(ftmpr);
  Assign(fdtmpr, ndtmpr);
  ReWrite(fdtmpr);

  Assign(ftmpg, ntmpg);
  ReWrite(ftmpg);
  Assign(fdtmpg, ndtmpg);
  ReWrite(fdtmpg);

  Assign(ftmpb, ntmpb);
  ReWrite(ftmpb);
  Assign(fdtmpb, ndtmpb);
  ReWrite(fdtmpb);

  inc(Count);
  for i := 1 to SizeX1*SizeY1 do
  begin
    Color1 := 0;
    Color2 := 0;
    BlockRead(f1, Color1, Cnt);
    BlockRead(f2, Color2, Cnt);

    Color := 1.0*RGBbytes1[0];
    dColor := (RGBbytes2[0]-RGBbytes1[0])/(1.0*Count);
    Write(ftmpr, Color);
    Write(fdtmpr, dColor);

    Color := 1.0*RGBbytes1[1];
    dColor := (RGBbytes2[1]-RGBbytes1[1])/(1.0*Count);
    Write(ftmpg, Color);
    Write(fdtmpg, dColor);

    Color := 1.0*RGBbytes1[2];
    dColor := (RGBbytes2[2]-RGBbytes1[2])/(1.0*Count);
    Write(ftmpb, Color);
    Write(fdtmpb, dColor);
  end;
  Close(f1);
  Close(f2);

  Close(fdtmpr);
  Close(ftmpr);
  Close(fdtmpg);
  Close(ftmpg);
  Close(fdtmpb);
  Close(ftmpb);

  Reset(fdtmpr);
  Reset(ftmpr);
  Reset(fdtmpg);
  Reset(ftmpg);
  Reset(fdtmpb);
  Reset(ftmpb);

  Reset(fhead, 1);
  for j := 1 to Count-1 do
  begin
    Seek(fhead, 0);

    Seek(ftmpr, 0);
    Seek(fdtmpr, 0);
    Seek(ftmpg, 0);
    Seek(fdtmpg, 0);
    Seek(ftmpb, 0);
    Seek(fdtmpb, 0);

    Assign(f, '00'+HexW(j, True)+'.BMP');
    ReWrite(f, 1);
    BlockRead(fhead, Buff, 54);
    BlockWrite(f, Buff, 54);
    for i := 1 to SizeX1*SizeY1 do
    begin
      Read(ftmpr, Color);
      Read(fdtmpr, dColor);
      RGBbytes1[0] := Round(Color+j*dColor);

      Read(ftmpg, Color);
      Read(fdtmpg, dColor);
      RGBbytes1[1] := Round(Color+j*dColor);

      Read(ftmpb, Color);
      Read(fdtmpb, dColor);
      RGBbytes1[2] := Round(Color+j*dColor);

      BlockWrite(f, Color1, Cnt);
    end;
    Close(f);
  end;

  Close(fdtmpr);
  Close(ftmpr);
  Close(fdtmpg);
  Close(ftmpg);
  Close(fdtmpb);
  Close(ftmpb);

  Close(fhead);

  Erase(fdtmpr);
  Erase(ftmpr);
  Erase(fdtmpg);
  Erase(ftmpg);
  Erase(fdtmpb);
  Erase(ftmpb);

  Erase(fhead);
end;
begin
  Mode := 0;
  WriteLn;
  WriteLn('Программа построения по двум BMP серии промежуточных рисунков.');
  WriteLn('Поддерживаются форматы BMP с 24bpp/15bpp');
  WriteLn('Причём два файла одновременно должны иметь одинаковое bpp');
  if ParamCount=0 then
  begin
    Write('Введите имя первого BMP-файла:');
    ReadLn(nm1);
  end else nm1 := ParamStr(1);
  if ParamCount<=1 then
  begin
    Write('Введите имя второго BMP-файла:');
    ReadLn(nm2);
  end else nm2 := ParamStr(2);
  if ParamCount > 2 then
  begin
    S := ParamStr(3);
    if UpString(S)='/RGB' then Mode := 1;
  end;
  Assign(f1, nm1);
  Assign(f2, nm2);
  {$I-}
  Reset(f1, 1);
  {$I+}
  if IOResult<>0 then
  begin
    WriteLn('Ошибка открытия первого файла');
    Halt(1);
  end;
  {$I-}
  Reset(f2, 1);
  {$I+}
  if IOResult<>0 then
  begin
    Close(f1);
    WriteLn('Ошибка открытия второго файла');
    Halt(2);
  end;
  if FileSize(f1)<>FileSize(f2) then
  begin
    WriteLn('Файлы имеют различный размер!');
    Close(f1);
    Close(f2);
    Halt(3);
  end;
  Seek(f1, 0);
  BlockRead(f1, Buff, 18);
  BlockRead(f1, SizeX1, 4);
  BlockRead(f1, SizeY1, 4);
  BlockRead(f1, Buff[18], 2);
  BlockRead(f1, bpp1, 1);
  BlockRead(f1, Buff[20], 25);
  Assign(fhead, nhead);
  ReWrite(fhead, 1);
  BlockWrite(fhead, Buff, 18);
  BlockWrite(fhead, SizeX1, 4);
  BlockWrite(fhead, SizeY1, 4);
  BlockWrite(fhead, Buff[18], 2);
  BlockWrite(fhead, bpp1, 1);
  BlockWrite(fhead, Buff[20], 25);
  Close(fhead);
  Seek(f2, 0);
  BlockRead(f2, Buff, 18);
  BlockRead(f2, SizeX2, 4);
  BlockRead(f2, SizeY2, 4);
  BlockRead(f2, Buff, 2);
  BlockRead(f2, bpp2, 1);
  BlockRead(f2, Buff, 25);
  if (SizeX1<>SizeX2) or (SizeY1<>SizeY2) then
  begin
    WriteLn('Размеры изображений не совпадают!');
    Close(f1);
    Close(f2);
    Halt(4);
  end;
  if bpp1<>bpp2 then
  begin
    WriteLn('У файлов различное число бит на пиксел!');
    Close(f1);
    Close(f2);
    Halt(5);
  end;
  if not ((bpp1=24) or (bpp1=16)) then
  begin
    WriteLn('Файлы имеют неподдерживаемый формат - ', bpp1,'bpp');
    Close(f1);
    Close(f2);
    Halt(6);
  end;
  Repeat
    Write('Введите число промежуточных кадров (1..255): ');
    ReadLn(Count);
  Until (Count>0) and (Count<=255);
  WriteLn('Обрабатываю файлы ', nm1,' ', nm2,'... ');
  WriteLn(SizeX1, 'x', SizeY1, ' ', bpp1, 'bpp');
  if bpp1 = 24 then Cnt := 3 else Cnt := 2;
  if Mode=0 then Together;
  if Mode=1 then RGB;
end.

Назад