Форум: "Media";
Текущий архив: 2006.06.11;
Скачать: [xml.tar.bz2];
Вниз
точки на плоскости Найти похожие ветки
← →
Antonio (2006-01-08 17:36) [0]Из заданного на плоскости множества точек выбрать три различные точки так, чтобы
разность между площадью круга ограниченного окружностью, проходящей через эти три точки,
и площадью треугольника с вершинами в этих точках была минимальной.
← →
Fenik © (2006-01-08 19:35) [1]Какое совпадение! У меня есть как раз то, что тебе нужно :)))
function SquareDifference(X1, Y1, X2, Y2, X3, Y3: Double): Double;
{
X1, Y1, X2, Y2, X3, Y3 - координаты вершин треугольника;
Функция возвращает разность площадей круга, заданного описанной
возле треугольника окружностью, и данного треугольника.
}
function LineLength(PX1, PY1, PX2, PY2: Double): Double;
begin
// Длина отрезка по теореме Пифагора
Result := Sqrt(Sqr(PX1 - PX2) + Sqr(PY1 - PY2));
end;
var
P: Double; // Полупериметр
A, B, C: Double; // Длины сторон треугольника
STriang: Double; // Площадь треугольника (в квадрате)
SCircle: Double; // Площадь описанного круга
begin
A := LineLength(X1, Y1, X2, Y2);
B := LineLength(X2, Y2, X3, Y3);
C := LineLength(X3, Y3, X1, Y1);
P := (A + B + C) / 2;
// Площадь треугольника по формуле Герона
STriang := Sqrt(P*(P-A)*(P-B)*(P-C));
// Площадь круга описанного возле треугольника Pi * (R^2)
SCircle := Pi * Sqr(A * B * C / (STriang * 4));
// Разность площадей
Result := SCircle - STriang;
end;
← →
MBo © (2006-01-08 20:35) [2]>Fenik
При наличии координат вершин не стоит использовать формулу Герона
← →
Fenik © (2006-01-08 21:07) [3]> MBo © (08.01.06 20:35) [2]
> При наличии координат вершин не стоит использовать формулу Герона
Почему?
← →
Fenik © (2006-01-08 23:39) [4]Все, понял :)
С другой формулой попроще будет:function SquareDifference(X1, Y1, X2, Y2, X3, Y3: Double): Double;
{
Функция возвращает разность площадей круга, заданного описанной
возле треугольника окружностью, и данного треугольника.
}
var
A, B, C: Double; // Квадраты сторон треугольника
STriang: Double; // Площадь треугольника
SCircle: Double; // Площадь описанного круга
begin
A := Sqr(X1 - X2) + Sqr(Y1 - Y2);
B := Sqr(X2 - X3) + Sqr(Y2 - Y3);
C := Sqr(X3 - X1) + Sqr(Y3 - Y1);
STriang := Abs((X2-X1)*(Y3-Y1) - (X3-X1)*(Y2-Y1)) * 0.5;
SCircle := Pi * (A * B * C) / Sqr(STriang * 4);
Result := SCircle - STriang;
end;
← →
Fenik © (2006-01-09 00:21) [5]Можно даже избавиться от дополнительных переменных,
а функцию Пи заменить константой (ну это в любом случае стоит сделать):function SquareDifference(X1, Y1, X2, Y2, X3, Y3: Double): Double;
begin
Result := Abs((X2-X1)*(Y3-Y1) - (X3-X1)*(Y2-Y1)) * 0.5;
if Result > 0 then
Result := 3.14159265358979323846 *
(Sqr(X1 - X2) + Sqr(Y1 - Y2)) *
(Sqr(X2 - X3) + Sqr(Y2 - Y3)) *
(Sqr(X3 - X1) + Sqr(Y3 - Y1)) / Sqr(Result * 4) - Result;
end;
Ох уж эта болезненная страсть к оптимизации... :)))
← →
Antonio (2006-01-10 11:51) [6]Спосибо, а нет у тебя всего алгоритма? в том числе как эти точки рисовать и выбрать из них нужные.
← →
Fenik © (2006-01-11 02:12) [7]Есть. Но его можно ещё оптимизировать поиск, отбрасывая заведомо неподходящие треугольники.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Math;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
A: array of TPoint;
P1, P2, P3: Integer;
procedure Init;
procedure FindMinDif;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
Color := clBlack;
Init;
end;
procedure TForm1.FormPaint(Sender: TObject);
var I: Integer;
begin
with Canvas do begin
Pen.Color := RGB(250, 250, 190);
Brush.Color := Pen.Color;
Brush.Style := bsSolid;
for I := 0 to Length(A) do
with A[I] do Ellipse(X - 1, Y - 1, X + 2, Y + 2);
Brush.Style := bsFDiagonal;
PolyGon([A[P1], A[P2], A[P3]]);
end;
end;
procedure TForm1.Init;
var X, Y, N, WW: Integer;
begin
N := 0;
WW := Width div 7;
SetLength(A, (Width div WW) * (Height div WW));
{ Заполнение массива равномерно разбросанными по форме точками }
for X := 0 to Width div WW - 1 do
for Y := 0 to Height div WW - 1 do begin
A[N] := Point(X * WW + WW div 8 + Random(WW - WW div 8),
Y * WW + WW div 8 + Random(WW - WW div 8));
Inc(N);
end;
FindMinDif;
end;
function SquareDifference(X1, Y1, X2, Y2, X3, Y3: Double): Double;
const PiDiv16 = Pi / 16;
begin
Result := Abs((X2-X1)*(Y3-Y1) - (X3-X1)*(Y2-Y1)) * 0.5;
if Result > 0 then
Result := (Sqr(X1 - X2) + Sqr(Y1 - Y2)) *
(Sqr(X2 - X3) + Sqr(Y2 - Y3)) *
(Sqr(X3 - X1) + Sqr(Y3 - Y1)) *
PiDiv16 / Sqr(Result) - Result
else
{ Это на случай, когда точки совпадают либо лежат на одной прямой }
Result := MaxDouble;
end;
procedure TForm1.FindMinDif;
var I, J, K, L: Integer;
Dif, MinDif: Double;
begin
P1 := 0;
P2 := 1;
P3 := 2;
L := Length(A);
MinDif := MaxDouble;
for I := 0 to L - 3 do
for J := I + 1 to L - 2 do
for K := J + 1 to L - 1 do begin
Dif := SquareDifference(A[I].X, A[I].Y, A[J].X, A[J].Y, A[K].X, A[K].Y);
if Dif < MinDif then begin
MinDif := Dif;
P1 := I;
P2 := J;
P3 := K;
end;
end;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Init;
RePaint;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Init;
RePaint;
end;
end.
← →
Antonio © (2006-01-11 11:38) [8]Спосибо
← →
Antonio © (2006-01-11 11:48) [9]А нет ничего подобного только чтоб точки задавались Form1.Canvas.Pixels[x,y]:=clRed)???
← →
Fenik © (2006-01-11 19:27) [10]
procedure TForm1.FormPaint(Sender: TObject);
var I: Integer;
begin
with Canvas do begin
Pen.Color := RGB(250, 250, 190);
Brush.Color := Pen.Color;
Brush.Style := bsSolid;
for I := 0 to Length(A) do
Pixels[A[I].X, A[I].Y] := clRed;
Brush.Style := bsFDiagonal;
PolyGon([A[P1], A[P2], A[P3]]);
end;
end;
Страницы: 1 вся ветка
Форум: "Media";
Текущий архив: 2006.06.11;
Скачать: [xml.tar.bz2];
Память: 0.48 MB
Время: 0.014 c
