Показать сообщение отдельно
  #7  
Старый 23.01.2012, 12:35
chainik chainik вне форума
Начинающий
 
Регистрация: 30.06.2008
Сообщения: 140
Репутация: 8882
По умолчанию

Код:
{----------------------------------------------------------------------
    здесь исправленный алгоритм. От точки (x,y) ищется из 4-ех соседних
    наиболее близкая по значению функции и в эту точку проводится вектор
    ( а не во все как в моем предыд алгоритме).
    В качестве функции здесь как пример конус опрокинутый вершиной на коорд плоскость.
    Соответственно изолинии- это сечения конуса те окружности.
    Рмсует на TImage размером 200х200 пикс
-------------------------------------------------------------------------}


const
Delta=1;
Epsilon=0.8;

var
H:extended;


function Isoln(x,y:extended):extended;
begin
Result:=Sqrt((x-100)*(x-100)+(y-100)*(y-100));  //конус
end;

{--------------------------------------------------------
    находит оптимальный путь
    возвращает true- путь найден
---------------------------------------------------------}
function FindTrace(x,y:extended;const H,Epsilon:extended; out OutX,OutY:extended):boolean;
begin
Result:=(abs(Isoln(x,y) - H) < Epsilon);
if Result then
    begin
    OutX:=x-Delta;OutY:=y;
    if abs(Isoln(x+Delta,y) - H) < abs(Isoln(OutX,OutY) - H) then
        OutX:=X+Delta;
    if abs(Isoln(x,y-Delta) - H) < abs(Isoln(OutX,OutY) - H) then
        OutY:=Y-Delta;
    if abs(Isoln(x,y+Delta) - H) < abs(Isoln(OutX,OutY) - H) then
        OutY:=Y+Delta;
    end;
end;

{--------------work----------------------------}
procedure TForm1.Button1Click(Sender: TObject);
var
OutX,OutY,x,y:extended;
begin
H:=StrToFloat(Edit1.Text);
x:=0;

with Image1.Canvas do
while x < 200 do
    begin
    y:=0;
    while y < 200 do
        begin
        if FindTrace(x,y,H,Epsilon,OutX,OutY) then
            begin
            MoveTo(round(x),round(y));LineTo(round(OutX),round(OutY));
            end;
        y:=y+Delta;
        end;
    x:=x+Delta;
    end;

end;

end.
Ответить с цитированием