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 >
Wrap
Pascal/Delphi Source File
|
1979-12-31
|
9KB
|
368 lines
Program Display_3D_Graphics;
{This program originally published in 80 Microcomputing
( now called Micro 80) ,March 1982 page 138
Written by E. Foglin, 42K Southwood Apts.,Amherst,
MA. 01002. Copyrighted March 1981.
Translated by R.K.Hallworth, 8 Rodney St., Bayswater, VIC. 3153.
from BASIC to PASCAL
the Connect procedure to ensure that only
the sections of lines found on screen are plotted was
written by R.K.H.
Operation
Three objects a square based pyramid and two boxes can be
observed from any position. First give the observers
position X Y Z (seperate the X Y Z components with spaces
e.g 30 -100 50) then give the point you are looking at
(e.g. 10 40 0). The program will then draw a perspective
view of the objects}
{$I HIRES4.I}
{$I DRAW.i}
{ *** adaptions to use Premium Graphics Package *** }
Procedure PutCurs(x,y:integer);
begin
GotoXY(X+1,Y+1)
end;
Procedure Plot(X0,y0,x1,y1:integer);
begin
Draw(x0,y0,x1,y1,1)
end;
Procedure Init80;
begin
SetVideo(80)
end;
Procedure Cls;
begin
ClrScr
end;
{*** end of adaptions ***}
Type
Pnt = array[1..21,1..3] of integer;
Conects = array[1..54] of integer;
Prj = array[1..21,1..2] of real;
Const
Points:Pnt =( ( 10,40,0), {Point 1 (X,Y,Z) }
( 30,40,0), {Point 2 }
(20,49,0), {Point 3 etc. ....}
(20,31,0),
(20,40,40),
(20,10,0),
(20,30,0),
(40,10,0),
(40,30,0),
(20,10,20),
(20,30,20),
(40,10,20),
(40,30,20),
(0,0,0),
(0,10,0),
(10,0,0),
(10,10,0),
(0,0,30),
(0,10,30),
(10,0,30),
(10,10,30));
Conections:conects =
(1,2,3,4, {Point 1 connects to 2 points point3 & point4}
2,2,3,4, {Point 2 connects to 2 points point3 & point4}
5,4,1,3,2,4,
6,3,7,8,10,
9,3,7,8,13,
12,3,8,10,13,
11,3,7,13,10,
14,3,15,16,18,
17,3,15,16,21,
20,3,16,18,21,
19,3,15,21,18);
ConSize=54; {number of elements in the conections array}
NumberOfPoints=21;
MaxY=255;MaxX=511;
Var
Response :Char;
CX,CY :integer;
Count :Integer;
I1,I2,I3,I4,
XO,YO,ZO,
XV,YV,ZV :Integer;
XP,YP,ZP,
SX,SY,Z :Real;
AV,AX,AY,TA,TH,T1,AR,T2,TX,KS,DS,
P2 :Real;
Again,OnScreen :Boolean;
C :Prj;
Procedure FindQuad;
Begin
if ax<>0 then
Begin
av:=ArcTan(ay/ax);
if ax>0 then
Begin
if ay<0 then av:=av+2*Pi;
end
else
av:=av+Pi;
end
else
if ay>0 then av:=Pi/2
else av:=3*Pi/2;
end;
Procedure FindOnScreen(Var Xa,Ya,X2,Y2:Integer);
Var
Xn,Yn,Xe,Ye:Real;
Slope :Real;
Procedure FindEdgePoint;
begin
If Xa<>X2 then
Begin
Yn:=Slope*(Xe-Xa)+Ya;
Xn:=Xe;
if (Yn>MaxY) or (Yn<0) then
if Slope<>0 then
Begin
Xn:=(Ye-Ya)/Slope+Xa;
Yn:=Ye;
End
Else
OnScreen:=FALSE;
if (Xn>MaxX) or (Xn<0) then OnScreen:=FALSE;
End
Else
Begin
Yn:=Ye;
Xn:=Xa;
if (Xn>MaxX) or (Xn<0) then OnScreen:=FALSE;
End;
End;
Procedure FindBoundary(X,Y:integer);
Begin
If X>MaxX then
Begin
Xe:=MaxX;
If Slope>0 then Ye:= MaxY else Ye:= 0;
end;
If X<0 then
Begin
Xe:=0;
If Slope>0 then Ye:=0 else Ye:=MaxY;
end;
If Y>MaxY then
Begin
Ye:=MaxY;
if Slope>0 then Xe:=MaxX else Xe:=0
End;
If Y<0 then
Begin
Ye:=0;
If Slope>0 then Xe:=0 else Xe:=MaxX;
End;
End;
begin
OnScreen:=TRUE;
if Xa<>X2 then Slope:=(Ya-Y2)/(Xa-X2) else Slope:=990;
if not(Ya in [0..255]) or (Xa<0) or (Xa>511) then
Begin
FindBoundary(Xa,Ya);
FindEdgePoint;
Xa:=Round(Xn);Ya:=Round(Yn);
end;
if not( Y2 in [0..255] ) or (X2<0) or (x2>511) then
Begin
FindBoundary(X2,Y2);
FindEdgePoint;
X2:=Round(Xn);Y2:=Round(Yn);
end;
end;
Procedure ConnectPoints;
begin
FindOnScreen(I1,I2,I3,I4);
if OnScreen then
begin
plot(I1,I2,I3,I4);
putCurs(30,15);
end;
end;
Procedure DrawFigures;
Var
ConPos:Integer;
NumOfCons:Integer;
begin
ConPos:=1;
While ConPos<ConSize do
Begin
I1:=Round(C[Conections[ConPos],1]);
I2:=Round(C[Conections[ConPos],2]);
NumOfCons:=Conections[ConPos+1];
for Count:=1 to NumOfCons do
Begin
I3:=Round(C[Conections[ConPos+1+Count],1]);
I4:=Round(C[Conections[ConPos+1+count],2]);
ConnectPoints;
end;
ConPos:=ConPos+NumOfCons+2;
end;
end;
Function Sgn(x:Real):Integer;
Begin
if x>0 then Sgn:=1;
if x=0 then Sgn:=0;
if x<0 then Sgn:=-1;
end;
Procedure FindProjections;
Function SqrR(X:Integer):Real;
Begin
SqrR:= Sqr(X*1.0);
end;
Begin
for Count:=1 to NumberOfPoints do
Begin
XP:=Points[Count,1]-XO;
YP:=Points[Count,2]-YO;
Z:=ZO-Points[Count,3];
AY:=YP;AX:=XP;
FindQuad;
PutCurs(0,0);
T1:=TA-AV;AR:=Cos(T1)*Sqrt( Sqr(XP) + Sqr(YP) );
AX:=Z;
if Z>0 then
Begin
AY:=Abs(AR);
FindQuad;
TX:=AV*Sgn(AR);
End
else
Begin
AY:=AR;
FindQuad;
TX:=AV;
end;
T2:=TH-TX;
if Abs(T2)>=P2 then
sx:=936
else
Begin
SY:=Round(KS*Sin(T2)/Cos(T2));
DS:=Sin(TX)*Sqrt(Sqr(SY)+Sqr(KS));
if DS<>0 then
SX:=Round(DS*Sin(T1)/Cos(T1))
else
Begin
SX:=Round(KS/Cos(TH)*Sqrt(Sqr(XP)+Sqr(YP))/Z*Sgn(T1));
if Abs(T1)>P2 then SX:=-SX;
end;
end;
C[Count,1]:=SX+CX;C[Count,2]:=CY-SY*0.67;
end;
end;
Procedure InputObsPos;
Procedure ReadVal(Var X:integer);
Var ValSt:string[4];
Code,Temp:integer;
begin
ValSt:='';
Buflen:=4;
Read(ValSt);
Val(ValSt,Temp,Code);
If (Code=0) and (Length(ValSt)<>0)
then x:=temp
else
begin
For temp:=1 to length(ValSt) do write(#127 {del});
Write(x)
end
end;
Begin
PutCurs(0,0);
Write('Draw Y/N');
Repeat
Read(Kbd,Response);
until Response in ['Y','y','N','n'];
if Response in ['Y','y'] then again:=TRUE else again:=FALSE;
if again then
Begin
PutCurs(0,0);
Write('Observers Co-ordinates ',XO,' ',YO,' ',ZO);
PutCurs(4,1);
Write('X=');
ReadVal(XO);
PutCurs(11,1);
write('Y=');
ReadVal(YO);
PutCurs(18,1);
Write('Z=');
ReadVal(ZO);
PutCurs(0,2);
Write('Viewing Co-Ordinates ',XV,' ',YV,' ',ZV);
PutCurs(4,3);
Write('X=');
ReadVal(XV);
PutCurs(11,3);
write('Y=');
ReadVal(YV);
PutCurs(18,3);
Write('Z=');
ReadVal(ZV);
AX:=XV-XO;AY:=YV-YO;
FindQuad;
TA:=AV;
AY:=Sqrt(Sqr(AX)+Sqr(AY));
AX:=ZO-ZV;
FindQuad;
TH:=AV;
end;
end;
Procedure PrintProjections;
Begin
For count:=1 to NumberOfPoints do
begin
writeln(Lst,' ',c[count,1]:4:0,' ',c[count,2]:4:0,' ');
end;
end;
Begin
SaveStandardVideoAddr;
Hires;
ClrScr;
CX:=Round(MaxX/2);CY:=Round(MaxY/2);KS:=500;P2:=Pi/2;
XO:=30;YO:=-100;ZO:=50;
XV:=10;YV:=40;ZV:=0;
InputObsPos;
While Again do
Begin
Cls;
FindProjections;
DrawFigures;
Delay(5000);
InputObsPos;
End;
Init80;
End.