نمایش نتایج 1 تا 7 از 7

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

  1. #1

    آموزش ایجاد افکت امواج آب بر روی عکس در دلفی ( پردازش تصویر)

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

    منبع
    موفق باشید.
    آخرین ویرایش به وسیله بهروز عباسی : سه شنبه 07 اردیبهشت 1395 در 20:42 عصر
    Everything that has a beginning has an end. ... The End?



  2. #2

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

    سلام.
    دوره جوونی یه شب زد به سرم که چرا مدار زمین گرد نیست.
    این برنامه رو نوشتم که با کمی اصلاحات براتون می گذارم. شاید براتون جالب باشه.
    البته در دو بعد هست که به راحتی می شه سه بعدیش کرد.
    دیدم دوستایی سورس دادن، گفتم من هم کاری کرده باشم برا تشویق بقیه برا ادامه این کار (دادن سورس برنامه ها)
    عکس های ضمیمه عکس های ضمیمه
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله یوسف زالی : چهارشنبه 06 دی 1391 در 23:00 عصر
    توابع تبدیل تاریخ با دقت 5000 سال
    پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840

    دوستای گلم حمایت کنید : https://cafebazaar.ir/app/com.nikanmehr.marmarxword/


    نرم افزار پخش مویرگی

  3. #3

    نقل قول: شبیه سازی Solar System

    توضیح:
    در متد

    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));


    یک چیزی شبیه خورشید-زمین-ماه و البته در مقیاس های غیر واقعی که نشون می ده تقریبا تعادل برقراره.
    آخرین ویرایش به وسیله Felony : سه شنبه 12 دی 1391 در 07:57 صبح
    توابع تبدیل تاریخ با دقت 5000 سال
    پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840

    دوستای گلم حمایت کنید : https://cafebazaar.ir/app/com.nikanmehr.marmarxword/


    نرم افزار پخش مویرگی

  4. #4
    کاربر دائمی آواتار SAASTN
    تاریخ عضویت
    خرداد 1385
    محل زندگی
    تهران
    سن
    39
    پست
    730

    نقل قول: شبیه سازی Solar System

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

    عکسه برا دو سالشه!
    عکس های ضمیمه عکس های ضمیمه
    فایل های ضمیمه فایل های ضمیمه

  5. #5

    تبدیل تصویر به متن !!

    سلام.
    در راستای قرار دادن سورس های جالب، تصمیم گرفتم این بار این برنامه رو قرار بدم.
    روی UI اصلا وقت نذاشتم. راستش سر لج و لج بازی فقط یک عکس باهاش درست کردم!
    این برنامه یک تصویر BitMap می گیره و خروجی یک تصویر دیگه می ده مثل این:
    عکس های ضمیمه عکس های ضمیمه
    فایل های ضمیمه فایل های ضمیمه
    توابع تبدیل تاریخ با دقت 5000 سال
    پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840

    دوستای گلم حمایت کنید : https://cafebazaar.ir/app/com.nikanmehr.marmarxword/


    نرم افزار پخش مویرگی

  6. #6

    شبیه سازی بازی بیلیارد - برخورد توپ ها به هم و تغییر جهت آنها

    سلام.
    بازم از زور بی خوابی () تصمیم گرفتم دستی به سورس سولار سیستم ببرم و تبدیلش کنم به بازی بیلیارد!!!
    خوب اشکالاتی داره.
    مثلا اصل پایستگی اندازه حرکت نیوتن توش "نمی دونم چرا" رعایت نمی شه.
    حالا من سورس رو براتون می گذارم. برای ایده گرفتن خیلی خوبه.
    اصل این کار رو با پاسکال دوره دانشجویی برا بازی "گردو بازی" نوشته بودم البته با الگوریتم سرسام آور و ماکارونی. هر چی بود داشت خوب کار می کرد.
    حالا من این کارم رو می گذارم اگه کسی هم پیدا بشه رفع اشکالش کنه که خیلی بهتر می شه.
    نظر هم اگر دادید که خیلی بهتر!
    عکس های ضمیمه عکس های ضمیمه
    فایل های ضمیمه فایل های ضمیمه
    توابع تبدیل تاریخ با دقت 5000 سال
    پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840

    دوستای گلم حمایت کنید : https://cafebazaar.ir/app/com.nikanmehr.marmarxword/


    نرم افزار پخش مویرگی

  7. #7

    اعمال افکت FadeOut بر روی تصاویر

    با این تابع می تونید افکت جالب 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;


    موفق باشید.
    آخرین ویرایش به وسیله بهروز عباسی : سه شنبه 07 اردیبهشت 1395 در 20:35 عصر
    Everything that has a beginning has an end. ... The End?



تاپیک های مشابه

  1. منابع، مراجع و نمونه کدهای مفید Silverlight
    نوشته شده توسط علیرضا مداح در بخش Silverlight
    پاسخ: 13
    آخرین پست: سه شنبه 13 تیر 1391, 13:56 عصر
  2. کدهای گرافیکی
    نوشته شده توسط fshb_ 1370 در بخش برنامه نویسی با زبان C و ++C
    پاسخ: 3
    آخرین پست: شنبه 25 مهر 1388, 10:32 صبح
  3. نمونه کدهای آموزشی
    نوشته شده توسط Soroush.Sarabi در بخش C#‎‎
    پاسخ: 8
    آخرین پست: جمعه 12 تیر 1388, 08:44 صبح
  4. خبر: چند نمونه کارهای گرافیکی زیبا
    نوشته شده توسط vahid_d_0101 در بخش برنامه نویسی در 6 VB
    پاسخ: 17
    آخرین پست: جمعه 22 شهریور 1387, 23:34 عصر
  5. نمونه کدهای ASP.NET برای شروع
    نوشته شده توسط dr_g در بخش ASP.NET Web Forms
    پاسخ: 1
    آخرین پست: جمعه 02 دی 1384, 21:22 عصر

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •