Zistí či body A,B,C ležia na jednej priamke a nájde parametrické rovnice priamok A-B, A-C, B-C

{ 3DPRIAM.PAS               Copyright (c) TrSek alias Zdeno Sekerak }
{ Zistite ci body A,B,C lezia na jednej priamke                     }
{ Vstup : cisla A,B,C                                               }
{ Vystup: Zisti ci body lezia na jednej priamke                     }
{         Ak nie potom najde parametricke rovnice priamok           }
{                                                                   }
{ Datum:17.12.2000                             http://www.trsek.com }
 
program Priamka_3D;
uses crt;
var
   a,b,c:array[1..3] of real;
   k,q:array[1..3,1..3] of real;
 
{ Vypocita smernicu [k] pre riesenie y=k*x+q }
function smer( a1,b1,a2,b2: real) : real;
begin
     if( (b1-a1) <> 0 ) then begin
          smer := ( b2 - a2 ) / ( b1 - a1 );
         end
     else
         begin
          writeln('Pocas vypoctu nastalo delenie nulou, riesenie nemusi byt korektne !');
          smer := 0;
     end;
end;
 
{ Vypocita konstantu [q] pre riesenie y=k*x+q }
function konst( a1,b1,a2,b2: real) : real;
begin
     if( (b1-a1) <> 0 ) then
         konst := b2 - ( b1 * ( b2 - a2) / ( b1 - a1 ))
     else
         konst := 0;
end;
 
{ Vypise parametricke riesenie rovnice }
procedure VypParRov( k2,q2,k3,q3 : real );
begin
     writeln('x = x');
 
     if( q2 >= 0 ) then
         writeln('y = ', k2:0:3, '*x +', q2:0:3 )
     else
         writeln('y = ', k2:0:3, '*x ', q2:0:3 );
 
     if( q3 >= 0 ) then
         writeln('z = ', k3:0:3, '*x +', q3:0:3 )
     else
         writeln('z = ', k3:0:3, '*x ', q3:0:3 );
 
     writeln;
end;
 
begin
 
   repeat
 
     writeln('Zistite ci body A,B,C lezia na jednej priamke.');
     writeln('Ak nie najdite parametricke rovnice priamok.');
 
     writeln('Zadaj bod A=[a1,a2,a3]');
     write('a1='); readln(a[1]);
     write('a2='); readln(a[2]);
     write('a3='); readln(a[3]);
 
     writeln('Zadaj bod B=[b1,b2,b3]:');
     write('b1='); readln(b[1]);
     write('b2='); readln(b[2]);
     write('b3='); readln(b[3]);
 
     writeln('Zadaj bod C=[c1,c2,c3]:');
     write('c1='); readln(c[1]);
     write('c2='); readln(c[2]);
     write('c3='); readln(c[3]);
 
     writeln;
     writeln('Riesenie:');
     writeln('---------');
 
     { priamka A-B }
     k[1,2] := smer ( a[1], b[1], a[2], b[2] );
     q[1,2] := konst( a[1], b[1], a[2], b[2] );
     k[1,3] := smer ( a[1], b[1], a[3], b[3] );
     q[1,3] := konst( a[1], b[1], a[3], b[3] );
 
     { priamka A-C }
     k[2,2] := smer ( a[1], c[1], a[2], c[2] );
     q[2,2] := konst( a[1], c[1], a[2], c[2] );
     k[2,3] := smer ( a[1], c[1], a[3], c[3] );
     q[2,3] := konst( a[1], c[1], a[3], c[3] );
 
     { priamka B-C }
     k[3,2] := smer ( b[1], c[1], b[2], c[2] );
     q[3,2] := konst( b[1], c[1], b[2], c[2] );
     k[3,3] := smer ( b[1], c[1], b[3], c[3] );
     q[3,3] := konst( b[1], c[1], b[3], c[3] );
 
     writeln('Parametricke riesenie priamky A-B je:');
     VypParRov( k[1,2], q[1,2], k[1,3], q[1,3] );
 
     if(   ( k[1,2] = k[2,2] ) and ( k[1,2] = k[3,2] )
       and ( k[1,3] = k[2,3] ) and ( k[1,3] = k[3,3] )
       and ( q[1,2] = q[2,2] ) and ( q[1,2] = q[3,2] )
       and ( q[1,3] = q[2,3] ) and ( q[1,3] = q[3,3] )) then begin
          writeln('Body A,B,C lezia na jednej priamke.');
         end
     else
         begin
 
          writeln('Parametricke riesenie priamky A-C je:');
          VypParRov( k[2,2], q[2,2], k[2,3], q[2,3] );
 
          writeln('Parametricke riesenie priamky B-C je:');
          VypParRov( k[3,2], q[3,2], k[3,3], q[3,3] );
 
     end;
 
     writeln('Opakovat znova ? [ESC-koniec]');
 
   until( readkey = #27 );
end.