graph64.pas

一款RPG游戏的引擎可以自己制作一款RPG游戏的引擎可以自己制作

begin
  FreeMem( FData);
  FreeMem( FLines);
  FData:= nil;
  FLines:= nil;
  FData:= nil
end;

function TCompressBitmap. GetScanLine( row: Longint): pointer;
var xx,size: Longint;
    temp: pointer;
begin
  if row=0 then result:= FData else
  begin
    size:= 0;
    for xx:=0 to row-1 do Inc( size, LineSize^[xx]);
    temp:= FData;
    asm
      mov eax, temp
      add eax, size
      mov temp, eax
    end;
    result:= temp;
  end;
end;


{ ------------------------ Start code for TBitmap64 ------------------ }
Constructor TBitmap64. Create( xres:Longint; yres:Longint; pixf: TPixelFormat);
begin
  WasAssigned:= false;
  Palette:= nil;
  bmWidth:=  0;
  bmHeight:= 0;
  bmBitsPixel:= pixf;
  transparent:= false;
  transparentColor:= 0;
  bmBpp:= (bmBitsPixel + 7) shr 3;
  bmBits:= nil;
  SetSize( xres, yres);

// GetMem( bmBits, bmWidth*bmHeight*bmBpp);
  linePitch:= bmBpp*bmWidth; //set default line pitch
   case bmBitsPixel of
   pf15bit: begin       {normal 555 format for 15bpp resolutions}
             RBitMask:= $7c00;
             GBitMask:= $03e0;
             BBitMask:= $001f;
             RStart:= 10;
             GStart:= 5;
             BStart:= 0;
            end;
   pf16bit: begin       {normal 565 format for 16bpp resolutions}
             RBitMask:= $f800;
             GBitMask:= $07e0;
             BBitMask:= $001f;
             RStart:= 11;
             GStart:= 5;
             BStart:= 0;
            end;
   pf24bit,pf32bit: begin        { 888 format for 24bpp, a888 format for 32bit, a-alpha,not used yet}
             RBitMask:= $ff0000;
             GBitMask:= $00ff00;
             BBitMask:= $0000ff;
             RStart:= 16;
             GStart:= 8;
             BStart:= 0;
            end;
  end;
end;

Constructor TBitmap64.AssignData( xres,yres: Longint; pixf: TPixelFormat;data: pointer;LineSize: longint);
begin
  WasAssigned:= true;
  bmWidth:=  xres;
  bmHeight:= yres;
  bmBitsPixel:= pixf;
  transparent:= false;
  transparentColor:= 0;
  bmBpp:= (bmBitsPixel + 7) shr 3;
  linePitch:= LineSize;
  bmBits:= data;
  case bmBitsPixel of
    pf15bit: begin       {normal 555 format for 15bpp resolutions}
               RBitMask:= $7c00;
               GBitMask:= $03e0;
               BBitMask:= $001f;
               RStart:= 10;
               GStart:= 5;
               BStart:= 0;
             end;
    pf16bit: begin       {normal 565 format for 16bpp resolutions}
               RBitMask:= $f800;
               GBitMask:= $07e0;
               BBitMask:= $001f;
               RStart:= 11;
               GStart:= 5;
               BStart:= 0;
             end;
    pf24bit,pf32bit:
             begin        { 888 format for 24bpp, a888 format for 32bit, a-alpha,not used yet}
               RBitMask:= $ff0000;
               GBitMask:= $00ff00;
               BBitMask:= $0000ff;
               RStart:= 16;
               GStart:= 8;
               BStart:= 0;
             end;
  end;
end;

Destructor TBitmap64. Destroy;
begin
if not WasAssigned then  //only when TBitmap was created
begin
{$IFDEF apFPC} FreeMem( bmBits, sizeOf(bmBits^));{$ELSE}
 if bmBits<>nil then FreeMem( bmBits);
 {$ENDIF}
 bmBits:= nil;
end;

{$IFNDEF apFPC}
 inherited destroy;
{$ENDIF}
end;

procedure TBitmap64. BuildColors;
{NEED funct}
var i: Longint;
    f: file of byte;
begin

  if Not Assigned(Palette) then New( Palette);
  
  AssignFile( f,'default.pal'); //this is not ideal way
  Reset( f);
  for i:= 0 to 255 do
  with Palette^[i] do
  begin
     Read( f, r);
     Read( f, g);
     Read( f, b);
//     r:= r*4;
//     g:= g*8;
//     r:= r*4;
     r:= r*4;
     g:= g*4;
     b:= b*4;
  end;
  CloseFile( f);

{  for i:= 0 to 255 do  //this one create "universal" 3-3-2 palette
  with Palette^[i] do
    begin
      r:= (i shr 5) *36;
      g:= ((i shr 2) and 7) * 36;
      b:= ( i and 3) *85;
    end;
}
end;

procedure TBitmap64. DrawCompressed( x,y: integer; b: TCompressBitmap);
var xx,yy: integer;
    p: PWord;
    pb: PByte;
begin

for yy:= 0 to b.height-1 do
begin
  xx:= 0;
  pb:= b.ScanLine[yy];     //source
  p:= ScanLine[yy+y];    //destation
  inc( p, x);
  repeat
    if (pb^ and 128)=128 then
    begin
      inc( p, pb^ and 127);
      inc( xx, pb^ and 127);
      inc( pb);
    end
    else
    begin
      inc( xx, pb^);
       asm
         push esi
         push edi

         mov esi, pb
         mov edi, p
         xor ecx, ecx
         mov cl, [esi]
         inc esi
         rep movsw

         pop edi
         pop esi
       end;
       inc( p, pb^);
       inc( pb, pb^*2);
       inc( pb);
    end;
    
  until xx>=b.Width;
end;

end;
                                                              
function TBitmap64. CompressToFile( filename: string):boolean;
type
  PLine=^TLine;
  TLine=array[0..0]of Word;

var temp: Pointer;
    Line: PLine;
    P,P1: PWord;
    xx,yy,x: Longint;
    z: byte;
    counter: word;
    Start: longint;
    f: File;
{
 0 -transparent color
 12 0 0 0 0 0 12 12 12 0 0 0 3
 b   w   b           w  b   w  w  w
 1, 12,  5 and  127, 0, 3, 12,12,12,
}
begin
 if (not transparent) or (height<1) then begin result:= false;exit;end;
 result:= true;

 AssignFile( f, filename);
 rewrite(f,1);

 GetMem( temp, Height*2);  //memory for line offsets
 Line:= temp;

BlockWrite( f, Width, 4);
BlockWrite( f, height, 4);
start:= FilePos(f);
BlockWrite( f, temp^, Height*2);
for yy:= 0 to height-1 do
begin
  p:= ScanLine[yy];
  x:= 0;
  counter:= 0;
  repeat
    If p^= TransparentColor then
    begin
      z:= 0;
      while (p^=TransparentColor)and(x<Width)and(z<127) do begin Inc( p);inc(z);inc(x);end;
      Inc( counter, 1);
      z:= z or 128;
      BlockWrite( f, z, 1);
    end
    else
    begin
      z:= 0;
      p1:= p;
      while (p^<>TransparentColor)and(x+z<Width)and(z<127) do begin Inc(p);inc(z);end;
      Inc( counter, z*2+1);
      BlockWrite( f, z, 1);
      p:= p1;
      for xx:=1 to z do
      begin
        BlockWrite( f, p^, 2);
        inc( p);inc(x);
      end;
    end;
  until x>=Width;
  Line^[yy]:= counter;
end;

  Seek(f, start);
  BlockWrite( f, temp^, height*2);
  FreeMem( temp);
  CloseFile(f);
end;

procedure TBitmap64. FlipVertical; {only for pf15bit or pf16bit or pf32bit or pf8bit}
var s,d: PWord;
    yy: Longint;
    temp: pointer;
begin

GetMem( temp, width*bmbpp);
for yy:=0 to (height-1)div 2 do
begin
 s:= scanline[yy];
 d:= scanline[height-1-yy];
 move( s^, temp^, width*bmBpp);
 move( d^, s^, width*bmBpp);
 move( temp^, d^, width*bmBpp);
end;

FreeMem( temp);
end;


procedure TBitmap64. FlipHorizontal; {only for pf15bit or pf16bit}
{Flip image horizontal (mirror)}
var s,d: PWord;
    s1,d1:PLongint;
    xx,yy: Longint;
begin
if (bmBitsPixel=pf15bit)or(bmBitsPixel=pf16bit)then
  begin
    for yy:= 0 to height-1 do
      begin
        s:= ScanLine[yy];
        d:= ScanLine[yy];
        Inc( d, width-1);
        for xx:= 0 to  (width-1) div 2 do
          begin
            SwapW( s^,d^);
            inc( s);dec( d);
          end;
      end;
  end;

if bmBitsPixel=pf32bit then
  begin
    for yy:= 0 to Height-1 do
      begin
        s1:= ScanLine[yy];
        d1:= ScanLine[yy];
        Inc( d1, Width-1);
        For xx:= 0 to (Width-1) div 2 do
          begin
            SwapL( s1^,d1^);
            Inc( s1);Dec(d1);
          end;
      end;

  end;

end;

procedure TBitmap64. LoadFromRSBFile( s: string);
{RSB - Rainbow Six Bitmap}
var f: file;
    lx,ly: Longint;

begin
  if self is TScreen64 then
   begin
     raise exception.create('You can''t load images into TScreen64!!!');
     exit;
   end;

if (bmBitsPixel= pf16bit)or(bmBitsPixel= pf15bit) then else exit;

assignFile( f, s);
 FileMode:= 0;  {read only}
 reset( f ,1);
 seek( f, 4);
 BlockRead( f, lx, 4);
 BlockRead( f, ly, 4);
 seek( f, 32); {to start data}
 bmWidth:= lx;
 bmHeight:= ly;
 ReAllocMem( bmBits, Longint( bmBpp*bmWidth*bmHeight) );  {for new resolution of bitmap}
 BlockRead( f, bmBits^, bmWidth*bmHeight*bmBpp);
CloseFile( f);

end;
procedure TBitmap64. SaveToTGAFile( s: string);
var f: file;
    r,g,b: Byte;
    w,wx,wy: word;
    xx,yy: Longint;
    TempData: pointer;
    target,p: PWord;
    p1:PRGB32;

begin
  AssignFile( f, s);
  Rewrite( f,1); {file exists? WHAT now??!?! exception??}
  w:= 0;
  BlockWrite( f, w, 2);
  w:= 2;  {uncompressed tgaformat}
  BlockWrite( f, w, 2);
  w:= 0;
  for xx:= 0 to 3 do BlockWrite( f, w, 2); {fill header with zero's}
  wx:= bmWidth;
  wy:= bmHeight;
  BlockWrite( f ,wx, 2);
  BlockWrite( f, wy, 2);
  w:= 16;
  BlockWrite( f, w, 2); {16 bit tga format}
  b:= 0;
  BlockWrite( f, b, 0);

  FlipVertical;
  GetMem( TempData, bmWidth*bmHeight*2{bmbpp});
  target:= TempData;

  if bmBpp=2 then //for 15/16 bit bpp
  begin
    if pixelFormat=pf16bit then w:= GStart +1 else w:= GStart;
    for yy:= 0 to bmHeight-1 do
      begin
        p:= scanline[yy];
        for xx:= 0 to bmWidth-1 do
          begin
            r:= (p^ and RBitMask) shr RStart;
            g:= (p^ and GBitMask) shr w;
            b:= p^ and BBitMask;
            target^:= (r shl 10) or (g shl 5) or b;
            Inc( target);
            Inc( p);
          end;
      end;
  end;

  if bmBpp=4 then  //for 32bit bpp
  begin
    for yy:= 0 to bmHeight-1 do
      begin
        p1:= scanline[yy];
        for xx:= 0 to bmWidth-1 do
          begin
            r:= p1^.r shr 3;
            g:= p1^.g shr 3;
            b:= p1^.b shr 3;
            target^:= (r shl 10) or (g shl 5) or b;
            Inc( target);
            Inc( p1);
          end;
      end;
  end;

  BlockWrite( f, TempData^, 2*(bmWidth)*(bmHeight));
  FreeMem ( TempData);

  CloseFile( f);
  FlipVertical;
end;

procedure TBitmap64. LoadFromBMPFile( s: string);
{Only 15 and 24 bpp BMP files supported, now!!}
type BitmapHeader= packed record
       Info: word;
       FileSize: cardinal;
       Res1,Res2: word;
       OffsetBits: cardinal;
     end;

type BitmapInformationHeader= packed record
       HeaderSize,
       Width,
       Height: cardinal;
       Row,  { always zero}
       BitCount: word; {1,4,8,24 (bits per pixel)}
       CompresionType,
       ImageSize,
       XPelsPerMeter,
       YPelsPerMeter,
       ColorsUsed,
       ColorsImportant: cardinal
     end;

var f: file;
    BHeader: BitmapHeader;
    BInformation: BitmapInformationHeader;
    xx,space,BMPbpp: Longint;
    source,destation: PByte;
    Data: Pointer;
begin
  if self is TScreen64 then
   begin
     raise exception.create('You can''t load images into TScreen64!!!');
     exit;
   end;

  if not FileExists( s) then exit;
  AssignFile( f, s);
  Reset(f, 1);
  BlockRead( f, BHeader, SizeOf(BHeader));