graph64.pas

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

  BlockRead( f, BInformation, SizeOf(BInformation));
  {$ifdef debug}
  with BInformation do
  begin
   Write( DebugFile, ImageSize,' ',Width, ' ',Height,' ', BitCount);
   Writeln( DebugFile, Format( 'Loading bmp: %s, %dx%dx%d image size: %d', [s,width,height,bitcount,ImageSize]));
  end;
  {$endif}
  seek( f, BHeader.OffsetBits);
  SetSize( BInformation.Width, BInformation.Height);
  GetMem( Data, BInformation.ImageSize);
  blockread( f, Data^, BInformation.ImageSize);
  
  if BInformation.BitCount=16 then BInformation.BitCount:= 15; //this is for non standart 15 bpp BMP files
  BMPbpp:= ((BInformation.BitCount+ 7) shr 3);
  if (BInformation.Width mod 4 <>0)and(bmHeight>1) then
  begin
    space:= BInformation. Width mod 4;
    source:= data;
    destation:= data;
    for xx:= 0 to bmHeight-1 do
      begin
       move(source^,destation^,bmWidth*BMPbpp);
       inc( source, bmWidth*BMPbpp+space);
       inc( destation,bmWidth*BMPbpp);
      end;
  end;
  linePitch:= bmBpp*bmWidth;
  g64ConvertBitmap( Cardinal( Data), Cardinal( bmBits), bmWidth*bmHeight  , BInformation.BitCount, bmBitsPixel);
  if (BInformation.BitCount<>15) then SwapRGB;
  FreeMem( Data);
  CloseFile( f);
end;

{ ------------------------- Conversion functions --------------------------}
{ -------------------------------------------------------------------------}

procedure g64Convert24to16( source, destation, size: cardinal);
{convert 24 bit to 16 bit}
var s: ^TRGB24;
    d: PWord;
    xx: cardinal;
begin
 s:= Pointer( source);d:= Pointer( destation);
 for xx:= 0 to size-1 do
 begin
   d^:= ((s^.r div 8) shl 11)+((s^.g div 4)shl 5)+(s^.b div 8);
   inc( s);
   inc( d);
 end;
end;

procedure g64Convert24to15( source, destation, size: cardinal);
{convert 24 bit to 15 bit}
var s: ^TRGB24;
    d: PWord;
    xx: cardinal;

begin
 s:= Pointer( source);d:= Pointer( destation);
 for xx:= 0 to size-1 do
 begin
   d^:= ((s^.r div 8) shl 10)+((s^.g div 8)shl 5)+(s^.b div 8);
   inc( s);
   inc( d);
 end;
end;

procedure g64Convert32to16( source, destation, size: cardinal);
{convert 32 bit to 16 bit}
var s: PByte;
    d: PWord;
    r,g,b: byte;
    xx: cardinal;

begin
 s:= Pointer( source);d:= Pointer( destation);
 for xx:= 0 to size-1 do
   begin
     b:= s^;Inc( s);
     g:= s^;Inc( s);
     r:= s^;Inc( s);
     Inc( s);  {skip alpha}
     d^:= ((r div 8) shl 11)+((g div 4)shl 5)+(b div 8);
     inc( d);
   end;
end;

procedure g64Convert32to15( source, destation, size: cardinal);
{convert 32 bit to 15 bit}
var s: PByte;
    d: PWord;
    r,g,b: byte;
    xx: cardinal;

begin
 s:= Pointer( source);d:= Pointer( destation);
 for xx:= 0 to size-1 do
   begin
     b:= s^;Inc( s);
     g:= s^;Inc( s);
     r:= s^;Inc( s);
     Inc( s);  {skip alpha}
     d^:= ((r div 8) shl 10)+((g div 8)shl 5)+(b div 8);
     inc( d);
   end;
end;

procedure g64Convert15to16( source, destation, size: cardinal);
{convert 15 bit to 16 bit}
var s,d: PWord;
    r,g,b: byte;
    xx: cardinal;
begin
 s:= Pointer( source);d:= Pointer( destation);
 for xx:= 0 to size-1 do {convert 15 bit to 16 bit}
  begin
    r:= (s^ shr 10) and 31;  {shr 10}
    g:= ((s^ shr 5) and 31);  {shr 5}
    b:= s^ and 31;
//    d^:= (r shl 10) or (g shl 5) or b;
    d^:= (r shl 11) or (g shl 6) or b;
    Inc( s);
    inc( d);
 end;
end;

procedure g64Convert16to15( source, destation, size: cardinal);
{convert 16 bit to 15 bit}
var s,d: PWord;
    r,g,b: byte;
    xx: cardinal;
begin
  s:= Pointer( source);d:= Pointer( destation);
  for xx:= 0 to size-1 do {convert 16 bit to 15 bit}
    begin
      r:= (s^ shr 11) and 31;  {shr 10}
      g:= ((s^ shr 5) and 31);  {shr 5}
      b:= s^ and 31;
      d^:= (r shl 10) or (g shl 5) or b;
      Inc( s);
      inc( d);
    end;
end;

procedure g64Convert24to32( source,destation, size: cardinal);
{Convert 24 bit to 32 bit}
var s: PRGB24;
    d: PLongint;
    xx: Cardinal;
begin
  s:= Pointer(Source); d:= Pointer(destation);
  for xx:= 0 to size-1 do
    begin
      d^:=(s^.r shl 16) or (s^.g shl 8) or (s^.b);
      Inc( s);
      Inc( d);
    end;
end;

procedure g64Convert15to32( source,destation, size: cardinal);
{Convert 15 bit to 32 bit}
var s: PWord;
    d: PLongint;
    r,g,b: byte;
    xx: Cardinal;
begin
  s:= Pointer(Source); d:= Pointer(destation);
  for xx:= 0 to size-1 do
    begin
      r:= (s^ shr 10) and 31;
      g:= ((s^ shr 5) and 31);
      b:= s^ and 31;
      d^:= (r shl 19) or (g shl 11) or (b shl 3);
      Inc( s);
      Inc( d);
    end;
end;

procedure g64Convert16to32( source,destation, size: cardinal);
{Convert 16 bit to 32 bit}
var s: PWord;
    d: PLongint;
    r,g,b: byte;
    xx: Cardinal;
begin
  s:= Pointer(Source); d:= Pointer(destation);
  for xx:= 0 to size-1 do
    begin
      r:= (s^ shr 11) and 31;
      g:= ((s^ shr 5) and 31);
      b:= s^ and 31;
      d^:= (r shl 19) or (g shl 11) or (b shl 3);
      Inc( s);
      Inc( d);
    end;
end;


procedure g64ConvertBitmap( source, destation, size: cardinal; fromBits, toBits: byte);
begin

  if (fromBits= 32) then
    case toBits of
      pf15bit: g64Convert32to15( source, destation, size);
      pf16bit: g64Convert32to16( source, destation, size);
      pf32bit:
        asm
          push esi
          push edi
          mov esi, source
          mov edi, destation
          mov ecx, size
          rep movsd
          pop edi
          pop esi
        end;
    end;
  if (fromBits= 24) then
    case toBits of
      pf15bit: g64Convert24to15( source, destation, size);
      pf16bit: g64Convert24to16( source, destation, size);
      pf32bit: g64Convert24to32( source, destation, size);
    end;
  if (fromBits= 16) then
    case toBits of
      pf15bit: g64Convert16to15( source, destation, size);
      pf16bit:
        asm
          push esi
          push edi
          mov esi, source
          mov edi, destation
          mov ecx, size
          rep movsw
          pop edi
          pop esi
        end;
      pf32bit: g64Convert16to32( source, destation, size);
    end;
  if (fromBits= 15) then
    case toBits of
      pf15bit:
        asm
          push esi
          push edi
          mov esi, source
          mov edi, destation
          mov ecx, size
          rep movsw
          pop edi
          pop esi
        end;
      pf16bit: g64Convert15to16( source, destation, size);
      pf32bit: g64Convert15to32( source, destation, size);
    end;
end;

procedure TBitmap64. LoadFromTGAFile( s: string);
var f: file;
    xx,yy: Longint;
    wx,wy: word;
    TGAFormat,TGAColors,AnyByte{,AnyByte2}: byte;
    TempData: pointer;

    SizeToLoad,SizeToSave: cardinal;

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

{$IFDEF debug}
 write(  DebugFile, Format( 'Loading %s ',[s]));
{$ENDIF}

assignFile( f, s);
 reset( f,1);
 seek( f, 2);
 BlockRead( f, TGAFormat, 1);
{ seek(f, 7);
 BlockRead(f, AnyByte2,1);}
 seek( f, 12);
 BlockRead( f, wx, 2);
 BlockRead( f, wy, 2);
 BlockRead( f, TGAColors, 1);
 Blockread( f, AnyByte, 1); 
 {$IFDEF debug100}
   write( DebugFile, ' "Byte:=',AnyByte2,'" ');
 {$ENDIF}
 xx:= wx;
 yy:= wy;
 bmWidth:= xx;
 bmHeight:= yy;

{$IFDEF debug}
 write(  DebugFile, Format( '%dx%d...Tga format=%d',[bmWidth,bmHeight,TgaFormat]));
{$ENDIF}

SizeToLoad:= 1;
if TGAFormat = 2 then  {only uncopressed RGB}
 begin
  case TGAColors of
    32:    SizeToLoad:= 4;
    24:    SizeToLoad:= 3;
    15,16: SizeToLoad:= 2;
    8:     SizeToLoad:= 1;
  end;

  {$WARNINGS off}  // be quiet Delphi
   SizeToLoad:= SizeToLoad * xx * yy;
  {$WARNINGS on}
  SizeToSave:= bmBpp * xx * yy;

  ReAllocMem( bmBits, SizeToSave);
  GetMem( tempData, SizeToLoad);
  BlockRead( f, tempData^, SizeToLoad);

  If TGAColors= 16 then TGAColors:= 15;
  linePitch:= bmBpp*bmWidth;
  g64ConvertBitmap( Cardinal( TempData), Cardinal( bmBits), xx*yy, TGAColors, bmBitsPixel);

  freeMem( tempData);
  if AnyByte and 32= 32 then FlipVertical;
  if tgacolors=24 then swaprgb;
 {$ifndef apGDI}
  FlipVertical;
 {$endif}
 end; // end of uncompressed TGA
{$IFDEF debug}
 writeln(  DebugFile, 'ok');
{$ENDIF}

 CloseFile( f);
end;

procedure TBitmap64. SetPixelFormat;
var temp: Longint;
begin
 bmBitsPixel:= value;
 temp:= (bmBitsPixel + 7) shr 3;
 if temp<>bmBpp then
    begin
     ReAllocMem( bmBits, temp*bmWidth*bmHeight)
     {now we must convert from actual to new format (e.g: 24 to 16 bits...)}
    end;
 bmBpp:= temp;
end;

function TBitmap64. GetPixelFormat;
begin
 result:= bmBitsPixel
end;

function TBitmap64. GetScanLine( row: Longint): pointer;
begin
{$IFDEF apGDI}
  if self is TScreen64 then
    with self as TScreen64 do
    begin
      result:= BackBuffer.ScanLine[row];
    end
    else
      result:= pointer( Longint( bmBits) + (bmHeight-1-row)*{bmBpp*}linePitch{bmWidth});
{$ELSE}

//this is for other platforms
  result:= pointer( Longint( bmBits) + row{*bmBpp}*linePitch{bmWidth});
{$ENDIF}
end;

procedure TBitmap64. SetSize( ValueX, ValueY: integer);
begin
  if (ValueX=bmWidth)and(ValueY=bmHeight) then exit; //nothing to change

  if bmBits<>nil then FreeMem( bmBits);   //release old picture data
  bmWidth:= ValueX;
  bmHeight:= ValueY;
  linePitch:= bmBpp*bmWidth;
  GetMem( bmBits, bmWidth*bmHeight*bmBpp); //new size

end;

procedure TBitmap64. SetWidth( value: Longint);
//use this when you changing ONLY bitmap width
//if you changing width and height use SetSize() function
begin
  if (WasAssigned)or(value=bmWidth) then exit; //You can't do it with assigned data...
  SetSize( value, bmHeight);
end;

procedure TBitmap64. SetHeight( value: Longint);
begin
  if (WasAssigned)or(value=bmHeight) then exit;
  SetSize( bmHeight, value);
end;

function TBitmap64. UnpackRGB ( what: Longint):TRGB;
begin
 case bmBitsPixel of
   pf15bit:with result do
           begin
             r:= (what shr 10)shl 3;
             g:= ((what shr 5)and 31)shl 3;
             b:= (what and 31) shl 3;
           end;
   pf16bit:with result do
           begin
             r:= (what shr 11)shl 3;
             g:= ((what shr 5)and 63)shl 2;
             b:= (what and 31) shl 3;
           end;
   pf24bit,pf32bit:
           with result do
           begin
             r:= what shr 16;
             g:= (what shr 8) and 255;
             b:= what and 255;
           end;
 else
   begin
     result.r:= 0;result.g:= 0;result.b:= 0;
   end;
 end; //case

end; //function

function FindColor(r,g,b: Integer;pal:PPalette64): Byte;
{Finds the color (8bit) number for a given  color(RGB format)}
var l,i: Integer;
    n: longint;
begin
  l:=10000;
  result:= 0;
  for i:=0 to 255 do
  begin
    n:= (r-pal^[i].r)*(r-pal^[i].r) + (g-pal^[i].g)*(g-pal^[i].g) + (b-pal^[i].b)*(b-pal^[i].b);
    if n<l then
    begin
      result:=i;
      l:=n;
    end;
  end;
end;

Function TBitmap64. RGB( r,g,b: byte): Longint;
begin
  case bmBitsPixel of
          pf8bit:  result:= FindColor( r,g,b, Palette);
          pf15bit: result:= ((r div 8) shl 10)+((g div 8)shl 5)+((b div 8));
          pf16bit: result:= ((r div 8) shl 11)+((g div 4)shl 5)+((b div 8));
    pf24bit,pf32bit: result:= (r shl 16) + (g shl 8) + b;
  else
    result:= 0;
  end;
end;

{$ifdef apGDI}
function  TBitmap64.WinColor( color: TColor): Integer;
begin
  result:= RGB( (Color mod $100) , ((color div $100) mod $100) , (color div $10000));
//  result:=RGB( GetRValue( Color)*32, GetGValue( Color)*23, GetBValue( Color)*32);
end;
{$endif}


Function TBitmap64. GetPixelPtr( x,y: Longint): Pointer;
var p:Pointer;
    start: Longint;
begin
  result:= nil;  //zero if pixel is out of space
  start:= x;
  if (x<0)or(y<0)or(x>=bmWidth)or(y>=bmHeight) then
  else
  begin