graph64.pas

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

{NEED ASM,MMX}
var xx,yy: Longint;
    p: PWord;
    p1: PLongint;
begin
 if x>x1 then swapL( x,x1);
 if y>y1 then swapL( y,y1);

 if (x1<0)or(x>=bmWidth)or(y1<0)or(y>=bmHeight) then exit;

 if x<0 then x:= 0;
 if x1>= bmWidth then x1:= bmWidth-1;

 if y<0 then y:= 0;
 if y1>= bmHeight then y1:= bmHeight-1;

 case bmBitsPixel of
   pf8bit:
     begin
       for yy:= y to y1 do
       begin
         p:= ScanLine[yy];
         FillChar( p^, x1-x, Color);
       end;
     end;
   pf16bit,pf15bit:
     begin
       for yy:= y to y1 do
         begin
           p:= ScanLine[yy];
           {$IFDEF apFPC}p:=p+x*2;{$ELSE}inc( p, x);{$ENDIF}  {seek to start}
           for xx:= x to x1 do begin p^:= color;{$IFDEF apFPC}p:=p+2;{$ELSE}inc( p);{$ENDIF}end;
         end;
     end;
   pf32bit:
     begin
       for yy:= y to y1 do
         begin
           p1:= ScanLine[yy];
           {$IFDEF apFPC}p1:=p1+x*4;{$ELSE} inc( p1,x);{$ENDIF}
           for xx:= x to x1 do begin p1^:= color;{$IFDEF apFPC}p1:=p1+2;{$ELSE}inc( p1);{$ENDIF}end;
         end;
     end;
 end;//end of case
end;

procedure   TBitmap64.LensBar( x,y,x1,y1,color: Longint);
var yy,size: Longint;
    p:PWord;
    p1: PLongint;
    andMask: word;
    AndMask32: Longint;
begin
  if x>x1 then swapL( x,x1);
  if y>y1 then swapL( y,y1);
  if (x1<0)or(x>=bmWidth)or(y1<0)or(y>=bmHeight) then exit;
       
  if x<0 then x:= 0;  //truncate region to screen
  if x1>= bmWidth then x1:= bmWidth;
  if x1=x then exit;  
  if y<0 then y:= 0;
  if y1>= bmHeight then y1:= bmHeight-1;

  case pixelformat of
    pf15bit:asm mov andmask, 0011110111101111b end;
    pf16bit:asm mov andmask, 1111101111101111b end;
    pf32bit:asm mov AndMask32, 011111110111111101111111b end;
  end;                         

  if pixelformat=pf32bit then
  begin
    for yy:= y to y1 do
      begin
        p1:= ScanLine[yy];
        Inc( p1, x);
        size:= x1-x;
        asm
          push edi
          mov edi, p1
          mov ecx, size
          mov edx, color
          shr edx, 1
          and edx, AndMask32
       @1:mov eax, [edi]
          shr eax, 1
          and eax, AndMask32
          add eax, edx
          stosd
          loop @1
          pop edi
        end;
      end;
  end
  else
    for yy:=y to y1 do
      begin
        p:= ScanLine[yy];
        inc( p, x);  {seek to start}
        size:= x1-x;
        asm
          push edi
          mov edi, p
          mov ecx, size
          mov dx, word ptr color
          shr dx, 1
          and dx, andmask  //compute this color only once
       @1:mov ax,[edi]  //main loop
          shr ax, 1
          and ax, andmask
          add ax, dx
          stosw
          loop @1
          pop edi
        end;
      end;

end;

procedure   TBitmap64. MotionBlur;
{Work in progress...}
var mnemonic: PWord;
    CxSize,
    SizeX: Longint;
    andmask: word;

begin
 mnemonic:= bmBits;
 CxSize:= bmWidth*(bmHeight-1);
 SizeX:= bmWidth;
 case pixelformat of
   pf15bit:asm mov andmask, 0011110111101111b end;
   pf16bit:asm mov andmask, 1111101111101111b end;
 end;
 
asm
     push edi
     push ebx
      mov edi, mnemonic

      mov ecx, CxSize
      mov ebx, SizeX
      shl ebx, 1

@lp1:   xor     edx,edx
        xor     eax,eax

        mov     ax,word ptr [edi]
        mov     dx,word ptr [edi+2]
        shr     eax,1
        shr     edx,1
        and     ax, andmask
        and     dx, andmask
        add     eax,edx

        mov     dx,word ptr [edi-2] // This is bug
        shr     eax,1
        shr     edx,1
        and     ax, andmask
        and     dx, andmask
        add     eax,edx

        mov     dx,word ptr [edi+ebx]  {+SizeX}
        shr     eax,1
        shr     edx,1
        and     ax, andmask
        and     dx, andmask
        add     eax, edx

@lp2:   stosw
        dec     ecx
        jnz     @lp1

     pop ebx
     pop edi
end;
end;

procedure   TBitmap64. SwapRGB;
// swap RGB format to BGR format
// It's not realtime!
var xx,yy,
    temp1,
    r1,g1,b1: Longint;
    r,g,b,
    temp: Word;
begin
case pixelformat of
  pf16bit:
    begin
      for yy:= 0 to height-1 do
        for xx:= 0 to width-1 do
          begin
            temp:= pixels[xx,yy];
            r:= (temp shr 11)and 31;
            g:= ((temp shr 5) and 63)shl 5;
            b:= (temp and 31) shl 11;
            pixels[xx,yy]:= r or g or  b;
          end;
    end; // pf16bit
  pf15bit:
    begin
      for yy:= 0 to height-1 do
        for xx:= 0 to width-1 do
          begin
            temp:= pixels[xx,yy];
            r:= temp shr 10;
            g:= ((temp shr 5) and 31)shl 5;
            b:= (temp and 31) shl 10;
            pixels[xx,yy]:= r or g or b;
          end;
    end; // pf15bit
  pf32bit:
    begin
      for yy:= 0 to height-1 do
        for xx:= 0 to width-1 do
          begin
            temp1:= pixels[xx,yy];
            r1:= (temp1 shr 16)and 255;
            g1:= ((temp1 shr 8) and 255)shl 8;
            b1:= (temp1 and 255) shl 16;
            pixels[xx,yy]:= r1 or g1 or b1;
          end;
    end; //pf32bit
end; //case

end;

procedure   TBitmap64. Antialiasing;
{this is pixel precision anitaliasing => slow, not for real-time effects}
{ Work in progress...}
var yy,xx: Longint;
    s1,s2,s3,s4,d: TRGB;
Function PackRGB( what: TRGB): word;
begin
 result:= (what.r shl 11)or (what.g shl 5) or (what.b);
end;

Function AddRGB( s1,s2: TRGB): TRGB;
begin
 result.r:= s1.r + s2.r;
 result.g:= s1.g + s2.g;
 result.b:= s1.b + s2.b;
end;
Procedure ClearRGB(var s: TRGB);
begin
with s do
 begin
  r:=0;
  g:=0;
  b:=0;
 end;
end;
begin
 if PixelFormat<>pf16bit then exit; //say good bye
 for yy:= 1 to bmHeight-1 do
   begin
     for xx:= 1 to bmWidth-1 do
       begin
         s1:= UnpackRGB( GetPixel( xx,yy));
         s2:= UnpackRGB( GetPixel( xx-1,yy));
         s3:= UnpackRGB( GetPixel( xx+1,yy));
         s4:= UnpackRGB( GetPixel( xx, yy-1));
//         s5:= UnpackRGB( GetPixel( xx, yy+1));
         d:=  AddRGB( AddRGB( s1,s2), AddRGB( s3,s4));
//          d:= AddRGB( AddRGB( s1,s2), s3);

         with d do
           begin
             r:= r div 4;
             g:= g div 4;
             b:= b div 4;
             if r>31 then r:= 31;
             if g>63 then g:= 63;
             if b>31 then b:= 31;
           end;
         PutPixel( xx,yy, PackRGB( d));
       end;
   end;

end;

procedure   TBitmap64. Antialiasing2;
var yy,sizex: Longint;
    s1,s2: PWord;
    AndMask: Word;
    AndMask32: Cardinal;
begin
 if bmbpp<>2 then exit; //say good bye
  case pixelformat of
    pf15bit:
      begin
        asm
          mov andmask,  0011110111101111b
          mov AndMask32, 0111101111011110011110111101111b
        end;
      end;
    pf16bit:
      begin
        asm
          mov andmask, 1111101111101111b
          mov AndMask32, 1111011111011111111101111101111b //stupid delphi!!
        end;
      end;
    pf32bit:
      asm mov AndMask32, 011111110111111101111111b{}end
    else exit
  end;

 for yy:= 1 to bmHeight-1 do
   begin
     s1:= PixelPtr[0,yy-1];
     s2:= PixelPtr[1,yy];
     sizex:= bmWidth-2;
{     for xx:= 1 to bmWidth-1 do}
       begin
         asm
           push ebx
           push edi
           push esi  //save registers

           //      -Midle pixel is target pixel "s2+1"
           //     *** -pointer to fist pixel in row is "s2"
           //      *  -pointer to this pixel is in "s1"
           //
           //
           mov edi, s1
           mov esi, s2

           mov ecx, SizeX
//           xor eax, eax
         @1:
           mov edx,[edi+2]
           mov ax, [esi]


           shr edx, 1  //operate with two pixels at once
           shr ax, 1
//           shr bx, 1

           and edx, AndMask32
//           and bx, andmask
           and ax, andmask
           add ax, dx
//           add ax, bx

{           shr ax, 1
           and ax, andmask
           add ax, dx
 }
           shr edx, 16
           shr ax, 1
           and ax, andmask
           add ax, dx

           mov [edi], ax
           inc edi
           inc edi

           inc esi
           inc esi

           loop @1

           pop esi
           pop edi
           pop ebx
         end;

       end;
   end;

end;

procedure TBitmap64. DrawResize( x,y, NewWidth, NewHeight: Longint; b: TBitmap64);
var yp,xp,sx,sy: Longint;
    source,target: PWord; xx,yy: Longint;
begin
  if (bmBpp<>2)or(b.bmBpp<>2) then exit; //sorry, only 15/16 bpp
  if (Width=b.Width)and(Height=b.Height) then //if target resolution is same as source
  begin
    Draw(x,y,b);
    exit;
  end;
  sx:=NewWidth  div b.Width;
  sy:=NewHeight div b.Height;

  yp:=0;target:= bmBits;
    for yy:=0 to NewHeight-1 do
    begin
      source:= b.ScanLine[yp]; xp:=0;
      target:= ScanLine[yy];
      for xx:=0 to NewWidth-1 do
      begin
        asm
          push edi;push esi;push ebx;
          mov edi,target
          mov esi,source
          mov ebx,xp
          mov ax, [esi+ebx]
          mov [edi],ax
          pop ebx;pop esi;pop edi;
        end;
        Inc(target); Inc(xp,sx);
      end;
//      pc:=Ptr(Longint(pc)+Dst.Gap);
      Inc(yp,sy);
    end;

end;

procedure TBitmap64. DrawBlend( x,y: Longint; b:TBitmap64; sfactor,dfactor: single);
{ This is not optimised code, now
  I would like add ASM and MMX code}
var StartX,StartY,
    SizeX,SizeY: Longint;
    xx,yy: Longint;
    s1,d1: PWord;
    s2,d2: PRGB32;
    zz,RS,GS,BS,RD,GD,BD: Longint;
    sfact,dfact: Longint;
    rr,gg,bb: word;//byte;
begin

if (x >= Width) or ( x+b.Width<0) or (y>=Height) or ( y+b.Height<0) then exit; {stupid clipping}
if (X + b.Width) > Width then SizeX:= Width - x else SizeX:= b.Width;
if (Y + b.Height) > Height then SizeY:= Height - y else SizeY:= b.Height;

if X < 0 then   //clip x start
  begin
    StartX:= -x;
    X:= 0;
  end
  else StartX:= 0;

if Y < 0 then   //clip y start
  begin
    StartY:= -y;
    Y:= 0;
  end
  else StartY:= 0;

SizeX:= SizeX- StartX;
SizeY:= SizeY- StartY;

sfact:= trunc(sfactor*128);
dfact:= trunc(dfactor*128);

if (bmBitsPixel <> b. bmBitsPixel) then
  begin
    raise exception.create('Can''t DrawBlend with diferent color depth');exit;
  end;
  
if bmBpp=2 then  //for 15/16bit bpp
  begin
    for yy:= 0 to (SizeY-1) do
      begin
        d1:=    ScanLine[yy+y];
        s1:= b. ScanLine[yy+StartY];
        inc( s1, StartX);
        inc( d1, x);
        for zz := 0 to (SizeX-1) do
          begin
            if (b.transparent)and(b.transparentcolor=s1^) then else
              begin
                Rs:= s1^ shr RStart;
                Gs:= (s1^ and GBitMask) shr GStart;
                Bs:= (s1^ and BBitMask);

                Rd:= d1^ shr RStart;
                Gd:= (d1^ and GBitMask) shr GStart;
                Bd:= (d1^ and BBitMask);

                rr:= (rS *sfact +rD*dfact)shr 7;
                gg:= (gS *sfact +gD*dfact)shr 7;
                bb:= (bS *sfact +bD*dfact)shr 7;

                if rr>31 then rr:= 31;
                if gg>GBitMask shr GStart then gg:= GBitMask shr GStar