home *** CD-ROM | disk | FTP | other *** search
/ 17 Bit Software 1: Collection A / 17Bit_Collection_A.iso / files / 35.dms / 35.adf / 3dsolids1.bas < prev    next >
Encoding:
BASIC Source File  |  1988-05-22  |  9.4 KB  |  208 lines
  1. 1     rem error in line 1045 -- last two rgb #s unknown
  2. 10    rem ** 3D Line Plotting System 
  3. 20    rem ** Original from Analog Magazine Feb.84
  4. 30    rem ** Modified by R. Grokett, Jr. 11/85
  5. 40    rem ** Amiga version 1.1
  6. 100   screen 1,2,0
  7. 110   ? inverse(1) "3-D IMAGE PLOT SYSTEM"
  8. 120   ? :?:?
  9. 130   ?"Original by Tom Hudson  Analog Magazine #16 February 1984"
  10. 140   ?:?
  11. 150   print"Amiga version by R.Grok ------ Dec 85"
  12. 154   ?" This is a modified version of Analog Magazine's SOLID STATES program.
  13. 156   ?"This version has NOT been fully optimized to maximize ABasiC's speed. Even"
  14. 157   ?"so, this version runs considerably faster than even the compiled  Atari"
  15. 158   ?"version. Plus, this version is running with twice the resolution of the
  16. 159   ?"original. Feel free to alter the coding of this program any way you wish!"
  17. 160   DIM r$(1),A$(5),F$(20),DMA$(1),O$(1),EG$(2),IN$(1):EG$=CHR$(27)
  18. 170   XL=0:XR=639:YT=0:yB=199
  19. 180   ? at (15,23);"Press <RETURN> to begin ";
  20. 185   getkey a$:if a$<>chr$(13) then 185
  21. 200   scnclr
  22. 210   ? inverse(1) "  3D-PLOTS  "
  23. 220   ?:?"(D)isk file or (K)eyboard input? (D or K)";
  24. 224   getkey a$:if a$="d" or a$="D" then 1100
  25. 230   if a$="k" or a$="K" then 240 else 224
  26. 240   ?:?"How many points are there";:input PS
  27. 250   DIM X(PS),Y(PS),Z(PS),P(PS,2),VIS(PS)
  28. 260   ? "Enter X,Y,Z coordinates for each point"
  29. 270   FOR I=1 TO PS:? "POINT ";I;:INPUT Q1,Q2,Q3:X(I)=Q1:Y(I)=Q2:Z(I)=Q3:NEXT I
  30. 280   ? :? "How many LINES are there";:INPUT LS:DIM LN(LS,1),z%(3,LS)
  31. 290   ? :? "Now enter POINT information"
  32. 300   ? "for each line."
  33. 310   FOR I=1 TO LS:? :? "Line ";I:? "From POINT";:INPUT Q1:LN(I,0)=Q1:? "  To POINT";:INPUT Q1:LN(I,1)=Q1:NEXT I
  34. 320   ? :? "Do you want to SAVE this object";:INPUT A$:IF A$="y" THEN 1250
  35. 330   IF A$<>"n" THEN 320
  36. 340   REM ***************************
  37. 350   REM *    TIME FOR NEW PLOT    *
  38. 360   REM ***************************
  39. 370   ?:?"Do you wish to (V)iew, (E)dit, or (Q)uit? (V, E, or Q)";
  40. 374   getkey a$:if a$="v" or a$="V" then 380 else if a$="e" or a$="E" then 1340 else if a$="q" or a$="Q" then scnclr:end else 374
  41. 380   ?:?"Enter Observer location (X,Y,Z) : ";
  42. 390   ZOOM=1
  43. 400   INPUT OX,OY,OZ
  44. 410   ? :? "Enter coordinates looked at X,Y,Z"
  45. 420   input VX,VY,VZ
  46. 430   ? :? "Enter ZOOM factor (1= normal)":on error goto 430:INPUT ZOOM:on error goto 0
  47. 434   ? :? "Do you want to do an X-Y loop";:INPUT R$:IF R$<>"y" THEN 440
  48. 436   ?:? "How many degrees TOTAL ROTATION";:INPUT AN2:AN2=(AN2/360)*6.28
  49. 438   ? "How many degrees rotation per frame";:INPUT AN3:AN3=(AN3/360)*6.28
  50. 439   GOTO 2000
  51. 440   X(0)=VX:Y(0)=VY:Z(0)=VZ
  52. 450   D0=1
  53. 460   REM ***************************
  54. 470   REM *  CALCULATE PERSPECTIVE  *
  55. 480   REM ***************************
  56. 490   DX=VX-OX:DY=VY-OY:DZ=VZ-OZ
  57. 500   U1=SQR(DX*DX+DY*DY+DZ*DZ):IF U1=0 THEN U1=1E-06
  58. 510   CX=DX/U1:CY=DY/U1:CZ=DZ/U1
  59. 520   S3=SQR(1-CZ*CZ):S2=SQR(1-CY*CY)
  60. 530   QX=OX+D0*CX:QY=OY+D0*CY:QZ=OZ+D0*CZ
  61. 540   FOR I=0 TO PS:XW=X(I):YW=Y(I):ZW=Z(I):GOSUB 610:NEXT I
  62. 550   FOR I=0 TO PS:IF VIS(I)=0 THEN 570
  63. 560   XW=X(I):YW=Y(I):ZW=Z(I):GOSUB 610:GOSUB 670
  64. 570   NEXT I:GOTO 740
  65. 580   REM ***************************
  66. 590   REM *  IS THE POINT VISIBLE?  *
  67. 600   REM ***************************
  68. 610   VIS(I)=1:VCX=XW-OX:VCY=YW-OY:VCZ=ZW-OZ
  69. 620   IF DX*VCX+DY*VCY+DZ*VCZ>0 THEN RETURN 
  70. 630   VIS(I)=0:RETURN 
  71. 640   REM ***************************
  72. 650   REM *  NOW CALC PLOT COORDS   *
  73. 660   REM ***************************
  74. 670   K=D0/(VCX*CX+VCY*CY+VCZ*CZ)
  75. 680   AX=OX+K*VCX:AY=OY+K*VCY:AZ=OZ+K*VCZ
  76. 690   IF S3=0 THEN 720
  77. 700   P(I,1)=((AX-QX)*CY-(AY-QY)*CX)/S3
  78. 710   P(I,2)=(AZ-QZ)/S3:RETURN 
  79. 720   P(I,1)=((QX-AX)*CZ+(AZ-QZ)*CX)/S2
  80. 730   P(I,2)=(AY-QY)/S2:RETURN 
  81. 740   REM ***************************
  82. 750   REM *     SCALE THE IMAGE     *
  83. 760   REM ***************************
  84. 770   T=450*ZOOM:FOR I=0 TO PS
  85. 780   P(I,1)=P(I,1)*(T*2)
  86. 790   P(I,2)=P(I,2)*T
  87. 800   NEXT I
  88. 810   XAD=320-P(0,1):YAD=100-P(0,2):FOR I=1 TO PS:P(I,1)=P(I,1)+XAD:P(I,2)=P(I,2)+YAD:NEXT I
  89. 820   REM ***************************
  90. 830   REM *   NOW DRAW THE IMAGE!   *
  91. 840   REM ***************************
  92. 850   rgb 0,0,0,0:rgb 2,0,0,0: rgb 3,15,15,15:pena 3
  93. 860   gosub 2200
  94. 870   FOR I=1 TO LS:TV=VIS(LN(I,0))+VIS(LN(I,1)):IF TV=0 THEN 1010
  95. 880   IF TV=2 THEN 980
  96. 890   QT=0:ISAVE=I:IF VIS(LN(I,0))=0 THEN I1=LN(I,0):I2=LN(I,1):I=LN(I,0):GOTO 910
  97. 900   I1=LN(I,1):I2=LN(I,0):I=LN(I,1)
  98. 910   XT1=X(I1):YT1=Y(I1):ZT1=Z(I1):XT2=X(I2):YT2=Y(I2):ZT2=Z(I2):FV=0:FH=0
  99. 920   XW=(XT1+XT2)/2:YW=(YT1+YT2)/2:ZW=(ZT1+ZT2)/2:GOSUB 610
  100. 930   IF VIS(I)>0 THEN XT2=XW:YT2=YW:ZT2=ZW:GOTO 950
  101. 940   XT1=XW:YT1=YW:ZT1=ZW
  102. 950   QT=QT+1:IF QT<15 THEN 920
  103. 960   XW=XT2:YW=YT2:ZW=ZT2:GOSUB 610
  104. 970   GOSUB 670:P(I,1)=P(I,1)*T+XAD:P(I,2)=P(I,2)*T+YAD:VIS(I)=0:I=ISAVE
  105. 980   X1=P(LN(I,0),1):Y1=191-P(LN(I,0),2):X2=P(LN(I,1),1):Y2=191-P(LN(I,1),2):GOSUB 1550
  106. 1010  NEXT I
  107. 1012  scnclr
  108. 1015  for i%=1 to LS:draw(z%(0,i%),z%(1,i%) to z%(2,i%),z%(3,i%)):next i%
  109. 1020  rem
  110. 1035  IF FLAG THEN 2100
  111. 1040  get a$: if a$="" then 1035
  112. 1045  scnclr:rgb 0,6,8,15:rgb 2,1,8,15
  113. 1050  ?"LAST PARAMETERS:"
  114. 1060  ? :? "OBSERVER: ";OX;",";OY;",";OZ:? "VIEWPOINT:";VX;",";VY;",";VZ:? "ZOOM:";ZOOM:GOTO 340
  115. 1070  REM ***************************
  116. 1080  REM *   LOAD 3-D IMAGE FILE   *
  117. 1090  REM ***************************
  118. 1100  gosub 1800:CLOSE #1:?:?:? "Enter Drive: Filename to load. (df_: filename) ";:INPUT F$:on error goto 1200:OPEN "i",#1,F$:on error goto 1180
  119. 1110  INPUT #1,PS:DIM X(PS),Y(PS),Z(PS),P(PS,2),VIS(PS)
  120. 1120  FOR X=1 TO PS:INPUT #1,Q1:X(X)=Q1:NEXT X
  121. 1130  FOR X=1 TO PS:INPUT #1,Q1:Y(X)=Q1:NEXT X
  122. 1140  FOR X=1 TO PS:INPUT #1,Q1:Z(X)=Q1:NEXT X
  123. 1150  INPUT #1,LS:DIM LN(LS,1),z%(3,LS)
  124. 1160  FOR X=1 TO LS:INPUT #1,Q1:LN(X,0)=Q1:INPUT #1,Q1:LN(X,1)=Q1:NEXT X
  125. 1165  a$=" loaded."
  126. 1170  CLOSE #1:on error goto 0
  127. 1175  ?:?"File ";f$;a$:goto 340
  128. 1180  ? :? "}FILE FORMAT ERROR!":GOTO 1210
  129. 1190  ? :? "}I/O ERROR - ";err$(err):GOTO 1210
  130. 1200  ? :? "}CAN'T OPEN FILE!"
  131. 1210  ? "PRESS RETURN":INPUT IN$:clr:goto 100
  132. 1220  REM ***************************
  133. 1230  REM *   SAVE 3-D IMAGE FILE   *
  134. 1240  REM ***************************
  135. 1250  gosub 1800:CLOSE #1:? "Enter Drive: Filename to save. (df_: filename)";:INPUT F$:on error goto 1210:OPEN "o",#1,F$:on error goto 1190
  136. 1260  ? #1,PS
  137. 1270  FOR X=1 TO PS:? #1,X(X):NEXT X
  138. 1280  FOR X=1 TO PS:? #1,Y(X):NEXT X
  139. 1290  FOR X=1 TO PS:? #1,Z(X):NEXT X
  140. 1300  ? #1,LS:FOR X=1 TO LS:? #1,LN(X,0):? #1,LN(X,1):NEXT X:a$=" saved.":GOTO 1170
  141. 1310  REM ***************************
  142. 1320  REM * EDIT THE 3-D IMAGE DATA *
  143. 1330  REM ***************************
  144. 1340  on error goto 0:? :? "(P)rint, (E)dit or (R)eturn";:INPUT A$:IF A$="E" or A$="e" THEN 1410
  145. 1350  IF A$="R" or A$="r" THEN 340
  146. 1360  if a$="p" or a$="P" then 1370 else 1340
  147. 1370  on error goto 1340:PRINT "POINTS:";PS:PRINT 
  148. 1380  FOR X=1 TO PS:PRINT "POINT ";X;": ";X(X),Y(X),Z(X):NEXT X:PRINT 
  149. 1390  PRINT "LINES:";LS:PRINT 
  150. 1400  FOR X=1 TO LS:PRINT "LINE ";X;": ";LN(X,0);" TO ";LN(X,1):NEXT X:PRINT :GOTO 1340
  151. 1410  on error goto 0:? :? "Edit (P)oint or (L)ine or (E)xit";:INPUT A$:IF A$="l" THEN 1480
  152. 1420  IF A$="e" THEN 320
  153. 1430  IF A$<>"p" THEN 1410
  154. 1440  ? :? "Enter POINT# or <RETURN>";:on error goto 1410:INPUT PT:IF PT>PS OR PT<0 THEN 1440
  155. 1450  ? :? "X=";X(PT),"Y=";Y(PT),"Z=";Z(PT)
  156. 1460  ? :? "Enter NEW X,Y,Z or <RETURN>":on error goto 1410
  157. 1470  INPUT Q1,Q2,Q3:X(PT)=Q1:Y(PT)=Q2:Z(PT)=Q3:GOTO 1410
  158. 1480  ? :? "Enter LINE# or <RETURN>";:on error goto 1410:INPUT LN:IF LN>LS OR LN<0 THEN 1480
  159. 1490  ? :? "FROM point:";LN(LN,0):? "  TO point:";LN(LN,1)
  160. 1500  ? :? "Enter new LINE POINTS or <RETURN>":on error goto 1410
  161. 1510  ? "FROM point:";:INPUT Q1:IF Q1>PS THEN 1510
  162. 1520  LN(LN,0)=Q1
  163. 1530  ? "  TO point:";:INPUT Q1:IF Q1>PS THEN 1530
  164. 1540  LN(LN,1)=Q1:GOTO 1410
  165. 1550  REM ***************************
  166. 1560  REM *  GRAPHICS
  167. 1570  REM ***************************
  168. 1580  L1=0:L2=0:R1=0:R2=0:T1=0:T2=0:B1=0:B2=0:POK=0
  169. 1590  IF X1<XL THEN L1=1:GOTO 1610
  170. 1600  IF X1>XR THEN R1=1
  171. 1610  IF Y1>YB THEN B1=1:GOTO 1630
  172. 1620  IF Y1<YT THEN T1=1
  173. 1630  IF X2<XL THEN L2=1:GOTO 1650
  174. 1640  IF X2>XR THEN R2=1
  175. 1650  IF Y2>YB THEN B2=1:GOTO 1670
  176. 1660  IF Y2<YT THEN T2=1
  177. 1670  IF L1+L2=2 OR R1+R2=2 OR T1+T2=2 OR B1+B2=2 THEN RETURN 
  178. 1680  X3=X1:Y3=Y1:X4=X2:Y4=Y2:GOSUB 1730
  179. 1690  L1=L2:R1=R2:T1=T2:B1=B2
  180. 1700  X1=XW:Y1=YW:X3=X2:Y3=Y2:X4=X1:Y4=Y1:GOSUB 1730
  181. 1710  IF X1<XL OR X1>XR OR Y1<YT OR Y1>YB OR XW<XL OR XW>XR OR YW<YT OR YW>YB THEN RETURN 
  182. 1715  z%(0,i)=x1:z%(1,i)=y1:z%(2,i)=xw:z%(3,i)=yw:pok=1:return
  183. 1720  draw( X1,Y1 to XW,YW):POK=1:RETURN 
  184. 1730  IF L1+T1+B1+R1=0 THEN XW=X3:YW=Y3:RETURN 
  185. 1740  IF L1 THEN XW=XL:YW=Y3+(Y4-Y3)*(XL-X3)/(X4-X3):X3=XW:Y3=YW:IF Y3>=YT AND Y3<=YB THEN RETURN 
  186. 1750  IF R1 THEN XW=XR:YW=Y3+(Y4-Y3)*(XR-X3)/(X4-X3):X3=XW:Y3=YW:IF Y3>=YT AND Y3<=YB THEN RETURN 
  187. 1760  IF B1 THEN YW=YB:XW=X3+(X4-X3)*(YB-Y3)/(Y4-Y3):X3=XW:Y3=YW:IF X3>=XR AND X3<=XL THEN RETURN 
  188. 1770  IF T1 THEN YW=YT:XW=X3+(X4-X3)*(YT-Y3)/(Y4-Y3):X3=XW:Y3=YW
  189. 1780  RETURN 
  190. 1800  rem ---- Disk Directory
  191. 1810  rem
  192. 1820  ?:?"For Disk Directory, input (df0:), (df1:) or (N)one";
  193. 1830  input drive$:if left$(drive$,2)<>"df" then return
  194. 1840  scnclr
  195. 1845  on error goto 1190
  196. 1847  chdir drive$
  197. 1850  dir drive$
  198. 1855  on error goto 0
  199. 1860  return
  200. 2000  FLAG=1:R=(OX^2+OY^2)^0.5:AN1=ATN(OY/OX):AN2=AN2+AN1
  201. 2100  AN1=AN1+AN3:OX=R*COS(AN1):OY=R*SIN(AN1)
  202. 2120  GOTO 440
  203. 2200  if flag=0 then return
  204. 2201  IF AN1>AN2 THEN FLAG=0:goto 1045
  205. 2202  XI=XI+1-2*(XI=2):XA=2-(XI=2)
  206. 2250  RETURN 
  207. 2500  on error goto 0:scnclr    :RETURN 
  208.