نمونه کدهای " گرافیکی - ریاضی "

[بهروز عباسی]

آموزش ایجاد افکت امواج آب بر روی عکس در دلفی
در مرحله اول یک یونیت جدید ایجاد کنید و نام آنرا به "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;


اینم عکس و خود پروژه

97033


منبع (http://stackoverflow.com/questions/10234727/how-to-make-a-water-effect-on-timage-or-anything)
موفق باشید.

[یوسف زالی]

سلام.
دوره جوونی یه شب زد به سرم که چرا مدار زمین گرد نیست.
این برنامه رو نوشتم که با کمی اصلاحات براتون می گذارم. شاید براتون جالب باشه.
البته در دو بعد هست که به راحتی می شه سه بعدیش کرد.
دیدم دوستایی سورس دادن، گفتم من هم کاری کرده باشم برا تشویق بقیه برا ادامه این کار (دادن سورس برنامه ها)

[یوسف زالی]

توضیح:
در متد


Universe.AddStar(TStar.Create(400, 250, 10, 100, -100, clRed));

به ترتیب = موقعیت افقی و عمودی، جرم، سرعت اولیه افقی و عمودی، رنگ و یک متغیر که نشان می دهد جرم ما می تواند حرکت کند یا نه. (دیفالت true)
در صورت برخورد دو جرم به هم هردو ایست می کنند و خاکستری می شند.
قابلیت افزودن هر تعداد جرم رو دارید.
با تغییر Interval تایمر زمان رو تند و کند کنید.

این خط:


procedure TUniverse.Render;
.
.
FillRect(Rect(0, 0, Width, Height));

رو کامنت کنید و جرکت خورشید رو false کنید تا اثرات جادبه سیارات رو رو هم بتونید ببینید.

این رو هم امتحان کنید:


Universe.AddStar(TStar.Create(150, 350, 1000, 0, -200, clRed));
Universe.AddStar(TStar.Create(200, 350, 10000, 0, -120, clBlue));
Universe.AddStar(TStar.Create(500, 350, 100000, 0, 0, clYellow, false));

یک چیزی شبیه خورشید-زمین-ماه و البته در مقیاس های غیر واقعی که نشون می ده تقریبا تعادل برقراره.

[SAASTN]

آقا دستت درد نکنه، خیلی حال کردم! امروز بی کار بودم با اجازت یه نیمچه UI براش نوشتم که راحتتر بشه حالتای متفاوتو ایجاد کرد.
ابر و باد و مه و خورشید و فلک در کارند
تا تو نانی به کف آری و به غفلت مخوری

عکسه برا دو سالشه!

[یوسف زالی]

سلام.
در راستای قرار دادن سورس های جالب، تصمیم گرفتم این بار این برنامه رو قرار بدم.
روی UI اصلا وقت نذاشتم. راستش سر لج و لج بازی فقط یک عکس باهاش درست کردم! :قهقهه:
این برنامه یک تصویر BitMap می گیره و خروجی یک تصویر دیگه می ده مثل این:

[یوسف زالی]

سلام.
بازم از زور بی خوابی (:لبخند:) تصمیم گرفتم دستی به سورس سولار سیستم ببرم و تبدیلش کنم به بازی بیلیارد!!!
خوب اشکالاتی داره.
مثلا اصل پایستگی اندازه حرکت نیوتن توش "نمی دونم چرا" رعایت نمی شه.
حالا من سورس رو براتون می گذارم. برای ایده گرفتن خیلی خوبه.
اصل این کار رو با پاسکال دوره دانشجویی برا بازی "گردو بازی" نوشته بودم البته با الگوریتم سرسام آور و ماکارونی. هر چی بود داشت خوب کار می کرد.
حالا من این کارم رو می گذارم اگه کسی هم پیدا بشه رفع اشکالش کنه که خیلی بهتر می شه.
نظر هم اگر دادید که خیلی بهتر!

[بهروز عباسی]

با این تابع می تونید افکت جالب FadeOut( محو شدن) رو روی یک تصویر اعمال کنید.
{ .... }
uses JPEG;

procedure ImageToBitmap(Img: TImage; BMP: TBitmap);
begin
if (BMP = nil) then
begin
BMP := TBitmap.Create;
BMP.PixelFormat := pfDevice;
end;

BMP.Width := Img.Picture.Width;
BMP.Height := Img.Picture.Height;

if Img.Picture.Graphic is TJPEGImage then
BMP.Canvas.Draw(0, 0, Img.Picture.Graphic)
else
BMP.Canvas.Draw(0, 0, Img.Picture.Bitmap);
end;

procedure FadeOut(const B: TImage; Pause: integer);
var
BMP: TBitmap;
BPS: integer;
W, H: integer;
pBA: pByteArray;
Counter: integer;
begin
BMP := TBitmap.Create;
BMP.PixelFormat := pfDevice;
ImageToBitmap(B, BMP);

try
BPS := Abs(integer(BMP.ScanLine[1]) - integer(BMP.ScanLine[0]));
except
raise exception.Create('Error!');
end;

{ Decrease the RGB components of each single pixel }
for Counter := 1 to 256 do
begin
for H := 0 to BMP.Height - 1 do
begin
pBA := BMP.ScanLine[H];
for W := 0 to BPS - 1 do
if pBA^[W] >= 0 then
pBA^[W] := pBA^[W] - 1;
end;

Sleep(Pause);
B.Picture.Bitmap := BMP;
B.Refresh;
end;
end;

// the following is an example how to use the procedure
procedure TForm1.btn_RunClick(Sender: TObject);
begin
FadeOut(img_Source, 3)
end;

موفق باشید.