home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG094.ARC / GRAPH3DP.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  9KB  |  368 lines
  1. Program Display_3D_Graphics;
  2. {This program originally published in 80 Microcomputing
  3.  ( now called  Micro 80) ,March 1982 page 138
  4.  Written by E. Foglin, 42K Southwood Apts.,Amherst,
  5.             MA. 01002. Copyrighted March 1981.
  6.  
  7.  Translated by R.K.Hallworth, 8 Rodney St., Bayswater, VIC. 3153.
  8.                from BASIC to PASCAL
  9.                the Connect procedure to ensure that only
  10.                the sections of lines found on screen are plotted was
  11.                written by R.K.H.
  12.  
  13. Operation
  14.          Three objects a square based pyramid and two boxes can be
  15.           observed from any position. First give the observers
  16.           position X Y Z (seperate the X Y Z components with spaces
  17.           e.g  30 -100 50) then give the point you are looking at
  18.           (e.g. 10 40 0). The program will then draw a perspective
  19.           view of the objects}
  20. {$I HIRES4.I}
  21. {$I DRAW.i}
  22.  
  23. { *** adaptions to use Premium Graphics Package *** }
  24.  
  25. Procedure PutCurs(x,y:integer);
  26.  
  27. begin
  28.      GotoXY(X+1,Y+1)
  29. end;
  30.  
  31. Procedure Plot(X0,y0,x1,y1:integer);
  32.  
  33. begin
  34.      Draw(x0,y0,x1,y1,1)
  35. end;
  36.  
  37. Procedure Init80;
  38.  
  39. begin
  40.      SetVideo(80)
  41. end;
  42.  
  43. Procedure Cls;
  44.  
  45. begin
  46.   ClrScr
  47. end;
  48.  
  49. {*** end of adaptions ***}
  50.  
  51. Type
  52.    Pnt = array[1..21,1..3] of integer;
  53.    Conects = array[1..54] of integer;
  54.    Prj = array[1..21,1..2] of real;
  55. Const
  56.    Points:Pnt =( ( 10,40,0),  {Point 1 (X,Y,Z) }
  57.                  ( 30,40,0),  {Point 2 }
  58.                  (20,49,0),   {Point 3 etc. ....}
  59.                  (20,31,0),
  60.                  (20,40,40),
  61.                  (20,10,0),
  62.                  (20,30,0),
  63.                  (40,10,0),
  64.                  (40,30,0),
  65.                  (20,10,20),
  66.                  (20,30,20),
  67.                  (40,10,20),
  68.                  (40,30,20),
  69.                  (0,0,0),
  70.                  (0,10,0),
  71.                  (10,0,0),
  72.                  (10,10,0),
  73.                  (0,0,30),
  74.                  (0,10,30),
  75.                  (10,0,30),
  76.                  (10,10,30));
  77.    Conections:conects =
  78.                 (1,2,3,4,      {Point 1 connects to 2 points point3 & point4}
  79.                  2,2,3,4,      {Point 2 connects to 2 points point3 & point4}
  80.                  5,4,1,3,2,4,
  81.                  6,3,7,8,10,
  82.                  9,3,7,8,13,
  83.                  12,3,8,10,13,
  84.                  11,3,7,13,10,
  85.                  14,3,15,16,18,
  86.                  17,3,15,16,21,
  87.                  20,3,16,18,21,
  88.                  19,3,15,21,18);
  89.    ConSize=54; {number of elements in the conections array}
  90.    NumberOfPoints=21;
  91.    MaxY=255;MaxX=511;
  92. Var
  93.    Response     :Char;
  94.    CX,CY        :integer;
  95.    Count    :Integer;
  96.    I1,I2,I3,I4,
  97.    XO,YO,ZO,
  98.    XV,YV,ZV   :Integer;
  99.    XP,YP,ZP,
  100.    SX,SY,Z    :Real;
  101.  
  102.    AV,AX,AY,TA,TH,T1,AR,T2,TX,KS,DS,
  103.    P2                 :Real;
  104.  
  105.    Again,OnScreen     :Boolean;
  106.    C                  :Prj;
  107.  
  108. Procedure FindQuad;
  109. Begin
  110.           if ax<>0 then
  111.           Begin
  112.              av:=ArcTan(ay/ax);
  113.              if ax>0 then
  114.              Begin
  115.                if ay<0 then av:=av+2*Pi;
  116.              end
  117.              else
  118.                 av:=av+Pi;
  119.           end
  120.           else
  121.              if ay>0 then av:=Pi/2
  122.              else av:=3*Pi/2;
  123. end;
  124.  
  125.  
  126.  
  127.  
  128.  
  129. Procedure FindOnScreen(Var Xa,Ya,X2,Y2:Integer);
  130. Var
  131.   Xn,Yn,Xe,Ye:Real;
  132.   Slope      :Real;
  133.  
  134. Procedure FindEdgePoint;
  135. begin
  136.      If Xa<>X2 then
  137.      Begin
  138.  
  139.           Yn:=Slope*(Xe-Xa)+Ya;
  140.           Xn:=Xe;
  141.           if (Yn>MaxY) or (Yn<0) then
  142.             if Slope<>0 then
  143.             Begin
  144.                Xn:=(Ye-Ya)/Slope+Xa;
  145.                Yn:=Ye;
  146.             End
  147.             Else
  148.                OnScreen:=FALSE;
  149.           if (Xn>MaxX) or (Xn<0) then OnScreen:=FALSE;
  150.        End
  151.        Else
  152.        Begin
  153.           Yn:=Ye;
  154.           Xn:=Xa;
  155.           if (Xn>MaxX) or (Xn<0) then OnScreen:=FALSE;
  156.        End;
  157.  End;
  158. Procedure FindBoundary(X,Y:integer);
  159.  
  160. Begin
  161. If X>MaxX then
  162.    Begin
  163.         Xe:=MaxX;
  164.         If Slope>0 then Ye:= MaxY else Ye:= 0;
  165.    end;
  166. If X<0 then
  167.    Begin
  168.         Xe:=0;
  169.         If Slope>0 then Ye:=0 else Ye:=MaxY;
  170.    end;
  171. If Y>MaxY then
  172.    Begin
  173.         Ye:=MaxY;
  174.         if Slope>0 then Xe:=MaxX else Xe:=0
  175.    End;
  176. If Y<0 then
  177.    Begin
  178.         Ye:=0;
  179.         If Slope>0 then Xe:=0 else Xe:=MaxX;
  180.    End;
  181. End;
  182. begin
  183.      OnScreen:=TRUE;
  184.      if Xa<>X2 then Slope:=(Ya-Y2)/(Xa-X2) else Slope:=990;
  185.      if not(Ya in [0..255]) or (Xa<0) or (Xa>511) then
  186.      Begin
  187.        FindBoundary(Xa,Ya);
  188.        FindEdgePoint;
  189.        Xa:=Round(Xn);Ya:=Round(Yn);
  190.      end;
  191.      if not( Y2 in [0..255] ) or (X2<0) or (x2>511) then
  192.      Begin
  193.         FindBoundary(X2,Y2);
  194.         FindEdgePoint;
  195.         X2:=Round(Xn);Y2:=Round(Yn);
  196.      end;
  197. end;
  198. Procedure ConnectPoints;
  199. begin
  200.      FindOnScreen(I1,I2,I3,I4);
  201.      if OnScreen then
  202.      begin
  203.            plot(I1,I2,I3,I4);
  204.            putCurs(30,15);
  205.      end;
  206. end;
  207.  
  208. Procedure DrawFigures;
  209. Var
  210.    ConPos:Integer;
  211.    NumOfCons:Integer;
  212. begin
  213.      ConPos:=1;
  214.      While ConPos<ConSize do
  215.      Begin
  216.          I1:=Round(C[Conections[ConPos],1]);
  217.          I2:=Round(C[Conections[ConPos],2]);
  218.          NumOfCons:=Conections[ConPos+1];
  219.          for Count:=1 to NumOfCons do
  220.          Begin
  221.              I3:=Round(C[Conections[ConPos+1+Count],1]);
  222.              I4:=Round(C[Conections[ConPos+1+count],2]);
  223.              ConnectPoints;
  224.          end;
  225.          ConPos:=ConPos+NumOfCons+2;
  226.       end;
  227.   end;
  228.   Function Sgn(x:Real):Integer;
  229.      Begin
  230.            if x>0 then Sgn:=1;
  231.            if x=0 then Sgn:=0;
  232.            if x<0 then Sgn:=-1;
  233.      end;
  234.   Procedure FindProjections;
  235.  
  236.   Function  SqrR(X:Integer):Real;
  237.   Begin
  238.       SqrR:= Sqr(X*1.0);
  239.   end;
  240.  
  241.   Begin
  242.        for Count:=1 to NumberOfPoints do
  243.        Begin
  244.            XP:=Points[Count,1]-XO;
  245.            YP:=Points[Count,2]-YO;
  246.            Z:=ZO-Points[Count,3];
  247.            AY:=YP;AX:=XP;
  248.            FindQuad;
  249.            PutCurs(0,0);
  250.            T1:=TA-AV;AR:=Cos(T1)*Sqrt( Sqr(XP) + Sqr(YP) );
  251.            AX:=Z;
  252.            if Z>0 then
  253.            Begin
  254.               AY:=Abs(AR);
  255.               FindQuad;
  256.               TX:=AV*Sgn(AR);
  257.            End
  258.            else
  259.            Begin
  260.               AY:=AR;
  261.               FindQuad;
  262.               TX:=AV;
  263.            end;
  264.            T2:=TH-TX;
  265.            if Abs(T2)>=P2 then
  266.               sx:=936
  267.            else
  268.            Begin
  269.               SY:=Round(KS*Sin(T2)/Cos(T2));
  270.               DS:=Sin(TX)*Sqrt(Sqr(SY)+Sqr(KS));
  271.               if DS<>0 then
  272.                  SX:=Round(DS*Sin(T1)/Cos(T1))
  273.               else
  274.               Begin
  275.                  SX:=Round(KS/Cos(TH)*Sqrt(Sqr(XP)+Sqr(YP))/Z*Sgn(T1));
  276.                  if Abs(T1)>P2 then SX:=-SX;
  277.               end;
  278.            end;
  279.            C[Count,1]:=SX+CX;C[Count,2]:=CY-SY*0.67;
  280.        end;
  281. end;
  282.  
  283. Procedure InputObsPos;
  284.  
  285. Procedure ReadVal(Var X:integer);
  286.  
  287. Var ValSt:string[4];
  288.     Code,Temp:integer;
  289. begin
  290.      ValSt:='';
  291.      Buflen:=4;
  292.      Read(ValSt);
  293.      Val(ValSt,Temp,Code);
  294.      If (Code=0) and (Length(ValSt)<>0)
  295.                then x:=temp
  296.                else
  297.                   begin
  298.                       For temp:=1 to length(ValSt) do write(#127 {del});
  299.                       Write(x)
  300.                    end
  301. end;
  302.  
  303. Begin
  304.      PutCurs(0,0);
  305.      Write('Draw Y/N');
  306.      Repeat
  307.         Read(Kbd,Response);
  308.      until Response in ['Y','y','N','n'];
  309.      if Response in ['Y','y'] then again:=TRUE else again:=FALSE;
  310.      if again then
  311.      Begin
  312.         PutCurs(0,0);
  313.         Write('Observers Co-ordinates ',XO,' ',YO,' ',ZO);
  314.         PutCurs(4,1);
  315.         Write('X=');
  316.         ReadVal(XO);
  317.         PutCurs(11,1);
  318.         write('Y=');
  319.         ReadVal(YO);
  320.         PutCurs(18,1);
  321.         Write('Z=');
  322.         ReadVal(ZO);
  323.         PutCurs(0,2);
  324.         Write('Viewing Co-Ordinates   ',XV,' ',YV,' ',ZV);
  325.         PutCurs(4,3);
  326.         Write('X=');
  327.         ReadVal(XV);
  328.         PutCurs(11,3);
  329.         write('Y=');
  330.         ReadVal(YV);
  331.         PutCurs(18,3);
  332.         Write('Z=');
  333.         ReadVal(ZV);
  334.         AX:=XV-XO;AY:=YV-YO;
  335.         FindQuad;
  336.         TA:=AV;
  337.         AY:=Sqrt(Sqr(AX)+Sqr(AY));
  338.         AX:=ZO-ZV;
  339.         FindQuad;
  340.         TH:=AV;
  341.      end;
  342. end;
  343. Procedure PrintProjections;
  344. Begin
  345.      For count:=1 to NumberOfPoints do
  346.      begin
  347.           writeln(Lst,' ',c[count,1]:4:0,' ',c[count,2]:4:0,' ');
  348.      end;
  349. end;
  350.  
  351. Begin
  352.      SaveStandardVideoAddr;
  353.      Hires;
  354.      ClrScr;
  355.      CX:=Round(MaxX/2);CY:=Round(MaxY/2);KS:=500;P2:=Pi/2;
  356.      XO:=30;YO:=-100;ZO:=50;
  357.      XV:=10;YV:=40;ZV:=0;
  358.      InputObsPos;
  359.      While Again do
  360.      Begin
  361.            Cls;
  362.            FindProjections;
  363.            DrawFigures;
  364.            Delay(5000);
  365.            InputObsPos;
  366.      End;
  367.      Init80;
  368. End.