hsbitmapsd.pas

常用数学计算工具

{
  Hs32BitMap的HsPoint:  112 ms  一百万次C
              但是，他的CopyRect(或)Draw过程比HsBitMap要慢，故而不用。张秀达
}
unit HSBitMapSD;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Math;

type
  TScanLines=Array of PByteArray;
  PHsColor=^THsColor;
  PHsCArray=^THsCArray;
  THsColor=//Array [0..2] of Byte;
           Record
            B,G,R:Byte;
           end;
  THsCArray=Array [0..4095] of THsColor;

  THSBitMap = class(TBitMap)  //High  Speed  Point  Access  BitMap
  private
    { Private declarations }
   fBaseP:Array of Integer;
   fBaseWidth:Integer;
   fDataAddr:PByteArray;
   fDataAmount:Integer;
   f3dLine:Boolean;
   function fGetLineColor:TColor;
   procedure fSetLineColor(c:TColor);
  protected
    { Protected declarations }
   fpixels:TScanLines;//Array of PByteArray;
   fHsPoints:array of PHsCArray;
   fMaxRect:TRect;
   fW,fH:Integer;
   fXPoint,fYPoint:Integer;
   fR,fG,fB:Byte;       //线颜色
   fLineColor:THsColor; //线颜色
   procedure BMPChanged;
   procedure SetPixels(x,y:Integer;c:TColor);
   function GetPixels(x,y:Integer):TColor;
   procedure SetHsPoint(x,y:Integer;C:THsColor);
   function  GetHsPoint(x,y:Integer):THsColor;
   procedure Changed(Sender: TObject); override;
  public
    { Public declarations }
   constructor create; override;
   destructor destroy; override;
   procedure GetPoint(x,y:Integer; var R,G,B:Byte);
   procedure SetPoint(X,y:Integer; R,G,B:Byte);
   property pixels[x,y:Integer]:TColor Read GetPixels write SetPixels;
   property HsPoints[X,Y:Integer]:THsColor read GetHsPoint write SetHsPoint;
   property OrgData:TScanLines read fPixels write fPixels;
   procedure SetLineColor(r,g,b:Byte); overload;
   procedure SetLineColor(C:TColor); overload;
   procedure SetPointLineColor(X,Y:Integer); //LineColor
   Procedure MoveTo(x,y:Integer);
   procedure LineTo(x,y:Integer);   //LineColor 实线
   procedure LineToPoint(x,y:Integer); //LineColor  虚线
   procedure LineToPL(x,y:Integer);  //LineColor    点划线
   procedure LineHZ(x1,x2,y:Integer); //LineColor
   procedure AcrossLine(x,y,r:Integer); //LineColor
   procedure Triangle(x1,y1,x2,y2,x3,y3:Integer); //LineColor
   procedure Rectangle(x1,y1,x2,y2:Integer); overload;//LineColor;
   procedure Rectangle(x,y,r:Integer); overload; //LineColor;
   procedure circle(x,y,R:Integer); //LineColor;
   procedure FillBackColor(r,g,b:Byte); overload; //对背景进行填充
   procedure FillBackColor(c:TColor); overload;    //对背景进行填充
   procedure SetBlack;                        //对背景进行填充黑色
   procedure SingleColor(R,G,B:Byte);
   property DataAddr:PByteArray read fDataAddr;
   property DataAmount:Integer read fDataAmount;
  published
    { Published declarations }
   property W:Integer Read fW;
   property H:Integer Read fH;
   property MaxRect:TRect read fMaxRect;
   property LineColor:TColor read fGetLineColor write fSetLineColor;
   property Can3DLine:Boolean read f3dLine write f3dLine;
  end;

implementation
///////////////--------------////////////
constructor THsBitMap.create;
begin
 inherited;
end;

destructor THsBitMap.destroy;
begin
 SetLength(fHsPoints,0);
 SetLength(fpixels,0);
 SetLength(fBaseP,0);
 inherited;
end;
/////////////////////////
procedure THsBitMap.BMPChanged; //当BMP的Width,Height因为各种原因改变时使用
var
 i:Integer;
 baddr,sLen:Integer;
begin
 fMaxRect:=Rect(0,0,width,height);
 if HandleType<>bmDIB then HandleType:=bmDIB;
 if PixelFormat<>pf24Bit then PixelFormat:=pf24bit;
 fw:=Width; fH:=Height;
 SetLength(fPixels,H);
 if H<=0 then exit;
 fPixels[0]:=ScanLine[0];
 bAddr:=Integer(fPixels[0]);
 if H<=1 then exit;
 sLen:=Integer(ScanLine[1])-BAddr;
 for i:=1 to H-1 do
  Integer(fPixels[i]):=bAddr+i*sLen;
 SetLength(fBaseP,fH);   SetLength(fHsPoints,fH);
 for i:=0 to H-1 do
  begin
   fBaseP[i]:=Integer(fPixels[i]);
   Integer(fHsPoints[i]):=fBaseP[i];
  end;
 fBaseWidth:=sLen;
 fDataAmount:=(W*3+W mod 4)*H;
 if SLen>0
  then fDataAddr:=fPixels[0]
  else fDataAddr:=fPixels[H-1];
end;
procedure THsBitMap.Changed;
begin
 inherited;
 BMPChanged;
end;
//--//--////////////////////////////
//--//--/////////////////////////////
procedure THsBitMap.SetHsPoint;
begin
 fHsPoints[Y,X]:=C;
end;
function THsBitMap.GetHsPoint;
begin
 Result:=fHsPoints[Y,X];
end;
//////
procedure THsBitMap.SetPixels;
var
 Cs:Array [0..3] of Byte;
 Wp:Integer; fp:PByteArray;
begin
 if (y<0) or (y>=fH) or (x<0) or (x>=fW) then exit;
 Integer(Cs):=C; wp:=3*x;
 fp:=fPixels[y];
 fp[wp+2]:=cs[0];
 fp[wp+1]:=cs[1];
 fp[wp]:=cs[2];
end;

function THsBitMap.GetPixels;
var
 cs:Array[0..3] of Byte;
 wp:Integer; fp:PByteArray;
begin
 if (y<0) or (y>=fH) or (x<0) or (x>=fW) then
 begin
  Result:=0;
  exit;
 end;
 wp:=x*3;
 fp:=fPixels[y];
 cs[0]:=fp[wp+2];
 cs[1]:=fp[wp+1];
 cs[2]:=fp[wp];
 cs[3]:=0;
 result:=Integer(cs);
end;
////////
////////////////////////////////
procedure THsBitMap.SetPoint;
var
 wp:Integer;
 fp:PByteArray;
begin
 fp:=fPixels[y];
 wp:=x*3;
 fP[wp]:=b;
 fP[wp+1]:=g;
 fP[wp+2]:=r;
end;
procedure THsBitMap.GetPoint;
var
 wp:Integer;
 fp:PByteArray;
begin
 if (x<0)or(x>=W)or(y<0)or(y>=h) then exit;
 fp:=fPixels[y];
 wp:=x*3;
 b:=fp[wp];
 g:=fp[wp+1];
 r:=fp[wp+2];
end;
///////
//////////////////////////////////
procedure THsBitMap.SetLineColor(r,g,b:Byte);
begin
 fB:=b;
 fG:=g;
 fR:=r;
 fLineColor.R:=fR; fLineColor.G:=fG; fLineColor.B:=fB;
end;
procedure THsBitMap.SetLineColor(C:TColor);
var
 cs:Integer;
 CB:Array [0..3] of Byte;
begin
 if c<0
  then cs:=GetSysColor(c and $ff)
  else cs:=c;
 integer(cb):=cs;
 fB:=cb[2];
 fG:=cb[1];
 fR:=cb[0];
 fLineColor.R:=fR;
 fLineColor.G:=fG;
 fLineColor.B:=fB;
end;
function  THsBitMap.fGetLineColor;
begin
 Result:=RGB(fR,fG,fB);
end;
procedure THsBitMap.fSetLineColor(C:TColor);
var
 cs:Integer;
 CB:Array [0..3] of Byte;
begin
 if c<0
  then cs:=GetSysColor(c and $ff)
  else cs:=c;
 integer(cb):=cs;
 fB:=cb[2];
 fG:=cb[1];
 fR:=cb[0];
 fLineColor.R:=fR; fLineColor.G:=fG; fLineColor.B:=fB;
end;
////
/////////////
procedure THsBitMap.SetPointLineColor;
begin
 if (Y<0)or(Y>=H)or(x<0)or(x>=W) then exit;
 fHsPoints[Y,x]:=fLineColor;
end;

procedure THsBitMap.MoveTo(x,y:Integer);
begin
 fXPoint:=x; fYPoint:=y;
end;
procedure THsBitMap.LineTo(x,y:Integer);
var
 i:Integer;
 tempY,
 BaseOff,
 YL,xL:Integer;
begin
 if (H<1)or(W<1) then exit;
 YL:=y-fYPoint; XL:=x-fXPoint;
 if (XL=0)and(YL=0) then exit;
 if ((y<0)and(fYPoint<0))or((y>=H)and(fYPoint>=H))or
    ((x<0)and(fXPoint<0))or((x>=W)and(fXPoint>=w))
    then begin  //无需画图
     fXPoint:=x; fYPoint:=y;
     exit;
    end;
 if f3DLine then begin //3d画线模式
 if Abs(XL)>=Abs(YL) then
 for i:=Max(0,Min(fXPoint,x)) to Min(W-1,Max(fXPoint,x)) do
  begin
   tempY:=fYPoint+(i-fXPoint)*YL div XL;
   if (TempY>=fH)or(tempY<0)//or(i>=fW)or(i<0)
     then continue;
   if fHsPoints[tempY,i].R<=fLineColor.R
      then fHsPoints[tempY,i]:=fLineColor;
  end
 else
  for i:=Max(0,Min(fYPoint,Y)) to Min(H-1,Max(fYPoint,y)) do
  begin
    BaseOff:=fXPoint+(i-fYPoint)*XL div YL;
   if (BaseOff<0)or(baseOff>=fW)//or(i>=fH)or(i<0)
    then continue;
   if fHsPoints[i,BaseOff].R<=fLineColor.R
      then fHsPoints[i,BaseOff]:=fLineColor;
  end;
 end else  //普通的 非3dLine
  if Abs(XL)>=Abs(YL) then
 for i:=Max(0,Min(fXPoint,x)) to Min(W-1,Max(fXPoint,x)) do
  begin
   if YL and $FFFFf000=0
    then tempY:=fYPoint+(i-fXPoint)*YL div XL
    else tempY:=fYPoint+(i-fXPoint)*Int64(YL) div XL ;
   if (TempY>=fH)or(tempY<0)//or(i>=fW)or(i<0)
     then continue;
   fHsPoints[tempY,i]:=fLineColor;
  end
 else
  for i:=Max(0,Min(fYPoint,Y)) to Min(H-1,Max(fYPoint,y)) do
  begin
   if XL and $FFFFf000=0
      then BaseOff:=fXPoint+(i-fYPoint)*XL div YL
      else BaseOff:=fXPoint+(i-fYPoint)*Int64(XL) div YL;
   if (BaseOff<0)or(baseOff>=fW)//or(i>=fH)or(i<0)
    then continue;
   fHsPoints[i,BaseOff]:=fLineColor;
  end;
 fXPoint:=x; fYPoint:=y;
end;
procedure THsBitMap.LineToPoint;
var
 i:Integer;
 tempY,
 BaseOff,
 YL,xL:Integer;
begin
 YL:=y-fYPoint; XL:=x-fXPoint;
 if (XL=0) and (YL=0) then exit;
 if ((y<0)and(fYPoint<0))or((y>=H)and(fYPoint>=H))or
    ((x<0)and(fXPoint<0))or((x>=W)and(fXPoint>=w))
    then begin  //无需画图
     fXPoint:=x; fYPoint:=y;
     exit;
    end;

 if Abs(XL)>=Abs(YL) then
 for i:=Max(0,Min(fXPoint,x)) to Min(W-1,Max(fXPoint,x)) do
  begin
   if (i and 2)=2 then continue;
   tempY:=fYPoint+(i-fXPoint)*Int64(YL) div XL ;
   if (TempY>=fH)or(tempY<0)//or(i>=fW)or(i<0)
     then continue;
   fHsPoints[TempY,i]:=fLineColor;
  end
 else
  for i:=Max(0,Min(fYPoint,Y)) to Min(H-1,Max(fYPoint,y)) do
  begin
   if (i and 2)=2 then continue;
   BaseOff:=fXPoint+(i-fYPoint)*Int64(XL) div YL;
   if (BaseOff<0)or(baseOff>=fW)//or(i>=fH)or(i<0)
     then continue;
   fHsPoints[i,BaseOff]:=fLineColor;
  end;
 fXPoint:=x; fYPoint:=y;
end;
procedure THsBitMap.LineToPL;
var
 i:Integer;
 tempY,
 BaseOff,
 YL,xL:Integer;
begin
 YL:=y-fYPoint; XL:=x-fXPoint;
 if (XL=0) and (YL=0) then exit;
 if ((y<0)and(fYPoint<0))or((y>=H)and(fYPoint>=H))or
    ((x<0)and(fXPoint<0))or((x>=W)and(fXPoint>=w))
    then begin  //无需画图
     fXPoint:=x; fYPoint:=y;
     exit;
    end;

 if Abs(XL)>=Abs(YL) then
 for i:=Max(0,Min(fXPoint,x)) to Min(W-1,Max(fXPoint,x)) do
  begin
   if ((i mod 14)>7) and ((i mod 14)and 2<>2)then continue;
   tempY:=fYPoint+(i-fXPoint)*Int64(YL) div XL ;
   if (TempY>=fH)or(tempY<0)//or(i>=fW)or(i<0)
     then continue;
   fHsPoints[TempY,i]:=fLineColor;
  end
 else
  for i:=Max(0,Min(fYPoint,Y)) to Min(H-1,Max(fYPoint,y)) do
  begin
   if ((i mod 14)>7) and ((i mod 14)and 2<>2) then continue;
   BaseOff:=fXPoint+(i-fYPoint)*Int64(XL) div YL;
   if (BaseOff<0)or(baseOff>=fW)//or(i>=fH)or(i<0)
     then continue;
   fHsPoints[i,BaseOff]:=fLineColor;
  end;
 fXPoint:=x; fYPoint:=y;
end;
///////
////////////////
procedure THsBitMap.LineHZ;
var
 i:Integer;
 BaseP:PHsCArray;
begin
 if (Y<0) or (Y>=fH) then exit;
 baseP:=fHsPoints[Y];
 for i:=Min(x1,x2) to Max(x1,x2) do
  begin
   if (i<0) or (i>=fW) then continue;
   baseP[i]:=fLineColor;
  end;
end;
procedure THsBitMap.AcrossLine;
var
 i:Integer;
begin
 if (Y<0)or(Y>=H)or(x<0)or(x>=W) then exit;
 LineHZ(x-r,x+r,y);
 for i:=y-r to y+r do
  begin
   if (i<0) or (i>=fH) then continue;
   fHsPoints[i,x]:=fLinecolor;
  end;
end;
////
////////////////
procedure THsBitMap.Triangle;
var
 X:Array [0..2] of Integer;
 Y:Array [0..2] of Integer;
 MaxY,MidY,MinY,
 YL,YR,
 i:Integer;
 LPoint,RPoint:Array of Integer;
begin
 x[0]:=x1; x[1]:=x2; x[2]:=x3;
 y[0]:=y1; y[1]:=y2; y[2]:=y3;
 MaxY:=0;
 for i:=1 to 2 do if y[i]>y[MaxY] then MaxY:=i;
 MinY:=0;
 for i:=1 to 2 do if y[i]<y[MinY] then MinY:=i;
 MidY:=3-MaxY-MinY;
 SetLength(LPoint,Y[MaxY]-Y[Miny]+1); SetLength(RPoint,Y[MaxY]-Y[MinY]+1);
 ////////////////////////找到各点的相对位置
 YL:=Y[MidY]-Y[MinY]; YR:=Y[MaxY]-Y[MinY]; //宽度
 for i:=Y[MinY] to Y[MidY] do
  begin
   if YL<>0 then  LPoint[i-Y[MinY]]:=X[MinY]+(i-Y[MinY])*(X[MidY]-X[MinY]) div YL
            else  LPoint[i-Y[MinY]]:=X[MidY];
   if YR<>0 then  RPoint[i-Y[MinY]]:=X[MinY]+(i-Y[MinY])*(X[MaxY]-X[MinY]) div YR
            else  RPoint[i-Y[MinY]]:=X[MaxY];
  end;
 YL:=Y[MaxY]-Y[MidY];// YR:=Y[MinY]-Y[MaxY];
 for i:=Y[MidY]+1 to Y[MaxY] do
  begin
   if YL<>0 then LPoint[i-Y[MinY]]:=X[MidY]+(i-Y[MidY])*(X[MaxY]-X[MidY]) div YL
            else LPoint[i-Y[MinY]]:=X[MidY];
   if YR<>0 then RPoint[i-Y[MinY]]:=X[MinY]+(i-Y[MinY])*(X[MaxY]-X[MinY]) div YR
            else RPoint[i-Y[MinY]]:=X[MaxY];
  end;
 ////////
 for i:=Y[MinY] to Y[MaxY] do
   LineHZ(LPoint[i-Y[MinY]],RPoint[i-Y[MinY]],i);
 SetLength(LPoint,0); SetLength(RPoint,0);
end;
///
procedure THsBitMap.Rectangle(x1,y1,x2,y2:Integer);
var
 i,j:Integer;
 BaseP:PByteArray;
 baseOff,BaseLen:Integer;
begin
 if (Y1<0)or(Y1>=H)or(x1<0)or(x1>=W) then exit;
 if (Y2<0)or(Y2>=H)or(x2<0)or(x2>=W) then exit;
 BaseP:=fPixels[Min(Y1,Y2)];
 for j:=Min(x1,x2) to Max(x1,x2) do
    begin
     baseOff:=j*3;
     BaseP[BaseOff]:=fB;
     BaseP[BaseOff+1]:=fG;
     BaseP[BaseOff+2]:=fR;
    end;
 BaseOff:=Min(x1,x2)*3;  BaseLen:=(Max(x1,x2)-Min(x1,x2)+1)*3;
 Integer(BaseP):=Integer(BaseP)+BaseOff;
 for i:=Min(y1,y2)+1 to Max(y1,y2) do
   MoveMemory(Pointer(Integer(fPixels[i])+BaseOff),
              BaseP,BaseLen);
end;
procedure THsBitMap.Rectangle(x,y,r:Integer);
begin
 Rectangle(x-r,y-r,x+r,y+r);
end;
///
procedure THsBitMap.circle;
var
 PB:PByteArray;
 BaseOff,
 i,j:Integer;
begin
 if (Y<0)or(Y>=H)or(x<0)or(x>=W) then exit;
 for j:=-r to r do
  begin
   if (y+j<0) or (y+j>=H) then continue;
   PB:=fPixels[y+j];
   for i:=-r to r do
    if i*i+j*j<=r*r then
     begin
      BaseOff:=x+i;
      if (BaseOff<0) or (BaseOff>=W) then continue;
      BaseOff:=BaseOff*3;
      PB[BaseOff]:=fB; PB[BaseOff+1]:=fG; PB[BaseOff+2]:=fR;
     end;
  end;
end;
/////////-------------------/////////
////----------////////
procedure THsBitMap.FillBackColor(r,g,b:Byte);
var
 i:Integer;
 bp:PByteArray;
begin
 if H<=0 then exit;
 bp:=fPixels[0];
 for i:=0 to w-1 do
  begin
   bp[i*3]:=b; bp[i*3+1]:=g; bp[i*3+2]:=r;
  end;
 for i:=1 to H-1 do
  CopyMemory(fPixels[i],bp,3*w);
end;
procedure THsBitMap.FillBackColor(c:Tcolor);
var
 Cs:Array [0..3] of Byte;
begin
 Integer(cs):=c;
 FillBackColor(cs[0],cs[1],cs[2]);
end;
procedure THsBitMap.SetBlack;
var
 i:Integer;
begin
 for i:=0 to H-1 do
   ZeroMemory(fPixels[i],3*W);
end;

procedure THsBitMap.SingleColor(R,G,B:Byte);
var
 i,j:Integer;
 Amount:Integer;
 Avg:Byte;
 PData:PByte;
begin
 for i:=0 to H-1 do
  begin
   PData:=@fPixels[i,0];
   for j:=0 to W-1 do
    begin
     Amount:=PData^*B div 255; Inc(PData);
     Amount:=Amount+PData^*G div 255; Inc(PData);
     Amount:=Amount+PData^*R div 255;
     Avg:=Amount div 3;
     Dec(PData,2);
     FillChar(PData^,3,Avg);
     Inc(PData,3);
    end;
  end;
end;
//////////////////////////////////////////


end.