Долго бился над этой задачей, решил поделиться решением, поскольку в сети ничего на эту тему не нашёл (может плохо искал?). | Код |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ComCtrls, math;
type
TForm1 = class(TForm)
Image1: TImage;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Button1: TButton;
Edit6: TEdit;
Label6: TLabel;
Edit7: TEdit;
Label7: TLabel;
Edit8: TEdit;
Label8: TLabel;
Edit9: TEdit;
Label9: TLabel;
procedure Button1Click(Sender: TObject);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var x1,x2,y1,y2 :word; i: byte; Rect: TRect;
h1,h2,r1,r2,a,b,x,y,xx,yy,d:double; drawn:boolean;
const step = 0.01;
begin
Rect.Left:=0; Rect.Top:=0;
Rect.Right:=Image1.width;
Rect.bottom:=Image1.Height;
Image1.Canvas.FillRect(Rect);
r1:=StrToFloat(Edit1.Text); // Радиус основания 1-го конуса
r2:=StrToFloat(Edit2.Text); // Радиус основания 2-го конуса
h1:=StrToFloat(Edit3.Text); // Высота 1-го конуса
h2:=StrToFloat(Edit4.Text); // Высота 2-го конуса
x1:=StrToInt(Edit6.Text); // Абсцисса центра основания 1-го конуса
x2:=StrToInt(Edit7.Text); // Абсцисса центра основания 2-го конуса
y1:=StrToInt(Edit8.Text); // Ордината центра основания 1-го конуса
y2:=StrToInt(Edit9.Text); // Ордината центра основания 2-го конуса
d:=sqrt(sqr(x1-x2)+sqr(y1-y2)); // Расстояние между центрами оснований
// Рисуем основание 1-го конуса
image1.canvas.Pen.Color:=clgreen;
image1.canvas.Moveto(round(x1+r1),y1);
for i:=0 to 255 do
begin
image1.canvas.Lineto(round(x1+r1*cos(i*2*pi/255)),y1+round(r1*sin(i*2*pi/255)));
end;
image1.canvas.Pen.Color:=clblue;
// Рисуем основание 2-го конуса
image1.canvas.Moveto(round(x2+r2),y2);
for i:=0 to 255 do
begin
image1.canvas.Lineto(x2+round(r2*cos(i*2*pi/255)),y2+round(r2*sin(i*2*pi/255)));
end;
drawn:=false;
// Рисуем линию пересечения
image1.canvas.Pen.Color:=clred;
if r2<r1 then
begin
b:=0;
while b<R2 do // перебираем радиусы сечений конуса с меньшим радиусом основания
begin
a:=r1/h1*(h1-h2+h2/r2*b); // радиус сечения другого конуса
if a<=0 then begin b:=b+step; continue; end;
x:=(sqr(a)-sqr(b))/(2*d); // абсцисса точек пересечения в системе координат с центром посередине между центрами оснований конусов и осью абсцисс, проходящей через них.
y:=(sqr(a)+sqr(b))/2-1/4*sqr((sqr(a)-sqr(b))/d)-sqr(d)/4;
if y<0 then begin b:=b+step; continue; end;
y:=sqrt(y); // ордината верхней точки пересечения
// пересчёт в исходную систему координат
xx:=(x1+x2)/2+x*(x2-x1)/d+y*(y2-y1)/d;
yy:=(y1+y2)/2+x*(y2-y1)/d-y*(x2-x1)/d;
if not drawn then
begin
drawn:=true;
image1.canvas.Moveto(round(xx),round(yy));
end
else
image1.canvas.Lineto(round(xx),round(yy));
b:=b+step
end;
end
else // случай, когда больше радиус другого конуса
begin
a:=0;
while a<R1 do
begin
b:=r2/h2*(h2-h1+h1/r1*a);
if b<=0 then begin a:=a+step; continue; end;
x:=(sqr(a)-sqr(b))/(2*d);
y:=(sqr(a)+sqr(b))/2-1/4*sqr((sqr(b)-sqr(a))/d)-sqr(d)/4;
if y<0 then begin a:=a+step; continue; end;
y:=sqrt(y);
xx:=(x1+x2)/2+x*(x2-x1)/d+y*(y2-y1)/d;
yy:=(y1+y2)/2+x*(y2-y1)/d-y*(x2-x1)/d;
if not drawn then
begin
drawn:=true;
image1.canvas.Moveto(round(xx),round(yy));
end
else
image1.canvas.Lineto(round(xx),round(yy));
a:=a+step
end;
end;
// Теперь всё то же самое для нижних точек y=-sqrt
drawn:=false;
image1.canvas.Pen.Color:=clred;
if r2<r1 then
begin
b:=0;
while b<R2 do
begin
a:=r1/h1*(h1-h2+h2/r2*b);
if a<=0 then begin b:=b+step; continue; end;
x:=(sqr(a)-sqr(b))/(2*d);
y:=(sqr(a)+sqr(b))/2-1/4*sqr((sqr(a)-sqr(b))/d)-sqr(d)/4;
if y<0 then begin b:=b+step; continue; end;
y:=-sqrt(y); // ордината нижней точки пересечения
xx:=(x1+x2)/2+x*(x2-x1)/d+y*(y2-y1)/d;
yy:=(y1+y2)/2+x*(y2-y1)/d-y*(x2-x1)/d;
if not drawn then
begin
drawn:=true;
image1.canvas.Moveto(round(xx),round(yy));
end
else
image1.canvas.Lineto(round(xx),round(yy));
b:=b+step
end;
end
else
begin
a:=0;
while a<R1 do
begin
b:=r2/h2*(h2-h1+h1/r1*a);
if b<=0 then begin a:=a+step; continue; end;
x:=(sqr(a)-sqr(b))/(2*d);
y:=(sqr(a)+sqr(b))/2-1/4*sqr((sqr(a)-sqr(b))/d)-sqr(d)/4;
if y<0 then begin a:=a+step; continue; end;
y:=-sqrt(y);
xx:=(x1+x2)/2+x*(x2-x1)/d+y*(y2-y1)/d;
yy:=(y1+y2)/2+x*(y2-y1)/d-y*(x2-x1)/d;
if not drawn then
begin
drawn:=true;
image1.canvas.Moveto(round(xx),round(yy));
end
else
image1.canvas.Lineto(round(xx),round(yy));
a:=a+step
end;
end
end;
// для удобства тестирования изменение координат центра основания второго конуса в позицию курсора мыши
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Edit7.Text:=Inttostr(x);
Edit9.Text:=Inttostr(y);
Button1Click(nil)
end;
end.
|
|
Пересечение конусов вращения, с компланарными основаниями 
Загрузка ...
