# Native Code > برنامه نویسی در Delphi > مباحث عمومی دلفی و پاسکال >  نمونه کدهای " گرافیکی - ریاضی "

## بهروز عباسی

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


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

منبع
موفق باشید.

----------


## یوسف زالی

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

----------


## یوسف زالی

توضیح:
در متد

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;

موفق باشید.

----------

