adkcompress.pas

N年前有个法国小组用Delphi写了一个2D网游（AD&D类型）

unit ADKCompress;

{
 Compression d'images pour le projet ADK-ISO (c)2003 Paul TOTH <[e-mail]>

 http://www.web-synergy.net/naug-land/

}

interface

uses
 Windows,Classes,ADKDepth,ADKScreens;

type
// TPalette=array[0..255] of TPixel;//integer;
// PPalette=^TPalette;
 TPalette16=array[0..255] of TPixel16;
 PPalette16=^TPalette16;
 { -> ADKDepth
 TPalette32=array[0..255] of TPixel32;
 PPalette32=^TPalette32;
 }

 TADKCompressedDIB=class
 private
  src:pchar;
  len:cardinal;
  function GetLen:integer;
 protected
  procedure Draw1(source,target:pointer; Height,Pitch,Mirror:integer);
  procedure Draw8(source,target:pointer; Height,Pitch,Mirror:integer);
  procedure XDraw(source,target:pointer; Height,Pitch,Mirror:integer;const pal);
  procedure XDrawRect(source,target:pointer; Pitch,Mirror:integer;const Rect:TRect;const pal);
  procedure XDrawBlend(source,target:pointer; Height,Pitch,Mirror:integer;const pal);
  procedure XDrawBlendRect(source,target:pointer; Pitch,Mirror:integer;const Rect:TRect; const pal);
 end;

function SamePalette(const a,b:TPalette32):boolean;
procedure CompressDib(DIB:pointer; Width,Height,Pitch,Transparent:integer; Stream:TStream);

implementation

//----------------------------------------------------------------------------//

function SamePalette(const a,b:TPalette32):boolean;
const
 ColorMask=$FFFFFF;
var
 x:integer;
begin
 for x:=0 to 255 do begin
  if (a[x] and ColorMask)<>(b[x] and ColorMask) then begin
   Result:=False;
   exit;
  end;
 end;
 Result:=True;
end;

procedure CompressDib(DIB:pointer; Width,Height,Pitch,Transparent:integer; Stream:TStream);
var
 x,y:integer;
 p:pchar;
 c:char;
 Temp:TMemoryStream;
 nul:integer;
 cpy:string;

 procedure SaveLen(Stream:TStream; len:cardinal);
 var
  s:string;
 begin
  s:=chr(len and 127);
  while len>127 do begin
   len:=len shr 7;
   s:=chr(128+(len and 127))+s;
  end;
  Stream.WriteBuffer(s[1],length(s));
 end;

 procedure SaveCpy;
 begin
  if Temp.Size=0 then SaveLen(Temp,0); // 0 nul
  SaveLen(Temp,Length(cpy));
  Temp.WriteBuffer(cpy[1],length(cpy));
 end;

begin
 Temp:=TMemoryStream.Create;
 p:=DIB;
 if Pitch<0 then dec(p,(Height-1)*Pitch);// else inc(p,Pitch);
 for y:=0 to Height-1 do begin
  //dec(p,Pitch);
  nul:=0;
  cpy:='';
  for x:=0 to Width-1 do begin
   c:=p[x];
   if ord(c)=Transparent then begin
    if (nul=0)and(cpy<>'') then begin
     SaveCpy;
     cpy:='';
    end;
    inc(nul);
   end else begin
    if (nul>0) then begin
     SaveLen(Temp,nul);
     nul:=0;
    end;
    cpy:=cpy+c;
   end;
  end; // for x
  if cpy<>'' then SaveCpy;
  SaveLen(Stream,Temp.Size);
  Stream.CopyFrom(Temp,0);
  Temp.Clear;
  inc(p,Pitch);
 end; // for y
end;

//----------------------------------------------------------------------------//

function TADKCompressedDIB.GetLen:integer;
begin
 result:=0;
 while src^>#127 do begin
  inc(result,ord(src^) and 127);
  result:=result shl 7;
  inc(src);
  dec(len);
 end;
 inc(Result,ord(src^));
 inc(src);
 dec(len);
end;

procedure TADKCompressedDIB.Draw1(source,target:pointer; Height,Pitch,Mirror:integer);
var
 y:integer;
 pix:pchar;
 w,i:integer;
begin
 src:=source;
 for y:=0 to Height-1 do begin
  pix:=target;
  len:=getLen;
  while len>0 do begin
   inc(pix,Mirror*GetLen);
   w:=getLen;
   dec(len,w);
   for i:=0 to w-1 do begin
    pix^:=#1;//src^;
    inc(src);
    inc(pix,Mirror);
   end;
  end;
  inc(Cardinal(target),Pitch);
 end;
end;

procedure TADKCompressedDIB.Draw8(source,target:pointer; Height,Pitch,Mirror:integer);
var
 y:integer;
 pix:pchar;
 w,i:integer;
begin
 src:=source;
 for y:=0 to Height-1 do begin
  pix:=target;
  len:=getLen;
  while len>0 do begin
   inc(pix,Mirror*GetLen);
   w:=getLen;
   dec(len,w);
   for i:=0 to w-1 do begin
    pix^:=src^;
    inc(src);
    inc(pix,Mirror);
   end;
  end;
  inc(Cardinal(target),Pitch);
 end;
end;

// generic
procedure TADKCompressedDIB.XDraw(source,target:pointer; Height,Pitch,Mirror:integer;const pal);
var
 y:integer;
 pix:pointer;
 w,i:integer;
begin
 Mirror:=ADKScreen.BPP*Mirror;
 src:=source;
 for y:=0 to Height-1 do begin
  pix:=target;
  len:=getLen;
  while len>0 do begin
   inc(cardinal(pix),Mirror*GetLen);
   w:=getLen;
   dec(len,w);
   if ADKScreen.BPP=BPP32 then begin
    for i:=0 to w-1 do begin
     TPixel32(pix^):=TPalette32(pal)[ord(src^)];
     inc(src);
     inc(cardinal(pix),Mirror);
    end;
   end else begin
    for i:=0 to w-1 do begin
     TPixel16(pix^):=TPalette16(pal)[ord(src^)];
     inc(src);
     inc(cardinal(pix),Mirror);
    end;
   end;
  end;
  inc(Cardinal(target),Pitch);
 end;
end;

procedure TADKCompressedDIB.XDrawRect(source,target:pointer; Pitch,Mirror:integer;const Rect:TRect;const pal);
var
 y:integer;
 pix:pointer;
 w:integer;

 function expand:pchar;
 var
  x,i:integer;
 begin
  result:=@src[len];
  x:=0;
  while len>0 do begin
   i:=getLen;
   inc(x,i);
   inc(cardinal(pix),i*Mirror);
   w:=getLen;
   dec(len,w);
   if ADKScreen.BPP=BPP32 then begin
    for i:=0 to w-1 do begin
     if x>=Rect.Right then exit;
     if (x>=Rect.Left) then TPixel32(pix^):=TPalette32(pal)[ord(src^)];
     inc(src);
     inc(cardinal(pix),Mirror);
     inc(x);
    end;
   end else begin
    for i:=0 to w-1 do begin
     if x>=Rect.Right then exit;
     if (x>=Rect.Left) then TPixel16(pix^):=TPalette16(pal)[ord(src^)];
     inc(src);
     inc(cardinal(pix),Mirror);
     inc(x);
    end;
   end;
  end;
 end;

begin
 Mirror:=ADKScreen.BPP*Mirror;
 if (Rect.Left>Rect.Right)or(Rect.Bottom<Rect.Top) then exit;
 src:=source;
 for y:=0 to Rect.Top-1 do begin
  inc(src,getLen);
  inc(Cardinal(target),Pitch);
 end;
 for y:=Rect.Top to Rect.Bottom-1 do begin
  pix:=target;
  len:=getLen;
  src:=expand;
  inc(Cardinal(target),Pitch);
 end;
end;

procedure TADKCompressedDIB.XDrawBlend(source,target:pointer; Height,Pitch,Mirror:integer;const pal);
var
 pix:pointer;
 tmp:cardinal;
 y,w,i:integer;
begin
 Mirror:=ADKScreen.BPP*Mirror;
 src:=source;
 for y:=0 to Height-1 do begin
  pix:=target;
  len:=getLen;
  while len>0 do begin
   inc(cardinal(pix),Mirror*GetLen);
   w:=getLen;
   dec(len,w);
   if ADKScreen.BPP=BPP32 then begin
    for i:=0 to w-1 do begin
     tmp:=TPixel32(pix^) and HalfMask32;
     inc(tmp,TPalette32(pal)[ord(src^)] and HalfMask32);
     TPixel32(pix^):=tmp shr 1;
     inc(src);
     inc(cardinal(pix),Mirror);
    end;
   end else begin
    for i:=0 to w-1 do begin
     tmp:=TPixel16(pix^) and ADKScreen.HalfMask;
     inc(tmp,TPalette16(pal)[ord(src^)] and ADKScreen.HalfMask);
     TPixel16(pix^):=tmp shr 1;
     inc(src);
     inc(cardinal(pix),Mirror);
    end;
   end;
  end;
  inc(Cardinal(target),Pitch);
 end;
end;

procedure TADKCompressedDIB.XDrawBlendRect(source,target:pointer; Pitch,Mirror:integer; const Rect:TRect; const pal);
var
 pix:pointer;
 y,w:integer;

 function expand:pchar;
 var
  x,i:integer;
 begin
  result:=@src[len];
  x:=0;
  while len>0 do begin
   i:=getLen;
   inc(x,i);
   inc(cardinal(pix),i*Mirror);
   w:=getLen;
   dec(len,w);
   if ADKScreen.BPP=BPP32 then begin
    for i:=0 to w-1 do begin
     if x>Rect.Right then exit;
     if (x>=Rect.Left) then TPixel32(pix^):=((TPalette32(pal)[ord(src^)] and HalfMask32)+(TPixel32(pix^) and HalfMask32)) shr 1;
     inc(src);
     inc(cardinal(pix),Mirror);
     inc(x);
    end;
   end else begin
    for i:=0 to w-1 do begin
     if x>Rect.Right then exit;
     if (x>=Rect.Left) then TPixel16(pix^):=((TPalette16(pal)[ord(src^)] and ADKScreen.HalfMask)+(TPixel16(pix^) and ADKScreen.HalfMask)) shr 1;
     inc(src);
     inc(cardinal(pix),Mirror);
     inc(x);
    end;
   end;
  end;
 end;

begin
 Mirror:=ADKScreen.BPP*Mirror;
 src:=source;
 for y:=0 to Rect.Top-1 do begin
  inc(src,getLen);
  inc(Cardinal(target),Pitch);
 end;
 for y:=Rect.Top to Rect.Bottom-1 do begin
  pix:=target;
  len:=getLen;
  src:=expand;
  inc(Cardinal(target),Pitch);
 end;
end;

end.