' ************* 3DGrapher ************** ' ***** Copyright 1987 Randy Finch ***** ' This program plots Z = F(X,Y) with any axes rotation. ' Axes drawn in following order: X, Y, Z ' ********** SET UP PROGRAM PARAMETERS ********** CLEAR,30000 CLEAR,75000& WIDTH WINDOW(2)/8 - 2 CLS : PRINT "Please wait ..." curdir$ = "df1:" CHDIR curdir$ LIBRARY "graphics.library" DECLARE FUNCTION ReadPixel&() LIBRARY LIBRARY "dos.library" DECLARE FUNCTION Lock&() LIBRARY DECLARE FUNCTION Execute&() LIBRARY success& = Execute&(SADD("cd "+curdir$+CHR$(0)),0,0) ON BREAK GOSUB EndProg BREAK ON checknum$ = "-.0123456789" checknumpos$ = ".0123456789" true% = -1 false% = 0 wrongequation% = false% ' used when retrieving a graph picsave% = false% ' flag for saving a graph picget% = false% ' flag for retrieving a graph plottinggraph% = false% ' flag - graph not currently plotting size% = 20003 DIM pic%(size%) ' to GET screen GOSUB SetUpMenu GOSUB SetUserParameters GOSUB SetUpScreen GOSUB SetColorPalette GOSUB SetEquationParameters WIDTH 38 LOCATE 12,7 PRINT "PLEASE CHOOSE A MENU ITEM." WaitForMenu: GOTO WaitForMenu ' ********************* MENU ROUTINES ************************ Origin: GOSUB SetEquationParameters ' in case changes made ' Project origin to projection plane along line to viewer xprojbase& = vp& * (xbase& - xcenter&) / (vp& + zplane&) + xcenter& yprojbase& = vp& * (ybase& - ycenter&) / (vp& + zplane&) + ycenter& dummy = MOUSE(0) ' Clear mouse settings WHILE MOUSE(0) = 0 OR MOUSE(0) = -1: WEND xclick& = MOUSE(3) yclick& = MOUSE(4) IF xclick& < 1 AND yclick& < 1 THEN WINDOW 3, "Set Origin", (0,65)-(311,130),18,2 COLOR textpen%,0 PRINT PRINT "Current projected origin" PRINT "in screen coordinates:" PRINT PRINT "X-axis: "; xprojbase& ; TAB(20) ; "CHANGE TO:" PRINT "Y-axis: "; yprojbase& ; TAB(20) ; "CHANGE TO:" CALL GetString(gs$, 5, 31, checknum$) IF gs$ <> "" THEN xclick& = VAL(gs$) ELSE xclick& = xprojbase& END IF CALL GetString(gs$, 6, 31, checknum$) IF gs$ <> "" THEN yclick& = VAL(gs$) ELSE yclick& = yprojbase& END IF WINDOW CLOSE 3 END IF xmove& = xclick& - xprojbase& ymove& = yclick& - yprojbase& SCROLL (0,0)-(319,199), xmove&, ymove& xp& = xp& + xmove& yp& = yp& + ymove& xbase& = (vp& + zplane&) * (xclick& - xcenter&) / vp& + xcenter& ybase& = (vp& + zplane&) * (yclick& - ycenter&) / vp& + ycenter& pixelcolor% = POINT(xp&,yp&) ' Only to move point cursor MENU ON RETURN Rotation: WINDOW 3, "Set Axes Rotation", (0,65)-(311,130),18,2 COLOR textpen%,0 PRINT PRINT "Current rotations" PRINT " in degrees" PRINT PRINT "Z-axis: "; thetadegrees ; TAB(20) ; "CHANGE TO:" PRINT "Y-axis: "; phidegrees ; TAB(20) ; "CHANGE TO:" PRINT "X-axis: "; deltadegrees ; TAB(20) ; "CHANGE TO:" CALL GetString(gs$, 5, 31, checknum$) IF gs$ <> "" THEN thetadegrees = VAL(gs$) CALL GetString(gs$, 6, 31, checknum$) IF gs$ <> "" THEN phidegrees = VAL(gs$) CALL GetString(gs$, 7, 31, checknum$) IF gs$ <> "" THEN deltadegrees = VAL(gs$) WINDOW CLOSE 3 MENU ON RETURN Scale: WINDOW 3, "Set Scale", (0,65)-(311,130), 18, 2 COLOR textpen%,0 PRINT PRINT "Current scale in" PRINT "pixels per unit: "; pperu& PRINT PRINT "CHANGE TO: "; CALL GetString(gs$, 5, 12, checknumpos$) IF gs$ <> "" THEN pperu& = VAL(gs$) WINDOW CLOSE 3 MENU ON RETURN ViewDist: WINDOW 3, "Set Viewing Distance", (0,65)-(311,130), 18, 2 COLOR textpen%,0 PRINT PRINT "Current viewing distance from" PRINT "projection plane in units: "; viewerdistance PRINT PRINT "CHANGE TO: "; CALL GetString(gs$, 5, 12, checknumpos$) IF gs$ <> "" THEN pperu& = pperu& * viewerdistance / VAL(gs$) viewerdistance = VAL(gs$) END IF WINDOW CLOSE 3 MENU ON RETURN ProjPlane: WINDOW 3, "Set Projection Plane", (0,65)-(311,130), 18, 2 COLOR textpen%,0 PRINT PRINT "Current projection plane, Z = "; zplaneunit PRINT PRINT "CHANGE TO Z = "; CALL GetString(gs$, 4, 15, checknum$) IF gs$ <> "" THEN zplaneunit = VAL(gs$) WINDOW CLOSE 3 MENU ON RETURN LineSpacing: WINDOW 3, "Set Line Spacing", (0,60)-(311,135), 18, 2 COLOR textpen%,0 PRINT PRINT "THESE VALUES DETERMINE THE DISTANCE," PRINT "IN UNITS, BETWEEN EACH DRAWN LINE." PRINT PRINT "Current values" PRINT PRINT "X-axis: "; spacex ; TAB(20) ; "CHANGE TO: " PRINT "Y-axis: "; spacey ; TAB(20) ; "CHANGE TO: " CALL GetString(gs$, 7, 31, checknumpos$) IF gs$ <> "" AND VAL(gs$) <> 0 THEN spacex = VAL(gs$) CALL GetString(gs$, 8, 31, checknumpos$) IF gs$ <> "" AND VAL(gs$) <> 0 THEN spacey = VAL(gs$) WINDOW CLOSE 3 MENU ON RETURN PlotPrecision: WINDOW 3, "Set Plot Precision", (0,55)-(311,145), 18, 2 COLOR textpen%,0 PRINT PRINT "THESE VALUES DETERMINE THE PRECISION" PRINT "OF THE PLOT AND THE SPEED IT WILL BE" PRINT "DRAWN. THE VALUES REPRESENT THE DIS-" PRINT "TANCE IN UNITS BETWEEN PLOTTED PIXELS." PRINT PRINT "Current values" PRINT PRINT "X-axis: "; incx ; TAB(20) ; "CHANGE TO: " PRINT "Y-axis: "; incy ; TAB(20) ; "CHANGE TO: " CALL GetString(gs$, 9, 31, checknumpos$) IF gs$ <> "" AND VAL(gs$) <> 0 THEN incx = VAL(gs$) CALL GetString(gs$, 10, 31, checknumpos$) IF gs$ <> "" AND VAL(gs$) <> 0 THEN incy = VAL(gs$) WINDOW CLOSE 3 MENU ON RETURN PlotSpan: WINDOW 3, "Set Plotting Ranges", (0,55)-(311,140), 18, 2 COLOR textpen%,0 PRINT PRINT "Current values" PRINT PRINT "X minimum: "; txmin; TAB(20) ; "CHANGE TO: " PRINT "X maximum: "; txmax; TAB(20) ; "CHANGE TO: " PRINT "Y minimum: "; tymin; TAB(20) ; "CHANGE TO: " PRINT "Y maximum: "; tymax; TAB(20) ; "CHANGE TO: " CALL GetString(gs$, 4, 31, checknum$) IF gs$ <> "" THEN txmin = VAL(gs$) Gettxmax: CALL GetString(gs$, 5, 31, checknum$) IF gs$ <> "" THEN txmax = VAL(gs$) IF txmax < txmin THEN Gettxmax CALL GetString(gs$, 6, 31, checknum$) IF gs$ <> "" THEN tymin = VAL(gs$) Gettymax: CALL GetString(gs$, 7, 31, checknum$) IF gs$ <> "" THEN tymax = VAL(gs$) IF tymax < tymin THEN Gettymax WINDOW CLOSE 3 MENU ON RETURN AxesSpan: WINDOW 3, "Set Axes Ranges", (0,55)-(311,145), 18, 2 COLOR textpen%,0 PRINT PRINT "Current values" PRINT PRINT "X minimum: "; axmin; TAB(20) ; "CHANGE TO: " PRINT "X maximum: "; axmax; TAB(20) ; "CHANGE TO: " PRINT "Y minimum: "; aymin; TAB(20) ; "CHANGE TO: " PRINT "Y maximum: "; aymax; TAB(20) ; "CHANGE TO: " PRINT "Z minimum: "; azmin; TAB(20) ; "CHANGE TO: " PRINT "Z maximum: "; azmax; TAB(20) ; "CHANGE TO: " PRINT "Precision: "; axesinc; TAB(20) ; "CHANGE TO: " CALL GetString(gs$, 4, 31, checknum$) IF gs$ <> "" THEN axmin = VAL(gs$) Getaxmax: CALL GetString(gs$, 5, 31, checknum$) IF gs$ <> "" THEN axmax = VAL(gs$) IF axmax < axmin THEN Getaxmax CALL GetString(gs$, 6, 31, checknum$) IF gs$ <> "" THEN aymin = VAL(gs$) Getaymax: CALL GetString(gs$, 7, 31, checknum$) IF gs$ <> "" THEN aymax = VAL(gs$) IF aymax < aymin THEN Getaymax CALL GetString(gs$, 8, 31, checknum$) IF gs$ <> "" THEN azmin = VAL(gs$) Getazmax: CALL GetString(gs$, 9, 31, checknum$) IF gs$ <> "" THEN azmax = VAL(gs$) IF azmax < azmin THEN Getazmax CALL GetString(gs$, 10, 31, checknumpos$) IF gs$ <> "" THEN axesinc = VAL(gs$) WINDOW CLOSE 3 MENU ON RETURN CHOn: xdrawflag% = true% ydrawflag% = true% MENU 1,10,2 MENU 1,11,1 MENU ON RETURN CHOff: dummy = MOUSE(0) ' Clear mouse settings WINDOW 3, "Crosshatch On Select", (0,75)-(311,125),18,2 COLOR textpen%,0 PRINT PRINT " LINES DRAWN PARALLEL TO WHICH AXIS?" PRINT PRINT " X Y"; TAB(31) ; "CANCEL" LINE (28,20)-(42,34),,b LINE (68,20)-(82,34),,b LINE (236,20)-(290,34),,b ChooseBox: WHILE MOUSE(0) = 0 OR MOUSE(0) = -1 : WEND xclick& = MOUSE(3) yclick& = MOUSE(4) IF yclick& >= 20 AND yclick& <= 34 THEN IF xclick& >= 28 AND xclick& <= 42 THEN xdrawflag% = true% ydrawflag% = false% GOTO EndCHChoose ELSEIF xclick& >= 68 AND xclick& <= 82 THEN xdrawflag% = false% ydrawflag% = true% GOTO EndCHChoose ELSEIF xclick& >= 236 AND xclick& <= 290 THEN GOTO EndCHChoose2 ELSE END IF END IF GOTO ChooseBox EndCHChoose: MENU 1,10,1 MENU 1,11,2 EndCHChoose2: WINDOW CLOSE 3 MENU ON RETURN AxesOn: axesflag% = true% MENU 1,12,2 MENU 1,13,1 MENU ON RETURN AxesOff: axesflag% = false% MENU 1,12,1 MENU 1,13,2 MENU ON RETURN Background: CALL DrawColorWindow("Set Background Color") CALL SetColorBars(0,bkgred, bkggreen, bkgblue, -1, 0!, 0!, 0!) MENU ON RETURN Graph: CALL DrawColorWindow("Set Graph Colors") CALL SetColorBars(pennumbase%,graphfarred, graphfargreen, graphfarblue, pennummax%, graphnearred, graphneargreen, graphnearblue) MENU ON RETURN Axes: CALL DrawColorWindow("Set Axes Color") CALL SetColorBars(axespen%,axesred, axesgreen, axesblue, -1, 0!, 0!, 0!) MENU ON RETURN Border: CALL DrawColorWindow("Set Border Color") CALL SetColorBars(1,borderred, bordergreen, borderblue, -1, 0!, 0!, 0!) MENU ON RETURN Text: CALL DrawColorWindow("Set Text Color") CALL SetColorBars(textpen%,textred, textgreen, textblue, -1, 0!, 0!, 0!) MENU ON RETURN SavePic: ext$ = "3D" GOSUB GetFile SavePicFile: IF filename$ <> "" THEN IF filelock& = false% THEN CLS PRINT "The screen will be restored" PRINT "when the save is complete." OPEN filename$+".3D" FOR OUTPUT AS #1 FOR j% = 0 TO size% PRINT#1, MKI$(pic%(j%)); NEXT PRINT#1, equation$ CLOSE 1 picsave% = true% GOTO SaveSets ELSE CLS PRINT "File exists." PRINT INPUT "OVERWRITE (Y/N) ?? ",overwrite$ IF INSTR("Yy",LEFT$(overwrite$,1)) THEN filelock& = false% GOTO SavePicFile END IF END IF END IF PUT (0,0), pic%, PSET MENU ON RETURN SaveSets: IF picsave% = false% THEN ext$ = "SET" GOSUB GetFile SaveSetFile: IF filename$ <> "" THEN IF filelock& = false% THEN CLS PRINT "The screen will be restored" PRINT "when the save is complete." ELSE CLS PRINT "File exists." PRINT INPUT "OVERWRITE (Y/N) ?? ",overwrite$ IF INSTR("Yy",LEFT$(overwrite$,1)) THEN filelock& = false% GOTO SaveSetFile ELSE GOTO QuitSetSave END IF END IF ELSE GOTO QuitSetSave END IF END IF OPEN filename$+".SET" FOR OUTPUT AS #1 PRINT #1, xbase& PRINT #1, ybase& PRINT #1, thetadegrees PRINT #1, phidegrees PRINT #1, deltadegrees PRINT #1, pperu& PRINT #1, viewerdistance PRINT #1, zplaneunit PRINT #1, txmin PRINT #1, txmax PRINT #1, tymin PRINT #1, tymax PRINT #1, spacex PRINT #1, spacey PRINT #1, incx PRINT #1, incy PRINT #1, xdrawflag% PRINT #1, ydrawflag% PRINT #1, axesflag% PRINT #1, axmin PRINT #1, axmax PRINT #1, aymin PRINT #1, aymax PRINT #1, azmin PRINT #1, azmax PRINT #1, axesinc CLOSE 1 QuitSetSave: PUT (0,0), pic%, PSET MENU ON picsave% = false% ' reset flag RETURN GetPic: ext$ = "3D" GOSUB GetFile GetPicFile: IF filename$ <> "" THEN IF filelock& THEN CLS PRINT "The graph will appear when" PRINT "retrieval is complete." OPEN filename$+".3D" FOR INPUT AS #1 FOR j% = 0 TO size% tempstr$ = INPUT$(2,1) pic%(j%) = CVI(tempstr$) NEXT INPUT#1, eq$ IF eq$ = equation$ THEN wrongequation% = false% ELSE wrongequation% = true% equation$ = eq$ END IF CLOSE 1 picget% = true% GOTO GetSets ELSE CLS PRINT "File does not exist. Press [RETURN]. WHILE INKEY$ <> CHR$(13) : WEND END IF END IF PUT (0,0), pic%, PSET MENU ON RETURN WaitForMenu GetSets: IF picget% = false% THEN ext$ = "SET" GOSUB GetFile IF filename$ <> "" THEN IF filelock& THEN CLS PRINT "The screen will be restored" PRINT "when retrieval is complete." ELSE CLS PRINT "File does not exist. Press [RETURN]. WHILE INKEY$ <> CHR$(13) : WEND GOTO QuitGetSets END IF ELSE GOTO QuitGetSets END IF END IF OPEN filename$+".SET" FOR INPUT AS #1 INPUT #1, xbase& INPUT #1, ybase& INPUT #1, thetadegrees INPUT #1, phidegrees INPUT #1, deltadegrees INPUT #1, pperu& INPUT #1, viewerdistance INPUT #1, zplaneunit INPUT #1, txmin INPUT #1, txmax INPUT #1, tymin INPUT #1, tymax INPUT #1, spacex INPUT #1, spacey INPUT #1, incx INPUT #1, incy INPUT #1, xdrawflag% INPUT #1, ydrawflag% INPUT #1, axesflag% INPUT #1, axmin INPUT #1, axmax INPUT #1, aymin INPUT #1, aymax INPUT #1, azmin INPUT #1, azmax INPUT #1, axesinc CLOSE 1 GOSUB SetEquationParameters QuitGetSets: PUT (0,0), pic%, PSET MENU ON picget% = false% ' reset flag RETURN DrawGraph: ' Don't draw graph if equation incorrect IF wrongequation% = true% THEN GET (0,0)-(319,199), pic% CLS PRINT PRINT "A graph has been retrieved from disk" PRINT "and the equation does not match the" PRINT "currently defined equation in the pro-" PRINT "gram. Please save current settings," PRINT "input the appropriate equation, re-run" PRINT "the program, and retrieve the saved" PRINT "settings." LOCATE 15,30 : PRINT "OK" LINE (229,109)-(249,121),,b GetDGClick: dummy = MOUSE(0) WHILE MOUSE(0) = 0 : WEND xclick& = MOUSE(3) yclick& = MOUSE(4) IF yclick& >= 109 AND yclick& <= 121 THEN IF xclick& >= 229 AND xclick& <= 249 THEN PUT (0,0),pic%,PSET MENU ON RETURN END IF END IF GOTO GetDGClick END IF ' OK to draw graph MENU 1,2,0 MENU 1,3,0 MENU 1,4,0 MENU 1,5,0 MENU 3,3,0 MENU 3,4,0 MENU 4,1,0 MENU 4,2,1 MENU ON plottinggraph% = true% CLS LOCATE 11,6 PRINT "Please wait while preliminary" LOCATE 13,7 PRINT "calculations are performed." GOSUB SetEquationParameters GOSUB SetCoordinateParameters GOSUB DefineFunctions ' CALCULATE MINIMUM & MAXIMUM DISTANCES FROM USER ' Initialize minimum & maximum tz = FNcalc(txmin,tymin) dtoplane = FNzcalc(txmin,tymin,tz) dmax = dtoplane dmin = dtoplane ' Loop on X at constant Y's IF xdrawflag% = true% THEN FOR ty = tymin TO tymax STEP calcspacey FOR tx = txmin TO txmax STEP calcincx tz = FNcalc(tx,ty) dtoplane = FNzcalc(tx,ty,tz) dmax = FNmax(dmax,dtoplane) dmin = FNmin(dmin,dtoplane) NEXT tx NEXT ty END IF ' Loop on Y at constant X's IF ydrawflag% = true% THEN FOR tx = txmin TO txmax STEP calcspacex FOR ty = tymin TO tymax STEP calcincy tz = FNcalc(tx,ty) dtoplane = FNzcalc(tx,ty,tz) dmax = FNmax(dmax,dtoplane) dmin = FNmin(dmin,dtoplane) NEXT ty NEXT tx END IF ' Calculate distance spread and depth of each color range spread = dmax - dmin colorspread = spread/numcolors% IF colorspread = 0 THEN colorspread = 1 'in case all points equidistant ' PLOT THE GRAPH ' Plot X's at constant Y's for specified range of Y CLS IF xdrawflag% = true% THEN FOR ty = tymin TO tymax STEP spacey backflag% = true% ' Prevent last point from connecting with the next first point FOR tx = txmin TO txmax STEP incx GOSUB CalcAndPlot NEXT tx NEXT ty END IF ' Plot Y's at constant X for specified range of X IF ydrawflag% = true% THEN ' Do only if user specified FOR tx = txmin TO txmax STEP spacex backflag% = true% ' Prevent last point from connecting with the next first point FOR ty = tymin TO tymax STEP incy GOSUB CalcAndPlot NEXT ty NEXT tx END IF ' DRAW AXES IF axesflag% = true% THEN ' Do only if user specified ' X-axis IF axmax > axmin THEN ' Do not plot if equal ty = 0 : tz = 0 FOR tx = axmin TO axmax STEP axesinc GOSUB AxesCalcAndPlot NEXT tx END IF ' Y-axis IF aymax > aymin THEN tx = 0 : tz = 0 FOR ty = aymin TO aymax STEP axesinc GOSUB AxesCalcAndPlot NEXT ty END IF ' Z-axis IF azmax > azmin THEN tx = 0 : ty = 0 FOR tz = azmin TO azmax STEP axesinc GOSUB AxesCalcAndPlot NEXT tz END IF END IF plottinggraph% = false% GOTO StopGraph StopGraph: MENU 1,2,1 MENU 1,3,1 MENU 1,4,1 MENU 1,5,1 MENU 3,3,1 MENU 3,4,1 MENU 4,1,1 MENU 4,2,0 MENU ON IF plottinggraph% = true% THEN RETURN ClearStack ClearStack: RETURN WaitForMenu InputEquation: GET (0,0)-(319,199),pic% CLS WIDTH 38 PRINT PRINT "The program will end and list the sub-" PRINT "routine SetUserParameters. Change the" PRINT "equation in lines 1 AND 2 of this sub-" PRINT "routine, and then re-run the program." PRINT "You must save any picture and/or set-" PRINT "tings at this time or you will lose" PRINT "them when the program ends." PRINT PRINT PRINT " OK CANCEL" LINE (5,75)-(27,91),,b LINE (37,75)-(91,91),,b GetIEClick: dummy = MOUSE(0) WHILE MOUSE(0) = 0 : WEND xclick& = MOUSE(3) yclick& = MOUSE(4) IF yclick& >= 75 AND yclick& <= 91 THEN IF xclick& >= 5 AND xclick& <= 27 THEN RETURN EndProg ELSEIF xclick& >= 37 AND xclick& <= 91 THEN PUT (0,0),pic%,PSET MENU ON RETURN END IF END IF GOTO GetIEClick ShowEquation: WINDOW 3, "Current Equation", (0,135)-(311,185), 26, 2 COLOR textpen%,0 WIDTH 38 PRINT PRINT "Z = " PRINT PRINT equation$ WHILE WINDOW(8) <> 0 : WEND WINDOW OUTPUT 2 MENU ON RETURN ShowSettings: GET (0,0)-(319,199),pic% CLS PRINT " ORIGIN: X ="; xbase& PRINT " Y ="; ybase& PRINT " ROTATION: Z ="; thetadegrees; "degrees" PRINT " Y ="; phidegrees; "degrees" PRINT " X ="; deltadegrees; "degrees" PRINT " SCALE:"; pperu&; "pixels per unit" PRINT " VIEW DISTANCE:"; viewerdistance; "units" PRINT " PROJ PLANE: Z ="; zplaneunit PRINT " LINE SPACING: X-axis ="; spacex PRINT " Y-axis ="; spacey PRINT "PLOT PRECISION: X-axis ="; incx PRINT " Y-axis ="; incy PRINT " PLOT SPAN: X min ="; txmin PRINT " X max ="; txmax PRINT " Y min ="; tymin PRINT " Y max ="; tymax PRINT " AXES SPAN: X min ="; axmin; "X max ="; axmax PRINT " Y min ="; aymin; "Y max ="; aymax PRINT " Z min ="; azmin; "Z max ="; azmax PRINT "AXES PRECISION:"; axesinc PRINT " CROSSHATCH IS: "; IF xdrawflag% = true% AND ydrawflag% = true% THEN PRINT "ON" ELSE PRINT "OFF "; IF xdrawflag% = true% THEN PRINT "X-axis ON" ELSE PRINT "Y-axis ON" END IF END IF PRINT " AXES ARE: "; IF axesflag% = true% THEN PRINT "ON" ELSE PRINT "OFF" END IF LOCATE 23,36 : PRINT "OK" LINE (276,172)-(298,186),,b GetSSClick: dummy = MOUSE(0) WHILE MOUSE(0) = 0 : WEND xclick& = MOUSE(3) yclick& = MOUSE(4) IF yclick& >= 172 AND yclick& <= 186 THEN IF xclick& >= 276 AND xclick& <= 298 THEN PUT (0,0),pic%,PSET MENU ON RETURN END IF END IF GOTO GetSSClick QuitProg: WINDOW 3,"QUIT PROGRAM!!",(10,80)-(300,120),18,2 PRINT " Are You Sure?" LOCATE 4,12 : PRINT "YES" LOCATE 4,22 : PRINT "NO" LINE (84,20)-(114,34),,b LINE (164,20)-(186,34),,b GetQPClick: dummy = MOUSE(0) WHILE MOUSE(0) = 0 : WEND xclick& = MOUSE(3) yclick& = MOUSE(4) IF yclick& >= 20 AND yclick& <= 34 THEN IF xclick& >= 84 AND xclick& <= 114 THEN WINDOW CLOSE 3 GOTO EndProg ELSEIF xclick& >= 164 AND xclick& <= 186 THEN WINDOW CLOSE 3 PUT (0,0),pic%,PSET MENU ON RETURN END IF END IF GOTO GetQPClick ' ************** END THE PROGRAM GRACEFULLY ************** EndProg: WINDOW CLOSE 2 SCREEN CLOSE 2 MENU RESET WIDTH 78 LIST SetUserParameters END ' ****************** SUBROUTINES ******************** SetUserParameters: DEF FNcalc(X,Y) = 3.5*COS(1.75*(X*X+Y*Y))*EXP(-.8*(X*X+Y*Y)) equation$ = "3.5*COS(1.75*(X*X+Y*Y))*EXP(-.8*(X*X+Y*Y))" thetadegrees = 135 ' Rotation about Z phidegrees = 60 ' Rotation about Y deltadegrees = -45 ' Rotation about X pperu& = 30 ' pixels per unit distance for X-axis ' Plotting ranges txmin = -3 : txmax = 3 tymin = -3 : tymax = 3 ' Spacing between lines spacex = 1 : spacey = 1 ' Plot accuracy in units between plotted pixels incx = (txmax-txmin)/60 : incy = incx ' Axes ranges axmin = -4 : axmax = 4 aymin = -4 : aymax = 4 azmin = -4 : azmax = 4 ' Axes plot precision axesinc = .1 ' Origin projected perpendicular to projection plane xbase& = 160 : ybase& = 100 ' Center of screen xcenter& = 160 : ycenter& = 100 viewerdistance = 20 ' in units from projection plane zplaneunit = 0 ' distance of projection plane from origin ' Crosshatching on xdrawflag% = true% ydrawflag% = true% axesflag% = true% ' draw axes RETURN SetEquationParameters: ' Viewer distance in pixels from projection plane vp& = viewerdistance * pperu& ' Distance in pixels of projection plane from origin zplane& = zplaneunit * pperu& aspectratio = .927 ' to correct y-axis pi = 3.14159 ' Values to speed up min and max calcs to get colorspread calcspacex = spacex : calcspacey = spacey calcincx = 5*incx : calcincy = 5*incy RETURN SetColorPalette: numcolors% = 16 pennumbase% = 14 pennummax% = pennumbase% + numcolors% - 1 axespen% = 2 textpen% = 3 COLOR textpen%,0 bkgred = 0 : bkggreen = 0 : bkgblue = 0 ' Black background axesred = .5 : axesgreen = 0 : axesblue = 0 ' Red axes borderred = .5 : bordergreen = .5 : borderblue = .5 ' Medium gray border textred = .5 : textgreen = 0 : textblue = .5 ' Purple text graphfarred = 0 : graphfargreen = 0 : graphfarblue = 1 graphnearred = 1 : graphneargreen = 1 : graphnearblue = 1 PALETTE 0,bkgred,bkggreen,bkgblue PALETTE 1,borderred,bordergreen,borderblue PALETTE axespen%,axesred,axesgreen,axesblue PALETTE textpen%,textred,textgreen,textblue PALETTE 30,0,.5,0 ' Green in menu PALETTE 31,.8,.8,0 ' Yellow in menu ' Set color scale for graph FOR num% = pennumbase% TO pennummax% fractionred = graphfarred + (num% - pennumbase%) * (graphnearred - graphfarred) / numcolors% fractiongreen = graphfargreen + (num% - pennumbase%) * (graphneargreen - graphfargreen) / numcolors% fractionblue = graphfarblue + (num% - pennumbase%) * (graphnearblue - graphfarblue) / numcolors% PALETTE num%,fractionred,fractiongreen,fractionblue NEXT num% RETURN DefineFunctions: DEF FNmax(a,b) = -(a>=b)*a - (b>a)*b DEF FNmin(a,b) = -(a<=b)*a - (b pennummax% THEN pennum% = pennummax% IF pennum% < pennumbase% THEN pennum% = pennumbase% pixelcolor% = ReadPixel&(rp&,xp&,yp&) IF pixelcolor% <= pennum% THEN IF backflag% THEN PSET(xp&,yp&),pennum% backflag% = false% ELSE LINE -(xp&,yp&),pennum% END IF ELSE PSET(xp&,yp&), pixelcolor% backflag% = true% END IF END IF RETURN AxesCalcAndPlot: GOSUB Calculate IF onscreen% = true% THEN pixelcolor% = ReadPixel&(rp&,xp&,yp&) dtoplane = FNzcalc(tx,ty,tz) potencolor% = INT((dtoplane - dmin)/colorspread) + pennumbase% IF potencolor% > pixelcolor% THEN PSET(xp&,yp&),axespen% END IF RETURN Calculate: xpixels = FNxcalc(tx,ty,tz) * pperu& + xbase& - xcenter& ypixels = -FNycalc(tx,ty,tz) * pperu& + ybase& - ycenter& zpixels = FNzcalc(tx,ty,tz) * pperu& zdiff = vp& + zplane& - zpixels ' negative if behind viewer IF zdiff > 1 THEN tforline = vp& / (vp& + zplane& - zpixels) xp& = xpixels * tforline + xcenter& yp& = ypixels * tforline * aspectratio + ycenter& onscreen% = true% ELSE xp& = -1 yp& = -1 onscreen% = false% END IF RETURN SetCoordinateParameters: theta = thetadegrees * pi / 180 phi = phidegrees * pi / 180 delta = deltadegrees * pi / 180 sintheta = SIN(theta) sinphi = SIN(phi) sindelta = SIN(delta) costheta = COS(theta) cosphi = COS(phi) cosdelta = COS(delta) ' Equation coefficients xcoeffx = cosphi * costheta xcoeffy = sindelta * sinphi * costheta + cosdelta * sintheta xcoeffz = -cosdelta * sinphi * costheta + sindelta * sintheta ycoeffx = -cosphi * sintheta ycoeffy = -sindelta * sinphi * sintheta + cosdelta * costheta ycoeffz = cosdelta * sinphi * sintheta + sindelta * costheta zcoeffx = sinphi zcoeffy = -sindelta * cosphi zcoeffz = cosdelta * cosphi RETURN SetUpScreen: xscreenmax% = 319 yscreenmax% = 199 SCREEN 2,320,200,5,1 WINDOW 2,,,16,2 rp& = WINDOW(8) RETURN GetFile: GET (0,0)-(319,199), pic% GetFile2: CLS GetFile3: PRINT "Current Directory is:" PRINT curdir$ PRINT PRINT "C - change directory" PRINT "D - show directory" PRINT "[RETURN] - Abort" PRINT INPUT "Filename: ", filename$ IF filename$ = "" THEN filelock& = false% RETURN ELSEIF INSTR("Cc",filename$) THEN CLS InputDir: PRINT "Input new directory, [RETURN] to Abort" INPUT "", newcurdir$ IF newcurdir$ = "" THEN GetFile2 dirlock& = Lock&(SADD(newcurdir$),-2) IF dirlock& = 0 THEN PRINT "Directory does not exist." PRINT GOTO InputDir END IF curdir$ = newcurdir$ CHDIR curdir$ success& = Execute&(SADD("cd "+curdir$+CHR$(0)),0,0) CALL UnLock(dirlock&) GOTO GetFile2 ELSEIF INSTR("Dd",filename$) THEN exstring$ = "list > ram:tempdir pat #?."+ext$+" quick"+CHR$(0) success& = Execute&(SADD(exstring$),0,0) IF success& THEN OPEN "ram:tempdir" FOR INPUT AS #1 ShowDir: CLS numfiles% = 0 WHILE NOT EOF(1) AND numfiles% < 20 LINE INPUT#1, fline$ PRINT fline$ numfiles% = numfiles% + 1 WEND PRINT INPUT "Filename: ", filename$ IF filename$ = "" THEN IF numfiles% = 20 THEN GOTO ShowDir ELSE CLOSE 1 KILL "ram:tempdir" GOTO GetFile2 END IF ELSE CLOSE 1 KILL "ram:tempdir" GOTO ExistFile END IF ELSE PRINT "Cannot obtain directory." GOTO GetFile3 END IF ELSE GOTO ExistFile END IF ExistFile: filelock& = Lock&(SADD(filename$+"."+ext$+CHR$(0)),-2) IF filelock& THEN CALL UnLock(filelock&) RETURN SetUpMenu: MENU 1,0,1, " SET" MENU 1,1,1, "Origin" MENU 1,2,1, "Rotation" MENU 1,3,1, "Scale" MENU 1,4,1, "View Distance" MENU 1,5,1, "Projection Plane" MENU 1,6,1, "Line Spacing" MENU 1,7,1, "Plot Precision" MENU 1,8,1, "Plot Span" MENU 1,9,1, "Axes Span" MENU 1,10,2, " Crosshatch On" MENU 1,11,1, " Crosshatch Off" MENU 1,12,2, " Axes On" MENU 1,13,1, " Axes Off" MENU 2,0,1, "COLOR" MENU 2,1,1, "Background" MENU 2,2,1, "Graph" MENU 2,3,1, "Axes" MENU 2,4,1, "Border" MENU 2,5,1, "Text" MENU 3,0,1, "FILE" MENU 3,1,1, "Save Picture" MENU 3,2,1, "Save Settings" MENU 3,3,1, "Get Picture" MENU 3,4,1, "Get Settings" MENU 4,0,1, "FUNCTION" MENU 4,1,1, "Plot" MENU 4,2,0, "Stop Plot" MENU 4,3,1, "Input Equation" MENU 4,4,1, "Show Equation" MENU 4,5,1, "Show Settings" MENU 4,6,1, "QUIT" ON MENU GOSUB HandleMenu MENU ON RETURN HandleMenu: MENU OFF ON MENU(0) GOTO Settings, ColorSet, File, FunctionSet Settings: ON MENU(1) GOTO Origin, Rotation, Scale, ViewDist, ProjPlane, LineSpacing, PlotPrecision, PlotSpan, AxesSpan, CHOn, CHOff, AxesOn, AxesOff ColorSet: ON MENU(1) GOTO Background, Graph, Axes, Border, Text File: ON MENU(1) GOTO SavePic, SaveSets, GetPic, GetSets FunctionSet: ON MENU(1) GOTO DrawGraph, StopGraph, InputEquation, ShowEquation, ShowSettings, QuitProg ' ************************ SUB PROGRAMS **************************** SUB GetString(td$, down%, across%, checkstring$) STATIC StartOfLoop: LOCATE down%,across% INPUT "",td$ IF td$ <> "" THEN strlen% = LEN(td$) FOR dummy = 1 TO strlen% IF INSTR(checkstring$,MID$(td$,dummy,1)) = 0 THEN LOCATE down%,across% : PRINT SPACE$(strlen%) GOTO StartOfLoop END IF NEXT END IF END SUB SUB DrawColorWindow(title$) STATIC SHARED textpen% ' Set up window for color bars WINDOW 3, title$, (0,0)-(311,75), 18, 2 COLOR textpen%,0 LINE (50,8)-(270,16),,b LINE (50,24)-(270,32),,b LINE (50,40)-(270,48),,b PRINT PRINT " RED" PRINT PRINT "GREEN" PRINT PRINT " BLUE" LINE (250,54)-(300,66),,b LOCATE 8,33 : PRINT "RESET"; LINE (198,54)-(232,66),,b LOCATE 8,27 : PRINT "OK"; END SUB SUB SetColorBars(colorreg1%,red1,green1,blue1,colorreg2%,red2,green2,blue2) STATIC SHARED numcolors% ' Change color mix for specified register totalbar = 220 ' Draw color boxes IF colorreg2% >= 0 THEN LINE (32,54)-(44,66),colorreg1%,bf LOCATE 8,1 : PRINT "FAR"; LINE (48,54)-(60,66),colorreg2%,bf LOCATE 8,9 : PRINT "NEAR"; END IF SetInitialBars: colorreg% = colorreg1% redbar1 = red1 greenbar1 = green1 bluebar1 = blue1 PALETTE colorreg1%, red1, green1, blue1 IF colorreg2% >= 0 THEN LINE (46,52)-(62,68),0,b LINE (30,52)-(46,68),,b redbar2 = red2 greenbar2 = green2 bluebar2 = blue2 PALETTE colorreg2%, red2, green2, blue2 END IF GOSUB ClearBars ' Set color ratios in bars LINE (51,9)-(redbar1 * totalbar + 50,15),,bf LINE (51,25)-(greenbar1 * totalbar + 50,31),,bf LINE (51,41)-(bluebar1 * totalbar + 50,47),,bf dummy = MOUSE(0) ' clear mouse settings SetUserBars: WHILE MOUSE(0) = 0 OR MOUSE(0) = -1 : WEND xclick& = MOUSE(5) yclick& = MOUSE(6) IF WINDOW(0) = 3 THEN IF yclick& >= 8 AND yclick& <= 48 THEN IF xclick& > 50 AND xclick& < 270 THEN IF yclick& >= 8 AND yclick& <= 16 THEN LINE (51,9)-(269,15),0,bf ' clear bar LINE (51,9)-(xclick&,15),,bf ' draw bar IF colorreg% = colorreg1% THEN redbar1 = (xclick& - 50)/totalbar PALETTE colorreg1%, redbar1, greenbar1, bluebar1 IF colorreg2% >= 0 THEN GOSUB SetColorSpread ELSE redbar2 = (xclick& - 50)/totalbar GOSUB SetColorSpread END IF ELSEIF yclick& >= 24 AND yclick& <= 32 THEN LINE (51,25)-(269,31),0,bf ' clear bar LINE (51,25)-(xclick&,31),,bf ' draw bar IF colorreg% = colorreg1% THEN greenbar1 = (xclick& - 50)/totalbar PALETTE colorreg1%, redbar1, greenbar1, bluebar1 IF colorreg2% >= 0 THEN GOSUB SetColorSpread ELSE greenbar2 = (xclick& - 50)/totalbar GOSUB SetColorSpread END IF ELSEIF yclick& >= 40 AND yclick& <= 48 THEN LINE (51,41)-(269,47),0,bf ' clear bar LINE (51,41)-(xclick&,47),,bf ' draw bar IF colorreg% = colorreg1% THEN bluebar1 = (xclick& - 50)/totalbar PALETTE colorreg1%, redbar1, greenbar1, bluebar1 IF colorreg2% >= 0 THEN GOSUB SetColorSpread ELSE bluebar2 = (xclick& - 50)/totalbar GOSUB SetColorSpread END IF ELSE END IF END IF END IF IF yclick& >= 54 AND yclick& <=66 THEN IF xclick& >= 250 AND xclick& <= 300 THEN GOTO SetInitialBars ' reset color ELSEIF xclick& >= 198 AND xclick& <= 232 THEN ' Lock in color and return red1 = redbar1 red2 = redbar2 green1 = greenbar1 green2 = greenbar2 blue1 = bluebar1 blue2 = bluebar2 WINDOW CLOSE 3 EXIT SUB ELSEIF xclick& >= 32 AND xclick& <= 44 AND colorreg% = colorreg2% THEN colorreg% = colorreg1% LINE (46,52)-(62,68),0,b LINE (30,52)-(46,68),,b GOSUB ClearBars LINE (51,9)-(redbar1 * totalbar + 50, 15),,bf LINE (51,25)-(greenbar1 * totalbar + 50, 31),,bf LINE (51,41)-(bluebar1 * totalbar + 50, 47),,bf ELSEIF xclick& >= 48 AND xclick& <= 60 AND colorreg% = colorreg1% THEN IF colorreg2% >= 0 THEN colorreg% = colorreg2% LINE (30,52)-(46,68),0,b LINE (46,52)-(62,68),,b GOSUB ClearBars LINE (51,9)-(redbar2 * totalbar + 50, 15),,bf LINE (51,25)-(greenbar2 * totalbar + 50, 31),,bf LINE (51,41)-(bluebar2 * totalbar + 50, 47),,bf END IF ELSE END IF END IF END IF GOTO SetUserBars SetColorSpread: FOR num% = colorreg1% TO colorreg2% fractionred = redbar1 + (num% - colorreg1%) * (redbar2 - redbar1) / numcolors% fractiongreen = greenbar1 + (num% - colorreg1%) * (greenbar2 - greenbar1) / numcolors% fractionblue = bluebar1 + (num% - colorreg1%) * (bluebar2 - bluebar1) / numcolors% PALETTE num%,fractionred,fractiongreen,fractionblue NEXT num% RETURN ClearBars: LINE (51,9)-(269,15),0,bf LINE (51,25)-(269,31),0,bf LINE (51,41)-(269,47),0,bf RETURN END SUB