📄 fastbmp.pas

📁 一个基于不需引擎的文件管理系统,使用了许多界面比较好的控件
💻 PAS
📖 第 1 页 / 共 3 页
字号:
上一页 1 23
  dx:Integer;
begin
  If x2<x1 then
  begin
    t:=x2;
    x2:=x1;
    x1:=t;
  end;
  If y2<y1 then
  begin
    t:=y2;
    y2:=y1;
    y1:=t;
  end;
  If (x1<0) OR (y1<0) OR (x2>Width-1) OR (y2>Width-1) then
    Exit;
  z:=0;
  iz:=$100000;
  If x2<>x1 then
    t:=$100000 div (x2-x1);
  If y2<>y1 then
    t2:=$100000 div (y2-y1);
  dx:=x2-x1;
  For yCount:=y1 to y2 do
  begin
    xx:=((c00.r*iz+c01.r*z) shr 20);
    rp:=xx shl 20;
    rp2:=(((c10.r*iz+c11.r*z) shr 20)-xx)*t;
    xx:=((c00.g*iz+c01.g*z) shr 20);
    gp:=xx shl 20;
    gp2:=(((c10.g*iz+c11.g*z) shr 20)-xx)*t;
    xx:=((c00.b*iz+c01.b*z) shr 20);
    bp:=xx shl 20;
    bp2:=(((c10.b*iz+c11.b*z) shr 20)-xx)*t;
    pb:=@PLine(ScanLines[yCount])^[x1];
    For xCount:=0 to dx do
    begin
      pb^:=bp shr 20;
      Inc (bp,bp2);
      PByte(Integer(pb)+1)^:=gp shr 20;
      Inc (gp,gp2);
      PByte(Integer(pb)+2)^:=rp shr 20;
      Inc (rp,rp2);
      Inc (pb,3);
    end;
    Inc (z,t2);
    Dec (iz,t2);
  end;
end;

// EFG's computer lab - Rotate Scanline
procedure TFastBmp.RotateWrap(Dst:TFastBmp;Degree:Extended;iRotationAxis,jRotationAxis:Integer);
var
Theta,
cosTheta,
sinTheta:      Double;
i,j,Delta,
iOriginal,
iPrime,
iPrimeRotated,
jOriginal,
jPrime,
jPrimeRotated: Integer;
RowOriginal,
RowRotated:    PLine;
begin
  GetMem(RowRotated,Dst.Width*3);
  Theta:=-Degree*Pi/180;
  sinTheta:=Sin(Theta);
  cosTheta:=Cos(Theta);

  for j:=0 to Dst.Height-1 do
  begin
    Dst.GetScanline(j,RowRotated);
    jPrime:=2*(j-jRotationAxis)+1;
    for i:=0 to Dst.Width-1 do
    begin
      iPrime:=2*(i-iRotationAxis)+1;
      iPrimeRotated:=Round(iPrime*cosTheta-jPrime*sinTheta);
      jPrimeRotated:=Round(iPrime*sinTheta+jPrime*cosTheta);
      iOriginal:=(iPrimeRotated-1)div 2+iRotationAxis;
      jOriginal:=(jPrimeRotated-1)div 2+jRotationAxis;

      if      iOriginal<0       then iOriginal:=Width-1-(-iOriginal mod Width)
      else if iOriginal>=Width  then iOriginal:=iOriginal mod Width;
      if      jOriginal<0       then jOriginal:=Height-1-(-jOriginal mod Height)
      else if jOriginal>=Height then jOriginal:=jOriginal mod Height;

      RowOriginal:=Scanlines[jOriginal];
      RowRotated^[i]:=RowOriginal[iOriginal];
    end;
    Dst.Scanlines[j]:=RowRotated;
  end;
  FreeMem(RowRotated,Dst.Width*3);
end;

procedure TFastBmp.GrayScale;
var
Tmp:   PFColor;
Gray,
p,x,y: Integer;
begin
  p:=Integer(Bits);
  for y:=0 to Height-1 do
  begin
    Tmp:=Pointer(p);
    for x:=0 to Width-1 do
    begin
      Gray:=Round(Tmp.r*0.3+Tmp.g*0.59+Tmp.b*0.11);
      Tmp.b:=Gray;
      Tmp.g:=Gray;
      Tmp.r:=Gray;
      Inc(Tmp);
    end;
    Inc(p,RowInc);
  end;
end;

procedure TFastBmp.DiscardColor;
var
Tmp:   PFColor;
Gray,
p,x,y: Integer;
begin
  p:=Integer(Bits);
  for y:=0 to Height-1 do
  begin
    Tmp:=Pointer(p);
    for x:=0 to Width-1 do
    begin
      Gray:=(Tmp.b*2+Tmp.g+Tmp.r)shr 2;
      Tmp.b:=Gray;
      Tmp.g:=Gray;
      Tmp.r:=Gray;
      Inc(Tmp);
    end;
    Inc(p,RowInc);
  end;
end;

procedure TFastBmp.Sharpen;
begin

end;

//  Interpolated Resampling Based on 'Bitmap Resampler'
//
//  By Anders Melander <anders@melander.dk>
//  -Interpolated Bitmap Resampling using filters.
//
//  v0.04 Optimized w/PLines
//
//  Contributors:
//  Dale Schumacher - "General Filtered Image Rescaling"
//  David Ullrich <ullrich@hardy.math.okstate.edu>

// Hermite filter
function HermiteFilter(Value:Single):Single;
begin
  // f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
  if(Value<0)then Value:=-Value;
  if(Value<1)then Result:=(2*Value-3)*Sqr(Value)+1
  else Result:=0;
end;

// Box filter
// a.k.a. "Nearest Nieghbor" filter
// anme: I have not been able to get acceptable
//       results with this filter for subsampling.
function BoxFilter(Value:Single):Single;
begin
  if(Value>-0.5)and(Value<=0.5)then Result:=1
  else {Value > .5 | < -.5}         Result:=0;
end;

// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
function TriangleFilter(Value:Single):Single;
begin
  if(Value<0)then Value:=-Value;
  if(Value<1)then Result:=1-Value
  else            Result:=0;
end;

// Bell filter
function BellFilter(Value:Single):Single;
begin
  if(Value<0)then Value:=-Value;
  if(Value<0.5)then Result:=0.75-Sqr(Value)
  else if(Value<1.5)then Result:=0.5*Sqr(Value-1.5)
  else Result:=0;
end;

// B-spline filter
function SplineFilter(Value:Single):Single;
var
tt: Single;
begin
  if(Value<0)then Value:=-Value;
  if(Value<1)then
  begin
    tt:=Sqr(Value);
    Result:=0.5*tt*Value-tt+2/3;
  end else if(Value<2)then
  begin
    Value:=2-Value;
    Result:=1/6*Sqr(Value)*Value;
  end else
    Result:=0;
end;

// Lanczos3 filter
function Lanczos3Filter(Value:Single):Single;
  function SinC(Value:Single):Single;
  begin
    if(Value<>0)then
    begin
      Value:=Value*Pi;
      Result:=Sin(Value)/Value
    end
    else Result:=1;
  end;
begin
  if(Value<0)then Value:=-Value;
  if(Value<3)then Result:=SinC(Value)*SinC(Value/3)
  else Result:=0;
end;

// Mitchell Filter
function MitchellFilter(Value:Single):Single;
const
  C=0.333333333333333333333333333333333;
var
  tt:Single;
begin
  if(Value<0)then Value:=-Value;
  tt:=Sqr(Value);
  if(Value<1)then
  begin
    Value:=(((12-9*C-6*C)*(Value*tt))+
           ((-18+12*C+6*C)*tt)+
           (6-2*C));
    Result:=Value/6;
  end else
  if(Value<2)then
  begin
    Value:=(((-1*C-6*C)*(Value*tt))+
           ((6*C+30*C)*tt)+
           ((-12*C-48*C)*Value)+
           (8*C+24*C));
    Result:=Value/6;
  end else
    Result:=0;
end;

procedure TFastBmp.Resample(Dst:TFastBmp;Filter:TFilterProc;FWidth:Single);
type
// Contributor for a pixel
TContributor=record
  Pixel:  Integer;  // Source pixel
  Weight: Single;  // Pixel weight
end;

TContributorList=array[0..0] of TContributor;
PContributorList=^TContributorList;

// List of source pixels contributing to a destination pixel
TCList=record
  n: Integer;
  p: PContributorList;
end;

TCListList=array[0..0] of TCList;
PCListList=^TCListList;

TRGB=record
r,g,b: Single;
end;

var
Delta,
DestDelta,
SrcWidth,
SrcHeight,
DstWidth,
DstHeight,
i,j,k,
Left,Right,n:   Integer;

xScale,yScale,
Center,Wdth,
fScale,Weight:  Single;

Work:           TFastBmp;
Contrib:        PCListList;
rgb:            TRGB;
Color:          TFColor;
SourceLine,
DestLine:       PLine;
SourcePixel,
DestPixel:      PFColor;

begin
  DstWidth:=Dst.Width;
  DstHeight:=Dst.Height;
  SrcWidth:=Width;
  SrcHeight:=Height;

  Work:=TFastBmp.Create(DstWidth,SrcHeight);

  if(SrcWidth=1)then xScale:=DstWidth/SrcWidth
  else xScale:=(DstWidth-1)/(SrcWidth-1);
  if(SrcHeight=1)then yScale:=DstHeight/SrcHeight
  else yScale:=(DstHeight-1)/(SrcHeight-1);

  GetMem(contrib, DstWidth*SizeOf(TCList));
  // Horizontal sub-sampling
  if(xScale<1)then
  begin
    Wdth:=fWidth/xScale;
    fScale:=1/xScale;
    for i:=0 to DstWidth-1 do
    begin
      Contrib^[i].n:=0;
      GetMem(Contrib^[i].p,Trunc(Wdth*2+1)*SizeOf(TContributor));
      Center:=i/xScale;
      Left:=Trunc(Center-Wdth);
      Right:=Trunc(Center+Wdth);
      for j:=Left to Right do
      begin
        Weight:=Filter((Center-j)/fScale)/fScale;
        if(Weight=0)then Continue;
        if(j<0)then n:=-j
        else if(j>=SrcWidth)then n:=SrcWidth-j+SrcWidth-1
        else n:=j;
        k:=Contrib^[i].n;
        Contrib^[i].n :=Contrib^[i].n+1;
        Contrib^[i].p^[k].Pixel:=n;
        Contrib^[i].p^[k].Weight:=Weight;
      end;
    end;
  end else
  // Horizontal super-sampling
  begin
    for i:=0 to DstWidth-1 do
    begin
      Contrib^[i].n:=0;
      GetMem(Contrib^[i].p,Trunc(fWidth*2+1)*SizeOf(TContributor));
      Center:=i/xScale;
      Left:=Trunc(Center-fWidth);
      Right:=Trunc(Center+fWidth);
      for j:=Left to Right do
      begin
        Weight:=Filter(Center-j);
        if(Weight=0)then Continue;
        if(j<0)then n:=-j
        else if(j>=SrcWidth)then n:=SrcWidth-j+SrcWidth-1
        else n:=j;
        k:=Contrib^[i].n;
        Contrib^[i].n:=Contrib^[i].n+1;
        Contrib^[i].p^[k].Pixel:=n;
        Contrib^[i].p^[k].Weight:=Weight;
      end;
    end;
  end;

  for k:=0 to SrcHeight-1 do
  begin
    SourceLine:=ScanLines[k];
    DestPixel:=Work.ScanLines[k];
    for i:=0 to DstWidth-1 do
    begin
      rgb.r:=0;
      rgb.g:=0;
      rgb.b:=0;
      for j:=0 to Contrib^[i].n-1 do
      begin
        Color:=SourceLine^[Contrib^[i].p^[j].Pixel];
        Weight:=Contrib^[i].p^[j].Weight;
        if(Weight=0)then Continue;
        rgb.b:=rgb.b+Color.b*Weight;
        rgb.g:=rgb.g+Color.g*Weight;
        rgb.r:=rgb.r+Color.r*Weight;
      end;
      if(rgb.r>255)then Color.r:=255
      else if(rgb.r<0)then Color.r:=0
      else Color.r:=Round(rgb.r);
      if(rgb.g>255)then Color.g:=255
      else if(rgb.g<0)then Color.g:=0
      else Color.g:=Round(rgb.g);
      if(rgb.b>255)then Color.b:=255
      else if(rgb.b<0)then Color.b:=0
      else Color.b:=Round(rgb.b);
      DestPixel^:=Color;
      Inc(DestPixel);
    end;
  end;

  for i:=0 to DstWidth-1 do
  FreeMem(Contrib^[i].p);
  FreeMem(Contrib);

  GetMem(contrib, DstHeight* sizeof(TCList));

  // Vertical sub-sampling
  if(yScale<1)then
  begin
    Wdth:=fWidth/yScale;
    fScale:=1/yScale;
    for i:=0 to DstHeight-1 do
    begin
      Contrib^[i].n:=0;
      GetMem(Contrib^[i].p,Trunc(Wdth*2+1)*SizeOf(TContributor));
      Center:=i/yScale;
      Left:=Trunc(Center-Wdth);
      Right:=Trunc(Center+Wdth);
      for j:=Left to Right do
      begin
        Weight:=Filter((Center-j)/fScale)/fScale;
        if(Weight=0)then Continue;
        if(j<0)then n:=-j
        else if(j>=SrcHeight)then n:=SrcHeight-j+SrcHeight-1
        else n:=j;
        k:=Contrib^[i].n;
        Contrib^[i].n:=Contrib^[i].n+1;
        Contrib^[i].p^[k].Pixel:=n;
        Contrib^[i].p^[k].Weight:=Weight;
      end;
    end
  end else
  // Vertical super-sampling
  begin
    for i:=0 to DstHeight-1 do
    begin
      Contrib^[i].n:=0;
      GetMem(Contrib^[i].p,Trunc(fWidth*2+1)*SizeOf(TContributor));
      Center:=i/yScale;
      Left:=Trunc(Center-fWidth);
      Right:=Trunc(Center+fWidth);
      for j:=Left to Right do
      begin
        Weight:=Filter(Center-j);
        if(Weight=0)then Continue;
        if(j<0)then n:=-j
        else if(j>=SrcHeight)then n:=SrcHeight-j+SrcHeight-1
        else n:=j;
        k:=Contrib^[i].n;
        Contrib^[i].n:=Contrib^[i].n+1;
        Contrib^[i].p^[k].Pixel:=n;
        Contrib^[i].p^[k].Weight:=Weight;
      end;
    end;
  end;

  SourceLine:=Work.ScanLines[0];
  Delta:=Integer(Work.ScanLines[1])-Integer(SourceLine);
  DestLine:=Dst.ScanLines[0];
  DestDelta:=Integer(Dst.ScanLines[1])-Integer(DestLine);
  for k:=0 to DstWidth-1 do
  begin
    DestPixel:=Pointer(DestLine);
    for i:=0 to DstHeight-1 do
    begin
      rgb.r:=0;
      rgb.g:=0;
      rgb.b:=0;
      for j:=0 to Contrib^[i].n-1 do
      begin
        Color:=PFColor(Integer(SourceLine)+Contrib^[i].p^[j].Pixel*Delta)^;
        Weight:=Contrib^[i].p^[j].Weight;
        if(Weight=0)then Continue;
        rgb.r:=rgb.r+Color.r*Weight;
        rgb.g:=rgb.g+Color.g*Weight;
        rgb.b:=rgb.b+Color.b*Weight;
      end;
      if(rgb.r>255)then Color.r:=255
      else if(rgb.r<0)then Color.r:=0
      else Color.r:=Round(rgb.r);
      if(rgb.g>255)then Color.g:=255
      else if(rgb.g<0)then Color.g:=0
      else Color.g:=Round(rgb.g);
      if(rgb.b>255)then Color.b:=255
      else if(rgb.b<0)then Color.b:=0
      else Color.b:=Round(rgb.b);
      DestPixel^:=Color;
      Inc(Integer(DestPixel),DestDelta);
    end;
    Inc(SourceLine);
    Inc(DestLine);
  end;

  for i:=0 to DstHeight-1 do
  FreeMem(Contrib^[i].p);
  FreeMem(Contrib);
  Work.Free;
end;


destructor TFastBmp.Destroy;
begin
  FreeMem(Calcs,Height*SizeOf(Integer));
  DeleteObject(Handle);
  inherited;
end;

end.
上一页 1 23
💿 文件大小 8395 K
👤 上传用户 lqlm521
📂 所属分类 Delphi控件源码
🏷️ 相关标签

#引擎 #文件管理 #控件
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -