{ перевод изображения на экране в файл формата pcx  }
{ перевод изображения из файла формата pcx на экран }

unit WorkPcx;

interface

procedure WriteFile( CenterX, CenterY, Scale: pointer );

function ReadFile( Name: string; CenterX, CenterY, Scale: pointer ): boolean;

implementation

uses Global;

type
  Header = record			{ заголовок pcx-файла }
    Manuf:	byte;
    Ver:	byte;
    Code:	byte;
    Bits:	byte;
    X1,Y1,X2,Y2:word;
    Hres:	word;
    VRes:	word;
    Palette:	array[1..48] of byte;
    Mode:	byte;
    Planes:	byte;
    BPLine:	word;
    PalInf:	word;
    ShRes:	word;
    SvRes:	word;
    Extra:	array[0..53] of byte
  end;
  Number = array[0..SizeOf( double ) - 1] of byte;
  TSign = array[1..6] of char;

const
  Signature: TSign = 'Mandel';


var
  Pict: file of byte;
  Cnt1, Cnt3: word;
  Temp1, Temp2, Cnt2: byte;
  Buffer: PLine;
  THeader: Header;
  PHeader: array[1..SizeOf( Header )] of byte absolute THeader;
  BlockPal: PBlockPal;
  CodPal: byte;


procedure WriteFile;			{ запись файла }
var					{ имя выбирается последовательно }
  Name: string[12];			{ от pict00.pcx до pict99.pcx }
begin
  Name := 'pict00.pcx';
  repeat
    Assign( Pict, Name );
    Reset( Pict );
    if IOResult = 0 then Close( Pict )
    else Break;
    if Name[6] < '9' then Inc( Name[6] )
    else begin
      Name[6] := '0';
      Inc( Name[5] )
    end
  until False;
  Rewrite( Pict );
  with THeader do begin
    Manuf := $A;
    Ver := 5;
    Code := 1;
    Bits := 8;
    X1 := 0;
    Y1 := 0;
    X2 := MaxX - 1;
    Y2 := MaxY - 1;
    HRes := MaxX;
    VRes := MaxY;
    Mode := 0;
    Planes := 1;
    BPLine := MaxX;
    Move( Signature, Extra, SizeOf( Signature ));
    Move( CenterX^, Extra[SizeOf( Signature )], SizeOf( Number ));
    Move( CenterY^, Extra[SizeOf( Signature ) + SizeOf( Number )],
	  SizeOf( Number ));
    Move( Scale^, Extra[SizeOf( Signature ) + SizeOf( Number ) +
	  SizeOf( Number )], SizeOf( Number ))
  end;
  for Cnt1 := 1 to SizeOf( THeader ) do Write( Pict, PHeader[Cnt1] );
  New( Buffer );
  for Cnt3 := 0 to MaxY - 1 do begin
    GetLine( Buffer, Cnt3 );
    Cnt1 := 0;
    Temp2 := Buffer^[Cnt1];
    Buffer^[MaxX] := not Buffer^[MaxX-1];
    Inc( Cnt1 );
    repeat
      Temp1 := Temp2;
      Cnt2 := 0;
      repeat
	Temp2 := Buffer^[Cnt1];
	Inc( Cnt1 );
	Inc( Cnt2 )
      until ( Temp1 <> Temp2 ) or ( Cnt2 = 63 ) or ( Cnt1 > MaxX );
      if (( Cnt2 = 1 ) and ( Temp1 >= $C0 )) or ( Cnt2 > 1 ) then begin
	Cnt2 := Cnt2 or $C0;
	Write( Pict, Cnt2 )
      end;
      Write( Pict, Temp1 )
    until Cnt1 > MaxX
  end;
  Dispose( Buffer );
  New( BlockPal );
  GetPalette( BlockPal );
  CodPal := $C;
  Write( Pict, CodPal );
  for Cnt1 := 0 to NumPal do begin
    CodPal := BlockPal^[Cnt1] shl 2;
    Write( Pict, CodPal )
  end;
  Dispose( BlockPal );
  Close( Pict )
end;

function ReadFile;
var
  BufPalette: PBlockPal;

begin
  Assign( Pict, Name );
  Reset( Pict );
  ReadFile := False;
  if IOResult <> 0 then Exit;
  for Cnt2 := 1 to SizeOf( Header ) do Read( Pict, PHeader[Cnt2] );
  if Signature <> TSign(  Addr( THeader.Extra )^ ) then begin
    Close( Pict );
    Exit
  end;
  ReadFile := True;
  with THeader do begin
    Move( Extra[SizeOf( Signature )], CenterX^, SizeOf( Number ));
    Move( Extra[SizeOf( Signature ) + SizeOf( Number )], CenterY^,
	    SizeOf( Number ));
    Move( Extra[SizeOf( Signature ) + SizeOf( Number ) + SizeOf( Number )],
	    Scale^, SizeOf( Number ))
  end;
  New( Buffer );
  for Cnt3 := 0 to MaxY - 1 do begin	{ пока не закончились все строки }
    Cnt1 := 0;
    repeat
      Read( Pict, Temp1 );
      if Temp1 >= $C0 then begin	{ байт-повторитель }
	Temp2 := Temp1 and $3F;		{ выделить число повторений }
	Read( Pict, Temp1 )		{ прочитать повторяемый байт }
      end else Temp2 := 1;		{ число повторений = 1 }
      for Cnt2 := 1 to Temp2 do begin	{ записать в буфер необходимое }
	Buffer^[Cnt1] := Temp1;		{ число повторяющихся байтов }
	Inc( Cnt1 )
      end
    until Cnt1 >= MaxX;			{ пока строка не закончилась }
    SetLine( Buffer, Cnt3 )		{ вывести строку на экран }
  end;
  Read( Pict, Temp1 );			{ байт-индикатор палитры 256 цветов }
  Dispose( Buffer );
  New( BufPalette );
  for Cnt1 := 0 to NumPal do begin	{ прочитать информацию о палитре }
    Read( Pict, Temp1 );
    BufPalette^[Cnt1] := Temp1 shr 2	{ сохранить в буфере }
  end;
  SetAllPalette( BufPalette );		{ одним махом установить все палитры }
  Dispose( BufPalette );
  Close( Pict )
end;

end.