home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB18.ZIP / GLOBE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-10-01  |  6.9 KB  |  213 lines
  1. program Globe(input,output);
  2.  
  3. { ---- Globe program by Karl Koessel ----
  4.  
  5.       Published in PC WORLD Vol.1, No. 1
  6.    Original BASIC program by Karl Koessel
  7.  Program Translated to Turbo by Lars Ecklund
  8.  
  9.   ---- Turbo version written 9/15/85 ---- }
  10.  
  11. type
  12. ArrayOne                                                   = array[1..11] of integer;
  13.  
  14. var
  15. BCK,PAL                                                    : byte;
  16. L,LX,LY,LZ,R,RC0,X,XC,Y,YC,Z                               : integer;
  17. A,A1,A3,ASP,B,B2,B3,C,C1,C2,CF,CX,CY,CZ,DR,I,J,SX,SY,SZ    : real;
  18. XObs,XRot,YObs,YRot,ZObs,ZRot,ZS                           : real;
  19. SStr                                                       : char;
  20. BStr                                                       : string[2];
  21. CStr                                                       : string[3];
  22. RC                                                         : ArrayOne;
  23. Q                                                          : boolean;
  24.  
  25. procedure SampleRun; forward;
  26. procedure ProcessInput; forward;
  27.  
  28. procedure SetupAndInitializeVariables;
  29. label ExitSAIV;
  30. begin
  31.     TextMode;
  32.     ClrScr;
  33.     GotoXY(23,1);
  34.     WriteLn('Perspective image of Rotated Globe');
  35.     for X:=1 to 11 do             { Prepare an array holding the colors }
  36.     begin                         { of parallels, pattern reverses after }
  37.          RC[X]:=(X-1) mod 3+1;    { equator which is brown or white.     }
  38.          if (X>6) then
  39.               RC[X]:=(5-RC[X]) mod 3+1;
  40.     end;
  41.     CF:=Pi/180;
  42.     WriteLn;
  43.     Write('Want to see a sample run? (Y/N): ');
  44.     ReadLn(SStr);
  45.     SStr:=UpCase(Copy(SStr,1,1));
  46.     if (SStr='Y') then
  47.     begin
  48.          SampleRun;
  49.          goto ExitSAIV;
  50.     end;
  51.     GotoXY(1,5);
  52.     WriteLn('Enter screen location of center of globe');
  53.     Write  ('(e.g. 160  100)                     ?  ');
  54.     Read   (XC,YC);
  55.     WriteLn;
  56.     WriteLn('Enter relative coordinates of observer:');
  57.     WriteLn('points left(-)/right(+) of X, below(-)/above(+) Y,');
  58.     WriteLn('and distance from the screen');
  59.     Write  ('(e.g. -9  0  456)                   ?  ');
  60.     Read   (XObs,YObs,ZObs);
  61.     WriteLn;
  62.     WriteLn('Enter parallel, meridian, & image''s tilt');
  63.     Write  ('(e.g. 37  -123  23)                  ?  ');
  64.     Read   (XRot,YRot,ZRot);
  65.     WriteLn;
  66.     WriteLn('Enter sphere''s radius');
  67.     Write  ('(e.g. 100)                          ?  ');
  68.     Read   (R);
  69.     WriteLn;
  70.     WriteLn('Enter background colour and palette');
  71.     Write  ('(e.g. 1  1)                         ?  ');
  72.     Read   (BCK,PAL);
  73.     WriteLn;
  74.     WriteLn('Enter this screen''s aspect ratio');
  75.     Write  ('(e.g. 1.21875)                      ?  ');
  76.     Read   (ASP);
  77.     ProcessInput;
  78.     repeat until (KeyPressed=True );
  79. ExitSAIV:
  80. end;
  81.  
  82. procedure SampleRun;
  83. begin
  84.     XC:=160; YC:=100;                      { Data for sample run }
  85.     XObs:=-9.0; YObs:=   0.0; ZObs:=456.0;
  86.     XRot:=37.0; YRot:=-123.0; ZRot:= 23.0;
  87.     R:=100;
  88.     BCK:=1; PAL:=1;
  89.     ASP:=1.21875;
  90.     GotoXY(1,5);                           { Screen for sample run }
  91.     WriteLn('Enter screen location of center of globe');
  92.     WriteLn('(e.g. 160,100)                      ?  ',XC,',',YC);
  93.     WriteLn;
  94.     WriteLn('Enter relative coordinates of observer:');
  95.     WriteLn('points left(-)/right(+) of X, below(-)/above(+) Y,');
  96.     WriteLn('and distance from the screen');
  97.     WriteLn('(e.g. -9,0,456)                     ?  ',XObs:0,',',YObs:0,',',ZObs:0);
  98.     WriteLn;
  99.     WriteLn('Enter parallel, meridian, & image''s tilt');
  100.     WriteLn('(e.g. 37,-123,23)                   ?  ',XRot:0,',',YRot:0,',',ZRot:0);
  101.     WriteLn;
  102.     WriteLn('Enter sphere''s radius');
  103.     WriteLn('(e.g. 100)                          ?  ',R);
  104.     WriteLn;
  105.     WriteLn('Enter background colour and palette');
  106.     WriteLn('(e.g. 1,1)                          ?  ',BCK,',',PAL);
  107.     WriteLn;
  108.     WriteLn('Enter this screen''s aspect ratio');
  109.     WriteLn('(e.g. 1.21875)                      ?  ',ASP:6);
  110.     GotoXY(1,25);
  111.     Write('HIT ANY KEY TO CONTINUE...');
  112.     ProcessInput;
  113.     repeat until (KeyPressed=True );
  114. end;
  115.  
  116. procedure ProcessInput;
  117. begin
  118.     CX:=Cos(CF*XRot+ArcTan(YObs/ZObs));
  119.     SX:=Sin(CF*XRot+ArcTan(YObs/ZObs));
  120.     CY:=Cos(CF*YRot+ArcTan(XObs/ZObs));
  121.     SY:=Sin(CF*YRot+ArcTan(XObs/ZObs));
  122.     CZ:=Cos(CF*ZRot);
  123.     SZ:=Sin(CF*ZRot);
  124.     ZObs:=Sqrt(Sqr(XObs)+Sqr(YObs)+Sqr(ZObs)); { Observer's distance from globe's center }
  125.     ZS:=Sqr(R)/ZObs;    { Can't see if point's Z coordinate < ZS }
  126. end;
  127.  
  128. procedure PlotPoint; forward;
  129. procedure WriteVisiblePoint; forward;
  130.  
  131. procedure DrawGlobe;
  132. begin
  133.     ClrScr; GraphColorMode; TextColor(BCK); TextBackGround(PAL);
  134.     I:=0;
  135.     while (I<=3) do
  136.     begin
  137.          RC0:=Round((I*12/Pi+2)) mod 3+1;
  138.          Str(RC0,CStr);
  139.          J:=0;
  140.          while (J<=2.0001*Pi) do
  141.          begin
  142.               A:=R*Sin(I)*Sin(J);
  143.               B:=R*Cos(J);
  144.               C:=R*Cos(I)*Sin(J);
  145.               PlotPoint;
  146.               WriteVisiblePoint;
  147.               J:=J+(Pi/24);
  148.          end;
  149.          I:=I+(Pi/12);
  150.     end;
  151.     I:=Pi/12;
  152.     while (I<=11*Pi/12) do
  153.     begin
  154.          RC0:=RC[Round(I*12/Pi)];
  155.          Str(RC0,CStr);
  156.          J:=0;
  157.          while (J<=2.0001*Pi) do
  158.          begin
  159.               A:=R*Sin(I)*Sin(J);
  160.               B:=R*Cos(I);
  161.               C:=R*Sin(i)*Cos(J);
  162.               PlotPoint;
  163.               WriteVisiblePoint;
  164.               J:=J+(Pi/24);
  165.          end;
  166.          I:=I+(Pi/12);
  167.     end;
  168. end;
  169.  
  170. procedure PlotPoint;
  171. begin
  172.     A1:=A*CY-C*SY;          { Turn requested meridian to observer at 0,0,0 }
  173.     C1:=A*SY+C*CY;          { (B1=B, so B is used for B1)}
  174.     B2:=B*CX-C1*SX;         { Turn requested parallel to observer at 0,0,0 }
  175.     C2:=B*SX+C1*CX;         { (A2=A1, so A1 is used for A2)}
  176.     A3:=A1*CZ-B2*SZ;        { Turn image on axis perpendicular to screen }
  177.     B3:=A1*SZ+B2*CZ;        { (C3=C2, so C2 is used for C3)}
  178.     DR:=C2/(ZObs-C2)+1;     { Distance ratio for computing perpective }
  179.     X:=Round(A3*DR*ASP+XC); { Screen's x (with perspective & aspect ratios)}
  180.     Y:=Round(B3*-DR+YC);    { Screen's y (with perspective, direction ratio }
  181. end;                        { (Z=C3=C2, so C2 is used for Z) }
  182.  
  183. procedure WriteVisiblePoint;
  184. label 840;
  185. begin
  186.     if (C2<ZS) or (LZ<ZS) then
  187.     begin
  188.          goto 840;
  189.     end;
  190.     Q:=(X<0) or (X>319) or (Y<0) or (Y>199) or (LX<0) or (LX>319) or (LY<0) or (LY>199);
  191.     if (Q or (J=0)) then    { Off screen? }
  192.          Plot(X,Y,RC0)
  193.     else
  194.          Draw(LX,LY,X,Y,RC0);
  195. 840:
  196.     LX:=X; LY:=Y; LZ:=Round(C2);  { LX, LY, LZ are X, Y, Z of last referenced point }
  197. end;
  198.  
  199. procedure RubberStamp;
  200. begin
  201.     GotoXY(1,1); WriteLn('PC WORLD');
  202.     Draw(32,1,38,1,0); Draw(32,2,38,2,3);
  203.     Draw(32,3,38,3,0); Draw(32,4,38,4,3);
  204.     Draw(32,5,38,5,0);
  205.     repeat until (KeyPressed=True );
  206. end;
  207.  
  208. BEGIN
  209.     SetupAndInitializeVariables;
  210.     DrawGlobe;
  211.     RubberStamp;
  212. END.
  213.