Программное обеспечение для построения полей изолиний, страница 5

A,B массивы для хранения координат точек, образующих отрезок, z0- текущий уровень изолинии, исходящие данные массив oK содержищий координаты пересечения, если они имеются , Result- результат выполнения процедуры(Result=2-  отрезок принадлежит плоскости, Result=0- отрезок не принадлежит плоскости, Result=1- точка пересечения отрезка и плоскости).

Procedure OTP(A,B:TT;z0:Real;var oK:TT;var Result:integer);

 var

    m,n,p,al,bt,c,t0:real;

 begin

    Result:=1;

    if(A[3]<z0)and(B[3]<z0) then exit;

    if(A[3]>z0)and(B[3]>z0) then exit;

    Result:=2;

    if(A[3]=z0)and(B[3]<>z0) then begin

                                 oK[1]:=A[1];

                                 oK[2]:=A[2];

                                 oK[3]:=A[3];

                                 exit;

                                 end;

    if(B[3]=z0)and(A[3]<>z0) then begin

                                 oK[1]:=B[1];

                                 oK[2]:=B[2];

                                 oK[3]:=B[3];

                                 exit;

                                 end;

   Result:=3;

   if(A[3]=z0)and(B[3]=z0)then exit;

   Result:=2;

   al:=A[1];bt:=A[2];c:=A[3];

   m:=B[1]-A[1];n:=B[2]-A[2];p:=B[3]-A[3];

   t0:=-(c-z0)/(p);

   oK[1]:=al+m*t0;oK[2]:=bt+n*t0;oK[3]:=c+p*t0;

end;

Процедура нахождения координат пересечения треугольника и плоскости:

A,B,C- массивы для хранения координат точек, образующих треугольник, z0- текущий уровень изолинии, исходящие данные: массивы aa и bb для хранения точек пересечения плоскости и треугольника, Resрезультат работы процедуры (Res=3- треугольник принадлежит плоскости, Res=0-  треугольник не принадлежит плоскости, Res=2- треугольник пересекает плоскость).

Procedure TREUG(A,B,C:TT; z0:real; var aa,bb: TT; Var Res: integer);

Var K1,K2,K3:TT; ResultAB,ResultBC,ResultAC,xp,yp:integer;

Begin

 OTP(A,B,z0,K1,ResultAB);

 OTP(B,C,z0,K2,ResultBC);

 OTP(A,C,z0,K3,ResultAC);

 res:=0;

 if(ResultAB=0) and (ResultBC=0) and (ResultAC=0) then EXIT;

 if(ResultAB=2) and (ResultBC=2) and (ResultAC=2) then exit;

 if(ResultAB=2) and (ResultBC<>2) and (ResultAC<>2) then

 Begin   aa:=a; bb:=b; Res:=2; Exit  end;

 if(ResultAB<>2)and(ResultBC=2)and(ResultAC<>2) then

 Begin aa:=c; bb:=b; Res:=2; Exit  end;

 if(ResultAB<>2)and(ResultBC<>2)and(ResultAC=2) then

 begin  aa:=c; bb:=a; Res:=2; Exit  end;

 if(ResultAB=1) and (ResultBC=1) then

 Begin  aa:=k1; bb:=k2; Res:=2; Exit  end;

 if(ResultBC=1) and (ResultAC=1) then

 Begin  aa:=k3; bb:=k2; Res:=2; Exit  end;

 if(ResultAC=1) and (ResultAB=1) then

 Begin   aa:=k3; bb:=k1; Res:=2; Exit  end;

end;

Головная программа:

Var   FL:text;   XYZ:Q; NNN:S; RXY:R;

         gm,gd,Nt,Ntr,j,i,Lx,Ly,x0,y0,Xp,Yp,e,col,k:integer;

         z0,kx,ky,ymax,xmin:real;

        cod:char; f:string;

Var  nrxy, jj, x1, y1, x2, y2: integer;

Var   FL:text;   XYZ:Q; NNN:S; RXY:R; z0,aa,bb:TT;

         iz, niz, gm,gd,Nt,Ntr,j,i,Lx,Ly,x0,y0,Xp,Yp,e,col,Res:integer;

         kx,ky,ymax,xmin:real;

cod:char; f:string;

 Begin

Чтение исходных данных из файла:

Data(Nt,Ntr,x0,y0,lx,ly,Niz,XYZ,NNN,z0);

  DetectGraph(gm,gd); InitGraph(gm,gd,'');SetBkColor(black);

Вычисление коэффициентов пересчета:

koefic(XYZ,lx,ly,Nt,kx,ky,ymax,xmin);

Построение рамки по границе окна:

rectangle(x0-50,y0-20,x0+lx+40,y0+ly+20);

  Setcolor(Yellow);

Рисовка сетки:

setka(XYZ,NNN,Ntr,Nt,x0,y0,Red,xmin,ymax,kx,ky);

SetLineStyle(0,0,2);

В цикле рисуем изолинии требуемых уровней:

for iz:=1 to Niz do

begin

 nrxy:=0;

 For i:=1 to Ntr do

 Begin

 SetColor(Yellow);

  TREUG(XYZ[NNN[i,1]],XYZ[NNN[i,2]],XYZ[NNN[i,3]],z0[iz],aa,bb,Res);

Подпись значений изолиний

Podpis(Res,x0,y0,xp,yp,nrxy,iz,xmin,ymax,kx,ky,z0,aa,bb,RXY);

end;

end;

xp:=Round((x0+lx)/2); yp:=Round((y0+ly)/2);e:=0;

Рисовка реперов:

Cursor(XYZ,NNN,Ntr,x0,y0,lx, ly,col,e,xp,yp,nt,xmin,ymax,kx,ky);

CloseGraph;

End.