graph64.pas

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

    case bmBitsPixel of
      pf8bit:
        begin
          p:= ScanLine[y];
          asm
            mov eax, p
            add eax, start
            mov p, eax
          end;
        end;
      pf16bit,pf15bit:
        begin
          p:= ScanLine[y];
          asm
            mov eax, p
            mov edx, start
            shl edx, 1
            add eax, edx
            mov p, eax
          end;
        end;
      pf32bit:
        begin
          p:= ScanLine[y];
          asm
            mov eax, p
            mov edx, start
            shl edx, 2
            add eax, edx
            mov p, eax
          end;
        end;

    end;  //case
    result:= p;
  end;

end;

Function TBitmap64. GetPixel( x,y: Longint): Longint;
{GetPixel from [x,y] position.
 If position out of region result is zero }
var p:PWord;
    p1: PLongint;
    p2: PByte;
begin
  result:= 0;  //zero if pixel is out of space
  if (x<0)or(y<0)or(x>=bmWidth)or(y>=bmHeight) then
  else
  case bmBitsPixel of
    pf8bit:
      begin
        p2:= ScanLine[y];
        inc( p2, x);
        result:= p2^;
      end;
    pf16bit,pf15bit:
      begin
        p:= ScanLine[y];
        {$IFDEF apFPC}p:=p+x*2;result:= p^{$ELSE} Inc( p, x); result:= p^;{$ENDIF}
      end;
    pf32bit:
      begin
        p1:= ScanLine[y];
        {$IFDEF apFPC}p1:=p1+x*4;result:= p1^{$ELSE} Inc( p1, x); result:= p1^;{$ENDIF}
      end;
  end;

end;

procedure TBitmap64. PutPixel( x,y,color: Longint);
var p: PWord;
    p1: PLongint;
    p2: PByte;
begin
 if (x<0)or(y<0)or(x>=bmWidth)or(y>=bmHeight) then  {only if we are "on Screen"}
 else
  case bmBitsPixel of
    pf8bit:
      begin
        p2:= ScanLine[y];
        Inc( p2, x);
        p2^:= color;
      end;
    pf16bit,pf15bit:
      begin
        p:=  ScanLine[y];
        {$IFDEF apFPC} p:=p+x*2;{$ELSE} Inc(p,x);{$ENDIF}
        p^:= color;
      end;
    pf32bit:
      begin
        p1:=  ScanLine[y];
        {$IFDEF apFPC}p1:=p1+x*2;{$ELSE} Inc( p1, x);{$ENDIF}
        p1^:= color;
      end;
  end;
end;

procedure TBitmap64. PutLensPixel( x,y,color: Longint);
{Draw Blended pixel to [x,y]}
var andmask: word;
    AndMask32: Longint;
    M:PWord;
    M1:PLongint;
begin
  if (x<0)or(y<0)or(x>=bmWidth)or(y>=bmHeight) then
  else
  begin
    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
        m1:= ScanLine[y];
        inc(m1,x);
        m1^:= ((Color shr 1)and AndMask32)+(m1^ shr 1) and AndMask32;
      end
      else
      begin
        m:= scanline[y];
        inc(m,x);
        m^:= ((Color shr 1)and andMask)+(m^ shr 1)and andMask;
      end;
  end;

end;

procedure TBitmap64.LensHLine(x,y,x1,color: Longint);
var p: PWord;
    andmask: word;
begin

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

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

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

  p:= ScanLine[y];
  asm
    push edi
    mov edi, p
    mov ecx, x1
    mov eax, x
    sub ecx, eax
    cmp ecx, 0
    je @NoDraw   //exit if nothing to draw
    shl eax, 1
    add edi, eax //seek to start

    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
    
@NoDraw:
    pop edi
  end;
end;

procedure TBitmap64. HLine( x,y,x1,color: Longint);
{This procedure draw horizontal line from [x,y] to [x1,y] with specific color}
{Need ASM,MMX}
var P: Pointer;
begin
 if x>x1 then swapL( x,x1);   {x is on left, x1 is on right}
 if (x1<0)or(x>=bmWidth)or(y<0)or(y>=bmHeight) then exit; {sayonara}

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

 case bmBitsPixel of
   pf8bit:
     begin
       p:= ScanLine[y];
       asm
         push edi
         mov edi, p
         mov ecx, x1
         mov eax, x
         sub ecx, eax
         add edi, eax
         mov eax, color
         rep stosb
         pop edi
       end;
     end;

   pf16bit,pf15bit:
     begin
       p:= ScanLine[y];
       asm
         push edi
         mov edi, p
         mov ecx, x1
         mov eax, x
         sub ecx, eax
         shl eax, 1
         add edi, eax
         mov eax, color
         rep stosw
         pop edi
       end;
     end;
   pf32bit:
     begin
       p:= ScanLine[y];
       asm
         push edi
         mov edi, p
         mov ecx, x1
         mov eax, x
         sub ecx, eax
         shl eax, 2
         add edi, eax
         mov eax, color
         rep stosd
         pop edi
       end;
     end;
 end;//end of case

end;

procedure TBitmap64. VLine( x,y,y1,color: Longint);
{Draw vertical line from [x,y] to [x,y1] with specific color}
var p:PWord;
    p1: PLongint;
    p2: PByte;
    yy: Longint;

begin
  if y>y1 then SwapL( y,y1);
  if (x<0)or(x>=bmWidth)or(y1<0)or(y>=bmHeight) then exit;//if Line is out of screen
  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
            p2:=  ScanLine[yy];
            {$IFDEF apFPC} p:=p+x*2;{$ELSE}inc( p2, x);{$ENDIF}
            p2^:= 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}
            p^:= color;
          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}
            p1^:= color;
          end;
        end;
  end; //end of case

end;

function sgn(a:Longint):Longint;
begin
  if a>0 then result:=+1 else
  if a<0 then result:=-1 else result:=0;
end;


procedure TBitmap64. Circle( x,y, size, color: Longint);
begin
  Ellipse( x,y, size, size, color);
end;

procedure TBitmap64. Ellipse ( x, y, xsize, ysize, color: Longint);
var xx,  mx1,mx2,  my1,my2: Longint;
    aq,bq, dx,dy, r,rx,ry: Longint;
begin
  PutPixel (x + xsize, y, color);
  PutPixel (x - xsize, y, color);
  mx1 := x - xsize;
  mx2 := x + xsize;
  my1 := y;
  my2 := y;

  aq := xsize * xsize;
  bq := ysize * ysize;
  dx := aq shl 1;
  dy := bq shl 1;
  r  := xsize * bq;
  rx := r shl 1;
  ry := 0;
  xx := xsize;

  while xx > 0
  do begin
    if r > 0
    then begin
      inc (my1);
      dec (my2);
      inc (ry, dx);
      dec (r, ry);
    end;
    if r <= 0
    then begin
      dec (xx);
      inc (mx1);
      dec (mx2);
      dec (rx, dy);
      inc (r, rx);
    end;
    PutPixel (mx1, my1, color);
    PutPixel (mx1, my2, color);
    PutPixel (mx2, my1, color);
    PutPixel (mx2, my2, color);
  end;
end;


procedure TBitmap64. Line( x,y,x1,y1,color: Longint);
{Slow putpixel used!}
var i,s,d1x,d1y,d2x,d2y,u,v,m,n:Longint;
begin
  u:= x1 - x;
  v:= y1 - y;
     d1x:= SGN(u);
     d1y:= SGN(v);
     d2x:= SGN(u);
     d2y:= 0;
     m:= ABS(u);
     n := ABS(v);
     IF NOT (M>N) then
     BEGIN
          d2x := 0 ;
          d2y := SGN(v);
          m := ABS(v);
          n := ABS(u);
     END;
     s := m shr 1;
     FOR i := 0 TO m DO
     BEGIN
          putpixel(x,y,color);
          s := s + n;
          IF not (s<m) THEN
          BEGIN
               s := s - m;
               x:= x + d1x;
               y := y + d1y;
          END
          ELSE
          BEGIN
               x := x + d2x;
               y := y + d2y;
          END;
     end;
end;

procedure TBitmap64. LensLine( x,y,x1,y1,color: Longint);
var i,s,d1x,d1y,d2x,d2y,u,v,m,n:Longint;
begin
  u:= x1 - x;
  v:= y1 - y;
     d1x:= SGN(u);
     d1y:= SGN(v);
     d2x:= SGN(u);
     d2y:= 0;
     m:= ABS(u);
     n := ABS(v);
     IF NOT (M>N) then
     BEGIN
          d2x := 0 ;
          d2y := SGN(v);
          m := ABS(v);
          n := ABS(u);
     END;
     s := m shr 1;
     FOR i := 0 TO m DO
     BEGIN
          PutLensPixel(x,y,color);
          s := s + n;
          IF not (s<m) THEN
          BEGIN
               s := s - m;
               x:= x + d1x;
               y := y + d1y;
          END
          ELSE
          BEGIN
               x := x + d2x;
               y := y + d2y;
          END;
     end;
end;

procedure TBitmap64. Rectangle( x,y, x1,y1,color: Longint);
begin
  Hline(x,y,x1,color);
  Hline(x,y1,x1,color);
  Vline(x,y,y1,color);
  Vline(x1,y,y1,color);

end;

procedure TBitmap64.Triangle( x1,y1, x2,y2, x3,y3,color:Longint);
var
  First,Last,xx,ax,bx,yy,p1,q1,p2,q2,p3,q3:Longint;
begin
  {First we must find first and last line}
  First:= y1; Last:= y1;
  if y2<First then First:=y2;
  if y2>Last then Last:=y2;
  if y3<First then First:=y3;
  if y3>Last then Last:=y3;

  p1:=x1-x3; q1:=y1-y3;
  p2:=x2-x1; q2:=y2-y1;
  p3:=x3-x2; q3:=y3-y2;
  for yy:=First to Last do
    begin
      ax:= Width;
      bx:=-1;
      if (y3>=yy) or (y1>=yy) then
        if (y3<=yy) or (y1<=yy) then
          if not(y3=y1) then
            begin
              xx:=(yy-y3)*p1 div q1+x3;
              if xx<ax then ax:=xx;
              if xx>bx then bx:=xx;
            end;
      if (y1>=yy) or (y2>=yy) then
        if (y1<=yy) or (y2<=yy) then
          if not(y1=y2) then
            begin
              xx:=(yy-y1)*p2 div q2+x1;
              if xx<ax then ax:=xx;
              if xx>bx then bx:=xx;
            end;
      if (y2>=yy) or (y3>=yy) then
        if (y2<=yy) or (y3<=yy) then
          if not(y2=y3) then
            begin
              xx:=(yy-y2)*p3 div q3+x2;
              if xx<ax then ax:=xx;
              if xx>bx then bx:=xx;
            end;
      if ax<=bx then HLine(ax,yy,bx,color);
    end;
end;

procedure TBitmap64. Bar( x,y,x1,y1,color: Longint);
{Draw filled rectangle from [x,y] to [x1,y1] with specific color}
{Ouch!! This slow function??!}