home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 058.lha / 3DPlot (.txt) < prev    next >
Encoding:
AmigaBASIC Source Code  |  1986-11-20  |  10.8 KB  |  403 lines
  1. CLS:COMMON flag,f$
  2. IF flag=1 THEN GOTO default
  3. start:
  4.   MENU 1,0,0,"Project"
  5.   MENU 1,1,1,"New Equation"
  6.   MENU 1,2,0,"New Window"
  7.   MENU 1,3,0,"See Graph"
  8.   MENU 1,4,1,"Quit"
  9.   MENU 2,0,0,"Surface Appearance"
  10.   MENU 2,1,1,"Topside Color"
  11.   MENU 2,2,1,"Bottomside Color"
  12.   MENU 2,3,2,"  Opaque"
  13.   MENU 2,4,1,"  Transparent"
  14.   MENU 3,0,0,"Grid"
  15.   MENU 3,1,1,"Color"
  16.   MENU 3,2,2,"  x & y Lines"
  17.   MENU 3,3,1,"  x Lines"
  18.   MENU 3,4,1,"  y Lines"
  19.   MENU 4,0,0,"Draw"
  20.   MENU 4,1,1,"Start"
  21.   MENU 4,2,0,"Stop"
  22.   MENU 4,3,0,"Rescale"
  23. PALETTE 3,0.33,0.87,0
  24. LOCATE 1,34:COLOR 2,3:PRINT " 3D GRAPHING "
  25. prompt:
  26.   COLOR 1,0:PRINT:f$=""
  27.   PRINT "Enter function of x and y to be graphed:"
  28.   PRINT
  29.   INPUT "z=",f$
  30.   eflag=0:ON ERROR GOTO 0
  31.   IF f$="" THEN
  32.     CLS:MENU RESET
  33.     PALETTE 3,1,0.73,0
  34.     CLEAR:END
  35.   END IF
  36. OPEN "df1:equation" FOR OUTPUT AS 1
  37. PRINT #1,"100 z="+f$+":RETURN"
  38. CLOSE 1:flag=1
  39. CHAIN MERGE "df1:equation"
  40. default:
  41.   m1=-2.5:m2=2.5:m3=-2.5:m4=2.5:col=60:azi=45:n=2
  42.   DIM r(3),g(3),b(3)
  43.   r(0)=0.4:g(0)=0.6:b(0)=1
  44.   r(1)=1:g(1)=1:b(1)=1
  45.   r(2)=0:g(2)=0:b(2)=0
  46.   r(3)=0.33:g(3)=0.87:b(3)=0
  47.   ON ERROR GOTO mischeck
  48.   x=m2:y=m4:GOSUB 100:IF eflag THEN DELETE 100:BEEP:GOTO prompt
  49. setup: 
  50.   WINDOW 1,"3d Graphing"
  51. setup1:
  52.   COLOR 1,0:CLS
  53.   LOCATE 1,34:COLOR 2,3:PRINT" 3D GRAPHING "
  54.   ln=LEN("z="+f$):tb=INT(40-ln/2):IF tb<0 THEN tb=0
  55.   LOCATE 3,tb:COLOR 1,0:PRINT "z="+f$
  56. options:
  57.   COLOR 3,2
  58.   MENU 1,0,1:MENU 2,0,1:MENU 3,0,1
  59.   MENU 4,0,1:MENU 4,1,1:MENU 4,2,0  
  60.   IF sflag THEN MENU 1,3,1:MENU 4,3,1
  61.   IF wflag THEN MENU 1,2,1
  62.   LOCATE 6,10
  63.   PRINT " Minimum x-coordinate ":LOCATE 6,50:PRINT " Maximum x-coordinate "
  64.   LOCATE 11,10
  65.   PRINT " Minimum y-coordinate ":LOCATE 11,50:PRINT " Maximum y-coordinate "
  66.   LOCATE 16,10
  67.   PRINT " Colatitude ":LOCATE 16,50:PRINT " Azimuth "
  68.   COLOR 2,1:LOCATE 7,10
  69.   PRINT " ";m1;" ":LOCATE 7,50:PRINT " ";m2;" "
  70.   LOCATE 12,10
  71.   PRINT " ";m3;" ":LOCATE 12,50:PRINT " ";m4;" "
  72.   LOCATE 17,10
  73.   PRINT " ";col;" ":LOCATE 17,50:PRINT " ";azi;" "
  74.   PRINT:COLOR 1,0
  75.   PRINT
  76.   PRINT "                   Select 'start' on draw menu to draw graph."
  77. selection:
  78.   m=MENU(0):mo=MOUSE(0):m=0:mo=0
  79. loop:  
  80.   m=MENU(0):IF m THEN checkmenu
  81.   mo=MOUSE(0):IF mo THEN adjust :ELSE loop
  82. checkmenu:
  83.   ON m GOTO menu1,menu2,menu3,menu4
  84.   menu1:ON MENU(1) GOTO newstart,newwindow,seegraph,quit
  85.   menu2:ON MENU(1) GOTO top,bottom,opaq,trans
  86.   menu3:ON MENU(1) GOTO gridcol,xygrid,xgrid,ygrid
  87.   menu4:ON MENU(1) GOTO draw,endraw,rescale
  88. adjust:
  89.   x%=MOUSE(1)/8:y%=MOUSE(2)/8
  90.   IF y%<6 OR y%>17 THEN selection
  91.   IF (x%<10 OR x%>70) OR (x%>30 AND x%<49) THEN selection
  92.   IF x%>=49 THEN rightside
  93.   IF y%=6 OR y%=7 THEN xmin
  94.   IF y%=11 OR y%=12 THEN ymin
  95.   IF y%=16 OR y%=17 THEN colatitude
  96.   GOTO selection
  97. rightside:
  98.   IF y%=6 OR y%=7 THEN xmax
  99.   IF y%=11 OR y%=12 THEN ymax
  100.   IF y%=16 OR y%=17 THEN azimuth
  101.   GOTO selection
  102. xmin:
  103.   GOSUB ghostmenu
  104.   COLOR 2,1:LOCATE 7,10
  105.   LINE INPUT " ";m1$:IF m1$="" THEN options
  106.   IF m1$="0" THEN m1=0:GOTO options
  107.   IF VAL(m1$)=0 THEN BEEP:GOTO xmin
  108.   m1=VAL(m1$):GOSUB xstatus:GOTO options
  109. xmax:
  110.   GOSUB ghostmenu
  111.   COLOR 2,1:LOCATE 7,50
  112.   LINE INPUT " ";m2$:IF m2$="" THEN options
  113.   IF m2$="0" THEN m2=0:GOTO options
  114.   IF VAL(m2$)=0 THEN BEEP:GOTO xmax
  115.   m2=VAL(m2$):GOSUB xstatus:GOTO options
  116. ymin:
  117.   GOSUB ghostmenu
  118.   COLOR 2,1:LOCATE 12,10
  119.   LINE INPUT " ";m3$:IF m3$="" THEN options
  120.   IF m3$="0" THEN m3=0:GOTO options
  121.   IF VAL(m3$)=0 THEN BEEP:GOTO ymin
  122.   m3=VAL(m3$):GOSUB xstatus:GOTO options
  123. ymax:
  124.   GOSUB ghostmenu
  125.   COLOR 2,1:LOCATE 12,50
  126.   LINE INPUT " ";m4$:IF m4$="" THEN options
  127.   IF m4$="0" THEN m4=0:GOTO options
  128.   IF VAL(m4$)=0 THEN BEEP:GOTO ymax
  129.   m4=VAL(m4$):GOSUB xstatus:GOTO options
  130. colatitude:
  131.   CLS:PRINT:GOSUB ghostmenu
  132.   PRINT " Colatitude is the angle between the line of sight and the z-axis."
  133.   PRINT " Specify a value between 0 and 180 degrees."
  134.   PRINT
  135.   INPUT ">",col:IF col<0 OR col>180 THEN BEEP:GOTO colatitude
  136.   GOTO setup1
  137. azimuth:
  138.   CLS:PRINT:GOSUB ghostmenu
  139.   PRINT " Azimuth is the angle between the xz-plane and the plane containing"
  140.   PRINT " the line of sight and the z-axis."
  141.   PRINT
  142.   PRINT " Specify a value between -180 and 180 degrees."
  143.   PRINT
  144.   INPUT ">",azi:IF azi<-180 OR azi>180 THEN BEEP:GOTO azimuth
  145.   GOTO setup1
  146. newstart:
  147.   inq$="New Equation":GOSUB confirm
  148.   IF an$<>"Y" THEN selection
  149.   CLS:FOR i=2 TO n:WINDOW CLOSE i:NEXT
  150.   DELETE 100
  151.   CLEAR:GOTO start  
  152. newwindow:
  153.   GOSUB ghostmenu
  154.   hmem=FRE(-1):IF hmem>160000 THEN ask
  155.   CLS:BEEP:PRINT"Not enough free memory."
  156.   question:
  157.     PRINT:INPUT"Do you wish to erase a current window (y/n)";an$
  158.     IF UCASE$(an$)<>"Y" THEN setup
  159.     PRINT:PRINT"Erase which one ( 1 -";n-1;")";:INPUT number
  160.     IF number<1 OR number>n-1 THEN BEEP:GOTO question
  161.     nflag=number+1:GOTO setup1
  162.   ask:
  163.     inq$="New Window":GOSUB confirm
  164.     IF an$<>"Y" THEN selection
  165.   create:
  166.     n=n+1:WINDOW n,STR$(n-1)+")z="+f$,(1,10)-(617,162),23
  167.     CLS:PRINT"Adjust window then press <RETURN>."
  168.   adjwin:
  169.     a$=INKEY$:IF a$<>CHR$(13) THEN adjwin
  170.   WINDOW n,,,22
  171.   GOTO setup
  172. seegraph:
  173.   GOSUB ghostmenu
  174.   FOR i=2 TO n:WINDOW i:NEXT
  175.   GOTO pause
  176. quit:
  177.   inq$="Quit":GOSUB confirm
  178.   IF an$<>"Y" THEN selection
  179.   COLOR 1,0:CLS:MENU RESET:ON ERROR GOTO 0
  180.   FOR i=2 TO n:WINDOW CLOSE i:NEXT
  181.   PALETTE 1,1,1,1
  182.   PALETTE 2,0,0,0
  183.   PALETTE 3,1,0.73,0
  184.   DELETE 100:CLEAR:END  
  185. top:
  186.   CLS:LOCATE 1,29:COLOR 0,1:PRINT" Top Color Adjustment "
  187.   COLOR 1,0:id=3
  188.   GOTO figcolor
  189. bottom:
  190.   CLS:LOCATE 1,28:COLOR 0,1:PRINT" Bottom Color Adjustment "
  191.   COLOR 1,0:id=1
  192.   GOTO figcolor
  193. opaq:
  194.   opq$="y":MENU 2,3,2:MENU 2,4,1:MENU 2,1,1:MENU 2,2,1:GOTO selection
  195. trans:
  196.   opq$="n":MENU 2,3,1:MENU 2,4,2:MENU 2,1,0:MENU 2,2,0:GOTO selection
  197. gridcol:
  198.   CLS:LOCATE 1,29:COLOR 0,1:PRINT " Grid Color Adjustment "
  199.   COLOR 1,0:id=2
  200.   GOTO figcolor
  201. xygrid:
  202.   gtype=0
  203.   MENU 3,2,2:MENU 3,3,1:MENU 3,4,1
  204.   GOTO selection
  205. xgrid:
  206.   gtype=1
  207.   MENU 3,2,1:MENU 3,3,2:MENU 3,4,1
  208.   GOTO selection
  209. ygrid:
  210.   gtype=2
  211.   MENU 3,2,1:MENU 3,3,1:MENU 3,4,2
  212.   GOTO selection
  213. rescale:
  214.   GOSUB ghostmenu
  215.   MENU 4,0,1:MENU 4,1,0:MENU 4,2,1:MENU 4,3,0
  216.   FOR i=2 TO n:WINDOW i:NEXT:COLOR 1,0
  217. scale:
  218.   GOSUB checkends
  219.   IF wflag=0 THEN WINDOW 2,STR$(1)+")z="+f$,(1,10)-(617,162),23
  220.   CLS:qflag=0:PRINT"***Surface Scaling in Progress***"
  221.   pi=3.14159:co=col*pi/180:az=azi*pi/180
  222.   l=1e+20:u=-l:a=l:r=u:ls=SIN(co):lc=COS(co):sa=SIN(az):ac=COS(az)
  223.   cb=961:FOR x=m1 TO m2 STEP (m2-m1)/30
  224.   FOR y=m3 TO m4 STEP (m4-m3)/30:cb=cb-1
  225.   LOCATE 2,1:PRINT "Only ";cb;" more steps to go!"
  226.   GOSUB 100
  227.   z=z*ls-(x*ac+y*sa)*lc
  228.   IF l>z THEN l=z
  229.   IF u<z THEN u=z
  230.   c=(y*ac-x*sa):IF a>c THEN a=c
  231.   IF r<c THEN r=c
  232.   IF MENU(0)=4 THEN
  233.     IF MENU(1)=2 THEN
  234.       inq$="Stop Scaling"
  235.       WINDOW OUTPUT 1
  236.       GOSUB confirm
  237.       WINDOW OUTPUT n
  238.       IF an$="Y" THEN x=m2:y=m4:qflag=1
  239.     END IF
  240.   END IF  
  241.   NEXT:NEXT:IF qflag THEN setup
  242.   IF wflag=0 THEN WINDOW 2,,,22:wflag=1
  243.   o=u-l:t=(r-a)/200:sflag=1
  244. draw:
  245.   GOSUB checkends    
  246.   qflag=0:GOSUB ghostmenu
  247.   MENU 4,0,1:MENU 4,1,0:MENU 4,2,1:MENU 4,3,0
  248.   IF sflag=0 THEN scale
  249.   FOR i=2 TO n:WINDOW i:NEXT:COLOR 1,0
  250.   IF nflag THEN WINDOW nflag:COLOR 1,0
  251.   CLS:w=WINDOW(2)-1:h=WINDOW(3)-1
  252.   co=col*pi/180:az=azi*pi/180
  253.   ls=SIN(co):lc=COS(co):sa=SIN(az):ac=COS(az)
  254.   IF ABS(azi)<=90 THEN xbeg=m1:xend=m2:stpx=(m2-m1)/30 :ELSE xbeg=m2:xend=m1:stpx=(m1-m2)/30
  255.   IF azi>=0 THEN ybeg=m3:yend=m4:stpy=(m4-m3)/30 :ELSE ybeg=m4:yend=m3:stpy=(m3-m4)/30
  256.   FOR x=xbeg TO xend STEP stpx
  257.   FOR y=ybeg TO yend STEP stpy
  258.   GOSUB 100
  259.   z=z*ls-(x*ac+y*sa)*lc
  260.   y2=h-h*(z-l)/o:x2=w*((y*ac-x*sa)-a)/(200*t)
  261.   ho=x:x=x-(m2-m1)/30:GOSUB 100
  262.   z=z*ls-(x*ac+y*sa)*lc    
  263.   ly=h-h*(z-l)/o:lx=w*((y*ac-x*sa)-a)/(200*t)
  264.   x2=CINT(ABS(x2)):y2=CINT(ABS(y2))
  265.   lx=CINT(ABS(lx)):ly=CINT(ABS(ly)):x=ho
  266.   IF opq$="n" THEN grid
  267.   IF (x1>w OR x2>w) OR (lx>w OR ux>w) THEN nexprep
  268.   IF (y1>h OR y2>h) OR (ly>h OR uy>h) THEN nexprep
  269.   IF y1<>uy THEN xcrit=x1+(y1-y2)*(ux-x1)/(y1-uy):dx=SGN(x2-xcrit)*SGN(stpy) :ELSE dx=SGN(ux-x1)
  270.   IF x1<>x2 THEN ycrit=y1-(ux-x1)*(y1-y2)/(x2-x1):dy=SGN(ycrit-uy)*SGN(stpx) :ELSE dy=SGN(y2-y1)
  271.   afill:
  272.     IF dy<0 THEN COLOR 1,2 :ELSE COLOR 3,2  
  273.     IF x<>xbeg AND y<>ybeg THEN AREA (x1,y1):AREA (x2,y2):AREA (lx,ly):AREA (ux,uy):AREAFILL
  274.   grid:
  275.     xlines:
  276.       IF gtype=1 THEN ylines
  277.       IF y<>ybeg THEN LINE (x1,y1)-(x2,y2),2:IF x<>xbeg THEN LINE (ux,uy)-(lx,ly),2
  278.     ylines:
  279.       IF gtype=2 THEN nexprep
  280.       IF x<>xbeg THEN LINE (lx,ly)-(x2,y2),2:IF y<>ybeg THEN LINE (ux,uy)-(x1,y1),2
  281. nexprep:
  282.   ux=lx:uy=ly  
  283.   x1=x2:y1=y2
  284.   IF MENU(0)=4 THEN
  285.     IF MENU(1)=2 THEN
  286.       inq$="Stop Drawing"
  287.       WINDOW OUTPUT 1
  288.       GOSUB confirm
  289.       WINDOW OUTPUT n
  290.       IF an$="Y" THEN x=xend:y=yend:qflag=1
  291.     END IF
  292.   END IF  
  293.   NEXT:NEXT:IF qflag THEN setup
  294. pause:
  295.   WINDOW OUTPUT 1
  296.   LOCATE 22,26:COLOR 2,1
  297.   PRINT" Press any key to continue. "
  298.   a$=INKEY$
  299.   waitloop:
  300.     a$=INKEY$
  301.     IF a$="" THEN waitloop
  302. endraw:
  303.   GOTO setup
  304. figcolor:
  305.   GOSUB ghostmenu
  306.   red=r(id):green=g(id):blue=b(id)
  307.   GOSUB changecolor
  308.   LINE (155,15)-(255,75),3,bf
  309.   LINE (350,15)-(450,75),1,bf
  310.   LINE (205,15)-(205,75),2:LINE (155,45)-(255,45),2
  311.   LINE (400,15)-(400,75),2:LINE (350,45)-(450,45),2
  312.   LOCATE 11,25:PRINT"TOP":LOCATE 11,48:PRINT"BOTTOM"
  313.   LINE (50,103)-(550,113),1,b
  314.   LINE (98,104)-STEP(450,8),0,bf
  315.   LOCATE 14,8:PRINT "red"
  316.   LINE (50,119)-(550,129),1,b
  317.   LINE (98,120)-STEP(450,8),0,bf
  318.   LOCATE 16,8:PRINT "green"
  319.   LINE (50,135)-(550,145),1,b
  320.   LINE (98,136)-STEP(450,8),0,bf
  321.   LOCATE 18,8:PRINT "blue"
  322.   LINE (155,153)-(255,173),1,b
  323.   PAINT (200,163),0,1:LOCATE 21,24:PRINT "RESET"
  324.   LINE (350,153)-(455,173),1,b
  325.   PAINT (400,163),0,1:LOCATE 21,49:PRINT "QUIT"
  326.   colorbars:
  327.     LINE (98,104)-STEP(red*452,8),1,bf
  328.     LINE (98,120)-STEP(green*452,8),1,bf
  329.     LINE (98,136)-STEP(blue*452,8),1,bf
  330.   checkmouse:
  331.     IF MOUSE(0)=0 THEN checkmouse
  332.     x0=MOUSE(1):y0=MOUSE(2)
  333.     IF (y0>153 AND y0<173) AND MOUSE(0)>-1 THEN
  334.        IF x0>155 AND x0<255 THEN figcolor
  335.        IF x0>350 AND x0<455 THEN
  336.          r(id)=red:g(id)=green:b(id)=blue
  337.          GOTO setup1
  338.        END IF  
  339.        GOTO checkmouse
  340.     END IF   
  341.     x=MOUSE(5):y=MOUSE(4):newcolor=(x-98)/(550-98)
  342.     IF newcolor<0 OR newcolor>1 THEN checkmouse
  343.     IF y>103 AND y<113 THEN
  344.       red=newcolor:GOSUB changecolor
  345.       LINE (98,104)-STEP(450,8),0,bf
  346.       GOTO colorbars
  347.     END IF
  348.     IF y>119 AND y<129 THEN
  349.       green=newcolor:GOSUB changecolor
  350.       LINE (98,120)-STEP(450,8),0,bf
  351.       GOTO colorbars
  352.     END IF
  353.     IF y>135 AND y<145 THEN
  354.       blue=newcolor:GOSUB changecolor
  355.       LINE (98,136)-STEP(450,8),0,bf
  356.       GOTO colorbars
  357.     END IF
  358.     GOTO checkmouse
  359.   changecolor:
  360.     PALETTE id,red,green,blue
  361.     RETURN
  362. ghostmenu:
  363.   MENU 1,0,0:MENU 2,0,0:MENU 3,0,0:MENU 4,0,0
  364.   RETURN
  365. checkends:
  366.   IF (m1>m2) OR (m3>m4) THEN
  367.     BEEP:status$=""
  368.     IF m1>m2 THEN status$=status$+" xmin>xmax. "
  369.     IF m3>m4 THEN status$=status$+" ymin>ymax. "
  370.     ov%=34-LEN(status$)/2:LOCATE 22,ov%
  371.     COLOR 2,1:PRINT status$+"Please fix. ":COLOR 1,0
  372.     GOTO options
  373.   END IF
  374. xstatus:
  375.   COLOR 1,0:LOCATE 22,ov%:c=2*(34-ov%)+12
  376.   FOR i=1 TO c:PRINT" ";:NEXT
  377.   RETURN
  378. confirm:
  379.   lin=CSRLIN
  380.   row=POS(0)
  381.   mv%=30-LEN(inq$)/2
  382.   LOCATE 22,mv%:COLOR 2,1
  383.   PRINT " "+inq$+" ";:COLOR 1,0
  384.   PRINT " Are you sure (y/n)?"
  385. getakey:  
  386.   a$=INKEY$
  387.   an$=UCASE$(a$)
  388.   IF an$<>"Y" AND an$<>"N" THEN getakey
  389.   LOCATE 22,mv%
  390.   FOR i=1 TO 50
  391.     PRINT " ";
  392.   NEXT
  393.   LOCATE lin,row
  394. RETURN
  395. mischeck:
  396.   IF (ERR=5) OR (ERR=11) THEN RESUME NEXT
  397.   IF (ERR=2) AND (ERL=100) THEN GOTO request
  398.   ON ERROR GOTO 0
  399.   request:
  400.     CLS:BEEP:PRINT"Syntax error in equation."
  401.     PRINT:PRINT"z=";f$
  402.   eflag=1:RESUME NEXT
  403.