آموزش ایجاد افکت امواج آب بر روی عکس در دلفی
در مرحله اول یک یونیت جدید ایجاد کنید و نام آنرا به "unt_WaterEffect.pas" تغییر دهید و کد های زیر را درون آن کپی کنید.
unit unt_WaterEffect;
interface
uses
Winapi.Windows, System.SysUtils, Vcl.Graphics, Math;
const
DampingConstant = 15;
type
PIntArray = ^TIntArray;
TIntArray = array [0 .. 16777215] of Integer;
PPIntArray = ^TPIntArray;
TPIntArray = array [0 .. 16777215] of PIntArray;
PRGBArray = ^TRGBArray;
TRGBArray = array [0 .. 16777215] of TRGBTriple;
PPRGBArray = ^TPRGBArray;
TPRGBArray = array [0 .. 16777215] of PRGBArray;
TWaterDamping = 1 .. 99;
TWaterEffect = class(TObject)
private
{ Private declarations }
FrameWidth: Integer;
FrameHeight: Integer;
FrameBuffer01: Pointer;
FrameBuffer02: Pointer;
FrameLightModifier: Integer;
FrameScanLine01: PPIntArray;
FrameScanLine02: PPIntArray;
FrameScanLineScreen: PPRGBArray;
FrameDamping: TWaterDamping;
procedure SetDamping(Value: TWaterDamping);
protected
{ Protected declarations }
procedure CalculateWater;
procedure DrawWater(ALightModifier: Integer; Screen, Distance: TBitmap);
public
{ Public declarations }
constructor Create;
destructor Destroy; override;
procedure ClearWater;
procedure SetSize(EffectBackgroundWidth, EffectBackgroundHeight: Integer);
procedure Render(Screen, Distance: TBitmap);
procedure Bubble(X, Y: Integer; BubbleRadius, EffectBackgroundHeight
: Integer);
property Damping: TWaterDamping read FrameDamping write SetDamping;
end;
implementation
{ TWaterEffect }
const
RandomConstant = $7FFF;
procedure TWaterEffect.Bubble(X, Y: Integer;
BubbleRadius, EffectBackgroundHeight: Integer);
var
Rquad: Integer;
CX, CY, CYQ: Integer;
Left, Top, Right, Bottom: Integer;
begin
if (X < 0) or (X > FrameWidth - 1) then
X := 1 + BubbleRadius + Random(RandomConstant)
mod (FrameWidth - 2 * BubbleRadius - 1);
if (Y < 0) or (Y > FrameHeight - 1) then
Y := 1 + BubbleRadius + Random(RandomConstant)
mod (FrameHeight - 2 * BubbleRadius - 1);
Left := -Min(X, BubbleRadius);
Right := Min(FrameWidth - 1 - X, BubbleRadius);
Top := -Min(Y, BubbleRadius);
Bottom := Min(FrameHeight - 1 - Y, BubbleRadius);
Rquad := BubbleRadius * BubbleRadius;
for CY := Top to Bottom do
begin
CYQ := CY * CY;
for CX := Left to Right do
begin
if (CX * CX + CYQ <= Rquad) then
begin
Inc(FrameScanLine01[CY + Y][CX + X], EffectBackgroundHeight);
end;
end;
end;
end;
procedure TWaterEffect.CalculateWater;
var
X, Y, XL, XR: Integer;
NewH: Integer;
P1, P2, P3, P4: PIntArray;
PT: Pointer;
Rate: Integer;
begin
Rate := (100 - FrameDamping) * 256 div 100;
for Y := 0 to FrameHeight - 1 do
begin
P1 := FrameScanLine02[Y];
P2 := FrameScanLine01[Max(Y - 1, 0)];
P3 := FrameScanLine01[Y];
P4 := FrameScanLine01[Min(Y + 1, FrameHeight - 1)];
for X := 0 to FrameWidth - 1 do
begin
XL := Max(X - 1, 0);
XR := Min(X + 1, FrameWidth - 1);
NewH := (P2[XL] + P2[X] + P2[XR] + P3[XL] + P3[XR] + P4[XL] + P4[X] +
P4[XR]) div 4 - P1[X];
P1[X] := NewH * Rate div 256;
end;
end;
PT := FrameBuffer01;
FrameBuffer01 := FrameBuffer02;
FrameBuffer02 := PT;
PT := FrameScanLine01;
FrameScanLine01 := FrameScanLine02;
FrameScanLine02 := PT;
end;
procedure TWaterEffect.ClearWater;
begin
if FrameBuffer01 <> nil then
ZeroMemory(FrameBuffer01, (FrameWidth * FrameHeight) * SizeOf(Integer));
if FrameBuffer02 <> nil then
ZeroMemory(FrameBuffer02, (FrameWidth * FrameHeight) * SizeOf(Integer));
end;
constructor TWaterEffect.Create;
begin
inherited;
FrameLightModifier := 10;
FrameDamping := DampingConstant;
end;
destructor TWaterEffect.Destroy;
begin
if FrameBuffer01 <> nil then
FreeMem(FrameBuffer01);
if FrameBuffer02 <> nil then
FreeMem(FrameBuffer02);
if FrameScanLine01 <> nil then
FreeMem(FrameScanLine01);
if FrameScanLine02 <> nil then
FreeMem(FrameScanLine02);
if FrameScanLineScreen <> nil then
FreeMem(FrameScanLineScreen);
inherited;
end;
procedure TWaterEffect.DrawWater(ALightModifier: Integer;
Screen, Distance: TBitmap);
var
DX, DY: Integer;
I, C, X, Y: Integer;
P1, P2, P3: PIntArray;
PScreen, PDistance: PRGBArray;
PScreenDot, PDistanceDot: PRGBTriple;
BytesPerLine1, BytesPerLine2: Integer;
begin
Screen.PixelFormat := pf24bit;
Distance.PixelFormat := pf24bit;
FrameScanLineScreen[0] := Screen.ScanLine[0];
BytesPerLine1 := Integer(Screen.ScanLine[1]) -
Integer(FrameScanLineScreen[0]);
for I := 1 to FrameHeight - 1 do
FrameScanLineScreen[I] := PRGBArray(Integer(FrameScanLineScreen[I - 1]) +
BytesPerLine1);
begin
PDistance := Distance.ScanLine[0];
BytesPerLine2 := Integer(Distance.ScanLine[1]) - Integer(PDistance);
for Y := 0 to FrameHeight - 1 do
begin
PScreen := FrameScanLineScreen[Y];
P1 := FrameScanLine01[Max(Y - 1, 0)];
P2 := FrameScanLine01[Y];
P3 := FrameScanLine01[Min(Y + 1, FrameHeight - 1)];
for X := 0 to FrameWidth - 1 do
begin
DX := P2[Max(X - 1, 0)] - P2[Min(X + 1, FrameWidth - 1)];
DY := P1[X] - P3[X];
if (X + DX >= 0) and (X + DX < FrameWidth) and (Y + DY >= 0) and
(Y + DY < FrameHeight) then
begin
PScreenDot := @FrameScanLineScreen[Y + DY][X + DX];
PDistanceDot := @PDistance[X];
C := PScreenDot.rgbtBlue - DX;
if C < 0 then
PDistanceDot.rgbtBlue := 0
else if C > 255 then
PDistanceDot.rgbtBlue := 255
else
begin
PDistanceDot.rgbtBlue := C;
C := PScreenDot.rgbtGreen - DX;
end;
if C < 0 then
PDistanceDot.rgbtGreen := 0
else if C > 255 then
PDistanceDot.rgbtGreen := 255
else
begin
PDistanceDot.rgbtGreen := C;
C := PScreenDot.rgbtRed - DX;
end;
if C < 0 then
PDistanceDot.rgbtRed := 0
else if C > 255 then
PDistanceDot.rgbtRed := 255
else
begin
PDistanceDot.rgbtRed := C;
end;
end
else
begin
PDistance[X] := PScreen[X];
end;
end;
PDistance := PRGBArray(Integer(PDistance) + BytesPerLine2);
end;
end;
end;
procedure TWaterEffect.Render(Screen, Distance: TBitmap);
begin
CalculateWater;
DrawWater(FrameLightModifier, Screen, Distance);
end;
procedure TWaterEffect.SetDamping(Value: TWaterDamping);
begin
if (Value >= Low(TWaterDamping)) and (Value <= High(TWaterDamping)) then
FrameDamping := Value;
end;
procedure TWaterEffect.SetSize(EffectBackgroundWidth, EffectBackgroundHeight
: Integer);
var
I: Integer;
begin
if (EffectBackgroundWidth <= 0) or (EffectBackgroundHeight <= 0) then
begin
EffectBackgroundWidth := 0;
EffectBackgroundHeight := 0;
end;
FrameWidth := EffectBackgroundWidth;
FrameHeight := EffectBackgroundHeight;
ReallocMem(FrameBuffer01, FrameWidth * FrameHeight * SizeOf(Integer));
ReallocMem(FrameBuffer02, FrameWidth * FrameHeight * SizeOf(Integer));
ReallocMem(FrameScanLine01, FrameHeight * SizeOf(PIntArray));
ReallocMem(FrameScanLine02, FrameHeight * SizeOf(PIntArray));
ReallocMem(FrameScanLineScreen, FrameHeight * SizeOf(PRGBArray));
ClearWater;
if FrameHeight > 0 then
begin
FrameScanLine01[0] := FrameBuffer01;
FrameScanLine02[0] := FrameBuffer02;
for I := 1 to FrameHeight - 1 do
begin
FrameScanLine01[I] := @FrameScanLine01[I - 1][FrameWidth];
FrameScanLine02[I] := @FrameScanLine02[I - 1][FrameWidth];
end;
end;
end;
end.
1-در قسمت interfaceیونیت اصلی برنامه ،نام یونیت مورد که نظر که "unt_WaterEffect" می باشد را در قسمت Usesاضافه کنید.
2-یک تایمر با خاصیت Enable=true را به برنامه اضافه کنید و مقدار Interval آن را برابر 25 قرار دهید.
3-در قسمت تعاریف Private این دو متغییر را تعریف کنید :
Water: TWaterEffect;
FrameBackground: TBitmap;
1- یک متغییر سراسری به شکل زیر تعیریف کنید
var
X: Integer;
و ادامه برنامه هم در فرم اصلی برنامه به صورت زیر بنویسید.
procedure Tfrm_Main.FormCreate(Sender: TObject);
begin
tmr_1.Enabled := true;
FrameBackground := TBitmap.Create;
FrameBackground.Assign(img_1.Picture.Graphic);
img_1.Picture.Graphic := nil;
img_1.Picture.Bitmap.Height := FrameBackground.Height;
img_1.Picture.Bitmap.Width := FrameBackground.Width;
Water := TWaterEffect.Create;
Water.SetSize(FrameBackground.Width, FrameBackground.Height);
X := img_1.Height;
end;
procedure Tfrm_Main.FormDestroy(Sender: TObject);
begin
FrameBackground.Free;
Water.Free;
end;
procedure Tfrm_Main.img_1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Water.Bubble(X, Y, 1, 100);
end;
procedure Tfrm_Main.img_1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
Water.Bubble(X, Y, 1, 100);
end;
procedure Tfrm_Main.tmr_1Timer(Sender: TObject);
begin
if Random(8) = 1 then
Water.Bubble(-1, -1, Random(1) + 1, Random(500) + 50);
Water.Render(FrameBackground, img_1.Picture.Bitmap);
with img_1.Canvas do
begin
Brush.Style := bsClear;
font.size := 12;
font.Style := [];
font.Name := 'Comic Sans MS';
font.color := $E4E4E4;
Textout(190, 30, DateTimeToStr(Now));
end;
end;
اینم عکس و خود پروژه
پاسخ با نقل قول
