Посчитать Фрактальную Размерность

Тема в разделе "Pascal and Delphi", создана пользователем Dimomaas, 19 мар 2013.

  1. Dimomaas

    Dimomaas New Member

    Регистрация:
    18 мар 2013
    Сообщения:
    1
    Симпатии:
    0
    Надо посчитать фрактальную рамерность замкнутой кривой. Для этого надо "обойти" всю кривую окружностями. Как это реализовать подскажите.

    Вот код который я написал:

    Код (Text):
    unit Unit1;

    interface

    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, Menus, StdCtrls, ExtCtrls, JPEG, Math;

    type
    TForm1 = class(TForm)
    mm1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    Image: TImage;
    But1: TButton;
    but2: TButton;
    OD1: TOpenDialog;
    procedure N3Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    procedure DrawCircle(x1, y1, R : Integer);
    procedure But1Click(Sender: TObject);
    procedure but2Click(Sender: TObject);
    private
    { Private declarations }
    public
    { Public declarations }
    end;

    var
    Form1: TForm1; x, y,c:Integer; arr:array[0..473, 0..289] of Integer;

    implementation

    {$R *.dfm}

    var ass,ass2:Integer;

    procedure TForm1.N3Click(Sender: TObject);
    begin
    Form1.Close;
    end;

    procedure TForm1.N2Click(Sender: TObject); //Добавляет картинку и вносит в массив координаты точек кривой 0 - черный цвет, 1 - белый цвет
    var Fname:string;   Bitmap: TBitmap; i,j:Integer; f:file;
    begin
    if OD1.Execute then
    begin
    FName := OD1.FileName;
    begin
    Bitmap:=TBitmap.Create;
    Bitmap.LoadfromFile(Fname);

    With Image.Picture.bitmap do
    Begin
    Width:=Bitmap.Width;
    height:=Bitmap.Height;
    Palette:=Bitmap.Palette;
    Canvas.draw(0,0,bitmap);
    Refresh;
    end;
    end;
    end;
    for i:=0 to 289 do
    begin
    for j:=0 to 473 do
    begin
    if Form1.Image.Picture.Bitmap.Canvas.Pixels[i,j]=clblack then
    begin
    Arr[i,j]:=1;
    end
    else
    begin
    Arr[i,j]:=0;
    end;
    end;
    end;
    end;

    procedure SearchNew1(a,b:integer);// поиск пересечений окружности с кривой
    var i,r,a11,b11:Integer; exit,exit1:Boolean;
    begin
    r:=16;
    a11:=a;
    b11:=b;
    exit1:=false;
    for a:=0 to 289 do
    begin
    for b:=0 to 473 do
    begin
    if ((Sqr(a-a11)+sqr(b-b11))=Sqr(16)) and (Arr[a,b]=1) then    //проверяем что точка принадлежит окружности радиуса 16
    begin
    ass:=a;
    ass2:=b;
    exit1:=False;
    exit:=False;
    end;
    end;
    end;
    end;

    procedure TForm1.ImageMouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    begin
    Form1.Image.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
    Form1.Image.Picture.Bitmap.Canvas.Ellipse(x-16,y-16,x+16,y+16);
    SearchNew1(x,y);
    Form1.Image.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
    Form1.Image.Picture.Bitmap.Canvas.Ellipse(ass-16,ass2-16,ass+16,ass2+16);
    SearchNew1(ass,ass2);
    Form1.Image.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
    Form1.Image.Picture.Bitmap.Canvas.Ellipse(ass-16,ass2-16,ass+16,ass2+16);
    SearchNew1(ass,ass2);
    Form1.Image.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
    Form1.Image.Picture.Bitmap.Canvas.Ellipse(ass-16,ass2-16,ass+16,ass2+16);
    SearchNew1(ass,ass2);
    Form1.Image.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
    Form1.Image.Picture.Bitmap.Canvas.Ellipse(ass-16,ass2-16,ass+16,ass2+16);
    SearchNew1(ass,ass2);
    Form1.Image.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
    Form1.Image.Picture.Bitmap.Canvas.Ellipse(ass-16,ass2-16,ass+16,ass2+16);
    end;
    procedure TForm1.But1Click(Sender: TObject);
    begin
    DrawCircle(ass,ass2, 16);
    SearchNew1(ass,ass2);
    end;

    procedure TForm1.but2Click(Sender: TObject);
    var
    tx:textfile;
    i,j:integer;
    a:array [1..10,1..10] of integer;
    begin
    randomize;
    AssignFile(tx,'G:\1.txt');
    Rewrite(tx);
    for i:=1 to 289 do
    begin
    for j:=1 to 473 do
    begin
    Write(tx,Arr[i,j]);
    end;
    end;
    closefile(tx);
    end;

    end.
     

    Вложения:

    • 1.jpg
      1.jpg
      Размер файла:
      32,6 КБ
      Просмотров:
      11
Загрузка...

Поделиться этой страницей