Category : Science and Education
Archive   : AGR103.ZIP
Filename : AGR103.BAS

 
Output of file : AGR103.BAS contained in archive : AGR103.ZIP


defdbl p-z
dim mem#(6,3)
dim const#(6,50)
dim sa%(100)
dim fstep%(6,100)
dim picture%(32000)
dim picture2%(32000)
dim ymax(240)
DIM YMIN(240)
dim xtest(240)
DIM HEIGHT(2,100)
dim wid(2,100)
dim ptcode(2,100)

' function evaluation routine (fnf#)
1 def fnf#(formula$)
2 local i,j,kz, mem#()
3 shared fu,r,t,u,v,x,y,z,ts,const#(),fstep%()
4 kz = 1
5 bb$ = "n"
8 for j = 1 to 100
10 if fstep%(fu,j) = 0 then goto 75
11 if fstep%(fu,j) = 28 then swap regi#(1), regi#(2):goto 70
12 if fstep%(fu,j) = 27 then regi#(1) = - regi#(1):goto 70
13 if fstep%(fu,j) = 9 then regi#(1) = abs(regi#(1)):goto 70
14 if fstep%(fu,j) = 10 then regi#(1) = sgn(regi#(1)):goto 70
15 if fstep%(fu,j) = 4 then regi#(1) = atn(regi#(1)):goto 70
16 if fstep%(fu,j) = 6 then
17 if regi#(1) < 0 then goto 80 else regi#(1) = sqr(regi#(1)):goto 70
18 end if
19 if fstep%(fu,j) = 5 then regi#(1) = regi#(1)*regi#(1):goto 70
20 if fstep%(fu,j) = 7 then regi#(1) = regi#(1)*regi#(1)*regi#(1):goto 70
21 if fstep%(fu,j) = 8 then regi#(1) = regi#(1)^(1/3):goto 70
22 if fstep%(fu,j) = 1 then regi#(1) = sin(regi#(1)):goto 70
23 if fstep%(fu,j) = 2 then regi#(1) = cos(regi#(1)):goto 70
24 if fstep%(fu,j) = 12 then
25 if regi#(1) <= 0 then goto 80 else regi#(1) = log(regi#(1)):goto 70
26 end if
27 if fstep%(fu,j) = 13 then
28 if regi#(1) <= 0 then goto 80 else regi#(1) = log10(regi#(1)):goto 70
29 end if
30 if fstep%(fu,j) = 14 then regi#(1) = exp(regi#(1)):goto 70
31 if fstep%(fu,j) = 11 then regi#(1) = int(regi#(1)):goto 70
32 if fstep%(fu,j) = 3 then regi#(1) = tan(regi#(1)):goto 70
33 if fstep%(fu,j) = 16 then regi#(1) = regi#(2) + regi#(1):goto 60
34 if fstep%(fu,j) = 17 then regi#(1) = regi#(2) - regi#(1):goto 60
35 if fstep%(fu,j) = 19 then regi#(1) = regi#(2) * regi#(1):goto 60
36 if fstep%(fu,j) = 18 then
37 if regi#(1) = 0 then goto 80 else regi#(1) = regi#(2)/regi#(1):goto 60
38 end if
39 if fstep%(fu,j) = 20 then
40 if (regi#(2)<0) and (regi#(1)-int(regi#(1))<>0) then goto 80 else regi#(1) = regi#(2) ^ regi#(1):goto 60
41 end if
42 if fstep%(fu,j) = 30 then mem#(fu,1) = regi#(1):goto 70
43 if fstep%(fu,j) = 31 then mem#(fu,2) = regi#(1):goto 70
44 if fstep%(fu,j) = 32 then mem#(fu,3) = regi#(1):goto 70
if fstep%(fu,j) > 200 then
i = fstep%(fu,j) - 200
const#(fu,i) = regi#(1):goto 70
end if
45 for i = 10 to 2 step -1:regi#(i) = regi#(i-1):next i
47 if fstep%(fu,j) = 22 then regi#(1) = x:goto 70
48 if fstep%(fu,j) = 23 then regi#(1) = y:goto 70
50 if fstep%(fu,j) = 25 then regi#(1) = u:goto 70
51 if fstep%(fu,j) = 26 then regi#(1) = v:goto 70
52 if fstep%(fu,j) = 24 then regi#(1) = t:goto 70
53 if fstep%(fu,j) = 33 then regi#(1) = mem#(fu,1):goto 70
54 if fstep%(fu,j) = 34 then regi#(1) = mem#(fu,2):goto 70
55 if fstep%(fu,j) = 35 then regi#(1) = mem#(fu,3):goto 70
if (fstep%(fu,j) > 100) and (fstep%(fu,j) < 200) then
i = fstep%(fu,j) - 100
regi#(1) = const#(fu,i):goto 70
end if
56 if fstep%(fu,j)<>29 then goto 85 else regi#(1)=const#(fu,kz):kz=kz+1:goto 70
60 for i = 2 to 9:regi#(i) = regi#(i+1):next i
70 next j
75 fnf# = regi#(1):goto 85
80 fnf# = rr - 1:ts = 0
85 end def


2000 LZ$ = "%":screen 2:screen 0:color 11,1:colr = 10
cls: BB$ = "a":xyz = 0
print:print " Welcome to
color 14
print:print:print" A GRAPHING ROUTINE
color 11
print:print:print" by Clayton W. Dodge
print" Mathematics Department
print" University of Maine
print" Orono, Maine 04469
print" ver. 1.03
print:print:print
color 11
2007 print:print:print:print"Hit any key to continue... ";
2008 z$ = inkey$:if z$ = "" then 2008
dimen$ = "2"
2020 cls

'Main program - enter function
2040 COLOR 11
2041 Print:print "Enter the function in AOS notation using lower case letters only.
2042 print "Standard operations include +, -, *, /, and ^. Standard functions
2043 print "include abs, sgn, sqrt, cuberoot, sin, cos, tan, arctan, ln, log,
2044 print "exp, int, all of which precede the variable. Also we have the
2045 print "functions sqr and cube, which follow the variable. Delimiters are spaces
2048 print "or '(' or ')' or a standard operation. Enter function all on one line.
2051 print:Print:print "Enter the function in reverse Polish notation using lower case letters
2052 print "only. The stack is ten levels high. Standard operations include +, -,
2053 print "*, /, and ^. Then 'a b -' produces a - b. Standard functions include
2055 print "sgn, sqrt, cuberoot, sqr, cube, sin, cos, tan, arctan, ln, log, exp, int,
2056 print "abs, chs (to change sign), exch (to exchange registers 1 and 2), and the
2057 print "memory functions sto1, sto2, sto3, rcl1, rcl2, rcl3. The delimiter is a
2058 print "space or a standard operation. Enter function all on one line.
2059 print:print "In two dimensions the aspect ratio x to y is 1.6 to 1."
2060 print:print "Hit any key to continue..."
2061 Z$ = inkey$: if Z$ = "" then 2061

colr = 10:clr = 15
fun$="x":funa$="u":funb$="u":func$="u":funx$="t":funy$="t":funz$="t"
tt=0:uu=1:pu=0:qu=1:pv=0:qv=1:pt=0:qt=1:p=0:q=1:r=0:s=1
ln=20:lnv=20:tval=40:stp = 10
curv$ = "yes":surf$ = "yes":CZ$ = "yes":ret$="no ":quit$="no "
coord$ = "p":coor$ = "parametric "
logica$="aos":insert$="insert"
grap$="ega":new$="new":col$="new "

7000 screen 2: screen 0 : ca = 11: cb = 14:cd=1:ce=4:color 11,4
7001 in = 1
7002 cls:print " Coordinate system is 2-dimensional ";coor$
print
if coord$ = "p" then
print "Curve x = f(t) = ";funx$
print " function: y = g(t) = ";funy$
print
end if
if coord$ = "o" then
print "Curve
print " function: r = f(t) = ";funx$
print "Theta (t) is measured in radians.
end if
if coord$ = "r" then
print "Curve
print " function: y = f(x) = ";fun$
print
end if
print
print
if coord$ = "r" or coord$ = "p" then
print "Limits: min x = ";p
print " min y = ";r
end if
if coord$ = "p" then
print " min t = ";pt
print "How many t-values? ";tval
print
print
end if
if coord$ = "r" then
print "There are 640 pixels across
print " the screen in EGA mode.
print "Plot every nth pixel for n = ";stp
print
end if
if coord$ = "o" then
print
print "Limits: maximum radius = ";s
print "There are 2880 pixels allotted.
print "Plot every nth pixel for n = ";stp
print "limits are measured in revolutions:
print "Start: t = ";pt
print "Plot coordinate circles? ";CZ$
end if
print
locate 21,1
print "Draw new or over old graph? ";new$
print " Use the same or a new color? ";col$
print "Return to opening menu? ";ret$
locate 23,45
print "quit? ";quit$
locate 5,65
print logica$;" logic
locate 6,65
print insert$;" mode
locate 10,55
print "Use up and down cursor
locate 11,55
print "keys to move between en-
locate 12,55
print "tries. Typing then pro-
locate 13,55
print "duces new entry. Use
locate 14,55
print "left and right keys to
locate 15,55
print "edit characters. Then
locate 16,55
print "typing overwrites or
locate 17,55
print "inserts (^V toggles).
locate 18,55
print "^G deletes character.
locate 19,55
print "^T deletes to end of line.
locate 20,55
print " toggles choices.
locate 21,55
print " when done.
locate 7,65
print grap$;" mode"
if coord$ = "p" or coord$ = "r" then
locate 8,30:print "max x = ";q
locate 9,30:print "max y = ";s
end if
if coord$ = "p" then locate 10,30:print "max t = ";qt
if coord$ = "o" then locate 13,25:print "Finish: t = ";qt

jn = 1
gosub 7100
gosub 7120

7050 LZ$ = inkey$: if LZ$ = "" then 7050
7060 if LZ$ = chr$(0)+chr$(80) then 'down arrow
gosub 7110
kn = 0
in = in + 1
gosub 7100
gosub 7120
end if
if LZ$ = chr$(0)+chr$(72) then 'up arrow
gosub 7110
kn = 0
in = in - 1
gosub 7100
gosub 7120
end if
if LZ$ = chr$(22) or LZ$ = chr$(0)+chr$(82) then '^V or INS
if insert$ = "insert" then
insert$ = "overwrite"
locate 6,65
print "overwrite mode"
else
insert$ = "insert"
locate 6,65
print "insert mode "
end if
end if
if LZ$ = chr$(13) then gosub 7130
if in = 2 or in = 3 or (in > 5 and in < 12) then
if LZ$ = chr$(0)+chr$(75) then gosub 7140 'left arrow
if LZ$ = chr$(0)+chr$(77) then gosub 7140 'right arrow
end if
LZN = asc(LZ$)
if (LZN>39 and LZN<58 and LZN<>44) or (LZN=32) or (LZN=94) or (LZN>96 and LZN<123) then
kn = len(Q$)
Q$ = space$(kn)
goto 7030
end if
if LZ$ = chr$(27) then goto 7170 '
goto 7050

7100 if in = 0 then in = 16
if in = 17 then in = 1
if coord$<>"p" then
if in=3 and LZ$ = chr$(0)+chr$(80) then in=in+1
if in=3 and LZ$ = chr$(0)+chr$(72) then in=in-1
end if
if coord$ = "r" then
if in = 10 then in = 12
if in = 11 then in = 9
if in = 2 then lx = 4:ly = 23:Q$ = fun$:gosub 6190
if in = 12 then lx = 12:ly = 30:Q$ = left$(str$(stp)+" ",5)
end if
if coord$ = "o" then
if in = 8 then in = 10
if in = 9 then in = 7
if in = 2 then lx = 4:ly = 23:Q$ = funx$:gosub 6190
if in = 6 then lx = 9:ly = 26: Q$ = left$(str$(s)+" ",10)
if in = 7 then lx = 11:ly = 30:Q$ = left$(str$(stp)+" ",5)
if in = 12 then lx = 14:ly = 26: Q$ = CZ$
if in = 10 then lx = 13:ly = 12: Q$ = left$(str$(pt)+" ",10)
if in = 11 then lx = 13:ly = 37: Q$ = left$(str$(qt)+" ",10)
end if
if coord$ <> "o" then
if in = 6 then lx = 8:ly = 17:Q$ = left$(str$(p)+" ",10)
if in = 7 then lx = 8:ly = 38:Q$ = left$(str$(q)+" ",10)
if in = 8 then lx = 9:ly = 17:Q$ = left$(str$(r)+" ",10)
if in = 9 then lx = 9:ly = 38:Q$ = left$(str$(s)+" ",10)
end if
if coord$ = "p" then
if in = 10 then lx = 10:ly = 17:Q$ = left$(str$(pt)+" ",10)
if in = 11 then lx = 10:ly = 38:Q$ = left$(str$(qt)+" ",10)
if in = 12 then lx = 11:ly = 20:Q$ = left$(str$(tval)+" ",5)
if in = 2 then lx = 3:ly = 23:Q$ = funx$:gosub 6190
end if
if in = 1 then lx = 1:ly = 51:Q$ = coor$
if in = 3 then lx = 4:ly = 23:Q$ = funy$:gosub 6190
if in = 4 then lx = 5:ly = 65:Q$ = logica$
if in = 5 then lx = 7:ly = 65:Q$ = grap$
if in = 13 then lx = 21:ly = 30:Q$ = new$
if in = 14 then lx = 22:ly = 34:Q$ = col$
if in = 15 then lx = 23:ly = 26:Q$ = ret$
if in = 16 then lx = 23:ly = 52:Q$ = quit$
if (in > 5 and in < 12) or (in = 12 and coord$ <> "o") then
kn = len(Q$)
for hn = 1 to kn
if mid$(Q$,hn,1)="e" or mid$(Q$,hn,1)="E" then Q$=left$(Q$,9+hn-kn)+mid$(Q$,hn)
next hn
Q$ = left$(Q$+" ",10)
end if
return

7110 locate lx,ly:color ca,ce: print Q$
return

7120 if in > 5 and in < 12 then locate lx,ly: print " "
locate lx,ly:color cb,cd: print Q$:color ca,ce
return

7130 if in = 1 then
if Q$<>"parametric " and Q$<>"rectangular" then Q$ = "polar "
if Q$="parametric " then Q$="rectangular":coord$ = "r":goto 7035
if Q$="rectangular" then Q$="polar ":coord$ = "o":goto 7035
if Q$="polar " then Q$="parametric ":coord$="p":coor$=Q$:dimen$="3":goto 6001
7035 coor$ = q$:goto 7001
end if
if in = 15 or in = 16 or (in = 12 and coord$ = "o") then
if Q$ = "yes" then q$ = "no " else q$ = "yes"
if in = 15 then ret$ = q$
if in = 16 then quit$ = q$
if in = 12 then cz$ = Q$
locate lx, ly
color cb,cd
print q$
color ca,ce
end if
if in = 4 then
if q$ = "aos" then q$ = "rpn" else q$ = "aos"
logica$ = Q$
locate lx,ly
color cb,cd
print Q$
color ca,ce
end if
if in = 5 then
if Q$ = "ega" then Q$ = "cga lo": goto 7040
if Q$ = "cga lo" then Q$ = "cga hi":goto 7040
if Q$ = "cga hi" then Q$ = "ega":colr=10:clr=15
7040 grap$ = q$
locate lx,ly
color cb,cd
print Q$;
color ca,ce:print " mode "
end if
if in = 13 then
if Q$ = "new" then Q$ = "old" else q$ = "new"
new$ = q$
locate lx,ly
color cb,cd
print Q$
color ca,ce
end if
if in = 14 then
if Q$ = "same" then Q$ = "new " else q$ = "same"
col$ = q$
locate lx,ly
color cb,cd
print Q$
color ca,ce
end if
return

7140 'editing routine
kn = len(Q$)
7010 gosub 6150
7020 LZ$ = inkey$: if LZ$ = "" then 7020
if LZ$ = chr$(22) or LZ$ = chr$(0)+chr$(82) then '^V or INS
if insert$ = "insert" then
insert$ = "overwrite"
locate 6,65
print "overwrite mode"
else
insert$ = "insert"
locate 6,65
print "insert mode "
end if
end if

if LZ$ = chr$(0)+chr$(75) then jn = jn - 1:goto 7010 'left arrow
if LZ$ = chr$(0)+chr$(77) then jn = jn + 1:goto 7010 'right arrow
if LZ$=chr$(27) or LZ$=chr$(0)+chr$(72) or LZ$=Chr$(0)+chr$(80) then goto 7160
LZN = asc(LZ$)
if (LZN>39 and LZN<58 and LZN<>44) or (LZN=32) or (LZN=94) or (LZN>96 and LZN<123) then
if in > 10 and in < 23 then kn = 10
if in = 23 or in = 24 then kn = 3
if in = 25 then kn = 5
7030 if insert$="insert" then Q$ = left$(Q$,jn-1)+LZ$+mid$(Q$,jn,kn-jn)
if insert$="overwrite" then Q$ = left$(Q$,jn-1)+LZ$+mid$(Q$,jn+1)
jn = jn + 1
end if
if LZ$ = chr$(7) or LZ$ = chr$(0)+chr$(83) then '^G or DEL
Q$ = left$(Q$,jn-1)+mid$(Q$,jn+1)+" "
end if
if LZ$ = chr$(20) then '^T
Q$ = left$(Q$,jn-1)+space$(kn-jn)
end if
if LZ$ = chr$(8) and jn > 1 then '
Q$ = left$(Q$,jn-2)+mid$(Q$,jn)+" "
jn = jn - 1
end if
goto 7010

7160 'exit edit routine
gosub 7110
if in > 0 and in < 8 and in <> 4 then gosub 6180
if in = 1 then coor$ = Q$
if in = 3 then funy$ = Q$
if coor$ <> "polar " then
if in = 6 then p = val(Q$)
if in = 7 then q = val(Q$)
if in = 8 then r = val(Q$)
if in = 9 then s = val(Q$)
end if
if coor$ <> "rectangular" then
if in = 2 then funx$ = Q$
if in = 10 then pt = val(Q$)
if in = 11 then qt = val(Q$)
end if
if coor$ = "rectangular" then
if in = 2 then fun$ = Q$
if in = 12 then stp = val(Q$)
end if
if coor$ = "polar " then
if in = 6 then s = val(Q$)
if in = 7 then stp = val(Q$)
if in = 12 then CZ$ = Q$
end if
if coor$ = "parametric " and in = 12 then tval = val(Q$)
jn = 1
goto 7060



7170 'graph the function
LZ$ = "%":in = 1
if quit$ = "yes" then screen 0: cls: end
if ret$ = "yes" then ret$ = "no ": goto 2000
if logica$ = "aos" then logic$ = "a" else logic$ = "r"
if coord$ = "o" then
if s <= 0 then in = 6:goto 7002
if stp <= 0 then in = 7:goto 7002
if stp > 2880 then in = 7:goto 7002
if pt = qt then in = 10:goto 7002
end if
if coord$ <> "o" then
if p = q then in = 6:goto 7002
if r = s then in = 8:goto 7002
end if
if coord$ = "p" then
if pt = qt then in = 10:goto 7002
if tval <= 0 then in = 12:goto 7002
if tval > 1000 then tval = 1000
end if
if coord$ = "r" and (stp <= 0 or stp > 320) then in = 12:goto 7002
if grap$ = "cga lo" then graphics$ = "l":screen 1
if grap$ = "cga hi" then graphics$ = "h":screen 2
if grap$ = "ega" then graphics$ = "e":screen 9
if col$ = "new " then clr = 29 - clr else colr = colr - 1
if new$ = "new" then BB$ = "n" else BB$ = "y"
cls
gosub 2002
if coord$ = "p" then goto 2100
if coord$ = "o" then goto 2150
if coord$ = "r" then goto 2090

2090 'parse function 2-dim rectangular
2092 xyz = 1
2093 print "Wait while I think..........."
formula$ = fun$ + " "
2094 fu = 1: gosub 9000 'Function parsing routine
2096 goto 2180

2100 'parse function 2-dim parametric
2130 CLS
2132 print "Wait while I think..........."
2134 formula$ = funx$ + " "
2136 fu = 1: gosub 9000
2138 formula$ = funy$ + " "
2140 fu = 2: gosub 9000
2142 goto 2180

2150 'parse function in polar form (2-dimensional)
2160 print "Wait while I think..........."
2167 xyz=1
2168 formula$ = funx$ + " "
2170 fu = 1: gosub 9000

2180 ' draw coordinate system (2-dimensions)
2181 if graphics$ = "e" then color ,0
2182 if coord$ = "o" then goto 2250

2190 ' draw rectangular 2-dimensional screen
if graphics$ = "h" then screen 2
if graphics$ = "l" then screen 1
2192 if graphics$ = "e" then color 8
2194 cls
2196 if BB$ = "y" then put(0,0),picture%:put(0,160),picture2%:goto 2236
2200 LINE (0,(7*ym-43)/15)-(xm,(7*ym-43)/15),ccc
2202 LINE (0,(7*ym-43)*2/15)-(xm,(7*ym-43)*2/15),ccc
2204 LINE (0,0)-(xm,0),ccc
2206 LINE ((xm+1)/2,0)-((xm+1)/2,(7*ym-43)*2/15),ccc
2208 LINE (0,0)-(0,(7*ym-43)*2/15),ccc
2210 LINE (xm,0)-(xm,(7*ym-43)*2/15),ccc
2212 for n=0 to 20: line (0,(7*ym-43)*n/150)-(3,(7*ym-43)*n/150),ccc: next n
2214 for n=0 to 20: line ((xm+1)*n/20,0)-((xm+1)*n/20,3),ccc: next n
2216 for n=0 to 20: line ((xm-3)/2,(7*ym-43)*n/150)-((xm+5)/2,(7*ym-43)*n/150),ccc: next n
2218 for n=0 to 20: line ((xm+1)*n/20,(7*ym-73)/15)-((xm+1)*n/20,(7*ym-13)/15),ccc: next n
2220 for n=0 to 20: line (xm-3,(7*ym-43)*n/150)-(xm,(7*ym-43)*n/150),ccc: next n
2222 for n=0 to 20: line ((xm+1)*n/20,(7*ym-73)*2/15)-((xm+1)*n/20,(7*ym-43)*2/15),ccc: next n
2224 Locate 2,40/lm-1,0:print"Y"
2226 Locate 11,80/lm-2,0:print"X"
2228 Locate 13,2,0:print using "###.####"; P
2230 Locate 13,80/lm-10,0:print using "###.####"; q
2232 Locate 2,40/lm+2,0: print using "###.####"; S
2234 Locate 22,40/lm+2,0: print using "###.####"; r
2236 ' end of 2-dim. rectangular screen drawing program
2238 goto 2300

2250 'draw polar screen
if graphics$ = "h" then screen 2
if graphics$ = "l" then screen 1
2251 cls: if BB$ = "y" then put(0,0),picture%:put(0,160),picture2%:goto 2300
2254 if graphics$ = "e" then color 8,0
2262 LINE (0,(7*ym-43)/15)-(xm,(7*ym-43)/15),ccc
2264 LINE (0,(7*ym-43)*2/15)-(xm,(7*ym-43)*2/15),ccc
2266 LINE (0,0)-(xm,0),ccc
2268 LINE ((xm+1)/2,0)-((xm+1)/2,(7*ym-43)*2/15),ccc
2270 LINE (0,0)-(0,(7*ym-43)*2/15),ccc
2272 LINE (xm,0)-(xm,(7*ym-43)*2/15),ccc
2274 if cZ$ = "no " then goto 2286
2276 for nz=1 to 10:circle ((xm+1)/2,(7*ym-43)/15),(ym+1)/18.23*nz*rad,ccc,,,asp:next nz
2278 for nz=1 to 5
2280 line((xm+1)/2+192*cos(.2618*nz)/al,(7*ym-43)/15+(7*ym-73)/15*sin(.2618*nz))-((xm+1)/2-192*cos(.2618*nz)/al,(7*ym-43)/15-(7*ym-73)/15*sin(.2618*nz)),ccc
2282 line((xm+1)/2-192*cos(.2618*nz)/al,(7*ym-43)/15+(7*ym-73)/15*sin(.2618*nz))-((xm+1)/2+192*cos(.2618*nz)/al,(7*ym-43)/15-(7*ym-73)/15*sin(.2618*nz)),ccc
2284 next nz
2286 Locate 2,40/lm-1,0:print"Y"
2288 Locate 10,80/lm-2,0:print"X"
2290 Locate 12,66/lm,0:print using "###.####"; s

2300 'sketch 2-dimensional function
2302 if coord$ = "r" then goto 2350
2304 if coord$ = "o" then goto 2400

2308 ' graph 2-dimensional parametric graph
2310 colr = colr + 1:if colr = 16 then colr = 10
2311 if graphics$ = "h" then colr = 1
if graphics$ = "l" and colr > 2 then colr = 1
2312 FOR t = PT to QT step (QT-PT)/tval
2313 ts = 1:rr=r
2314 fu = 1: X = FNF#(formula$)
2316 fu = 2: Y = FNF#(formula$)
2318 IF P < Q AND (X < P OR X > Q) THEN ts = 0
2320 IF P > Q AND (X > P OR X < Q) THEN ts = 0
2322 IF R > S AND (Y > R OR Y < S) THEN ts = 0
2324 IF R < S AND (Y < R OR Y > S) THEN ts = 0
2326 A = (x - p)*xm/(q - p)
2328 B = (7*ym-43)*2/15 - (y - r)*((7*ym-43)*2/15-1)/(s - r)
2330 if (t > PT) and (ts = 1) then line (a,b)-(ua,ya),colr
2332 ua = a:ya = b
2334 NEXT t
2336 get (0,0)-(xm,159),picture%
2338 get (0,160)-(xm,(7*ym-43)*2/15),picture2%
2340 locate 23,1
2342 if graphics$ = "e" then color 15
2344 print "x = ";funx$;"; y = ";funy$
2345 Z$ = inkey$: if z$ = "" then 2345
2346 goto 2450

2350' plot function 2-dimensional rectangular
2352 fu = 1:ua = 10:ya = (7*ym-43)*2/15
2354 colr = colr + 1:if colr = 16 then colr = 10
2355 if graphics$ = "h" then colr = 1
if graphics$ = "l" and colr > 2 then colr = 1
2356 FOR U=0 TO 640/al step stp
2358 x=P+(Q-P)*U/640*al
2359 rr = r
2360 V=FNF#(formula$)
2362 Y=(7*ym-43)*2/15-(v-R)*(7*ym-43)*2/15/(S-R)
2363 if y < 0 or y > (7*ym-43)*2/15 then ts = 0
2364 if (u > 1) and (ts = 1) then line (u,y)-(ua,ya),colr
2366 IF Y>=0 AND Y<=(7*ym-43)*2/15 THEN PSET (U,Y),colr:ts=1 else ts=0:goto 2370
2368 ua = u:ya = y
2370 NEXT U
2372 locate 23,1
2374 if graphics$ = "e" then color 15
2378 get (0,0)-(xm,159),picture% 'Save the current graph (top half)
2380 get (0,160)-(xm,ym), picture2% 'Save the current graph (bottom half)
2381 print "f(x) = "formula$
2382 Z$ = inkey$: if z$ = "" then 2382
2384 goto 2450

2400 'polar sketching
2402 colr = colr + 1:if colr = 16 then colr = 10
2403 if graphics$ = "h" then colr = 1
if graphics$ = "l" and colr > 2 then colr = 1
2404 FOR U=0 TO 2880 step stp
2406 t = (QT - PT)*u/456 + PT*6.283185
2407 rr = s + 2
2408 V=FNF#(formula$)
2409 if v > s then ts = 0
2410 x = (xm+1)/2 + 193*v*cos(t)/s/al
2412 Y = (7*ym-43)/15 - (7*ym-73)/15*v*sin(t)/s
2413 IF Y>=0 AND Y<=(7*ym-43)*2/15 and X>=0 and X<=xm then h = 1 else ts=0
2414 if (u > 1) and (ts = 1) then line (x,y)-(ua,ya),colr
2416 IF Y>=0 AND Y<=(7*ym-43)*2/15 and X>=0 and X<=xm and v<=s THEN ts=1 else ts=0:goto 2420
2418 ua = x:ya = y
2420 NEXT U
2422 locate 23,1
2424 if graphics$ = "e" then color 15
2426 get (0,0)-(xm,159),picture%
2428 if graphics$ = "e" then get (0,160)-(xm,320), picture2%
2429 if graphics$ = "h" then get (0,160)-(xm,199), picture2%
if graphics$ = "l" then get (0,160)-(xm,199), picture2%
2430 print "f(x) = "formula$
2432 Zz$ = inkey$: if Zz$ = "" then goto 2432

2450 ' repeat request routine
screen 2: screen 0
2452 goto 7000



'3-dimensional rectangular plot
3290 print "Wait while I think..........."
3291 if surf$ = "no " then 3298
3292 formula$ = fun$ + " "
3294 fu = 1
3296 gosub 9000
3298 if curv$ = "no" then 3317
3300 formula$ = funx$ + " "
3302 fu = 2
3304 gosub 9000
3306 formula$ = funy$ + " "
3308 fu = 3
3310 gosub 9000
3312 formula$ = funz$ + " "
3314 fu = 4
3316 gosub 9000
3317 CLS:if graphics$ = "e" then color ,0
if graphics$ = "h" then screen 2
if graphics$ = "l" then screen 1
3318 if BB$ = "y" then cls:put(0,0),picture%:put(0,175),picture2%:goto 3480
3320 LINE (0,(ym-1)/3)-((xm+1)/4,0),ccc
3322 LINE ((xm+1)/4,0)-(3*(xm+1)/4,0),ccc
3324 LINE (3*(xm+1)/4,0)-(3*(xm+1)/4,(ym-1)*2/3),ccc
3330 LINE (3*(xm+1)/4,(ym-1)*2/3)-((xm+1)/2,ym-1),ccc
3340 LINE ((xm+1)/2,ym-1)-((xm+1)/2,(ym-1)/3),ccc
3350 LINE ((xm+1)/2,(ym-1)/3)-(3*(xm+1)/4,0),ccc
3360 LINE ((xm+1)/2,(ym-1)/3)-(0,(ym-1)/3),ccc
3370 LINE ((xm+1)/2,ym-1)-(0,ym-1),ccc
3380 LINE (0,ym-1)-(0,(ym-1)/3),ccc
3390 LINE ((xm+1)/4,(ym-1)*2/3)-((xm+1)/4,0),ccc
3400 LINE ((xm+1)/4,(ym-1)*2/3)-(3*(xm+1)/4,(ym-1)*2/3),ccc
3410 LINE ((xm+1)/4,(ym-1)*2/3)-(0,ym-1),ccc
3420 LOCATE 2,22/lm:PRINT"Z =";uu
3430 LOCATE 14,22/lm:PRINT"Z =";TT
3440 LOCATE 15,22/lm:PRINT"Y =";R
3450 LOCATE 15,54/lm:PRINT"Y =";S
3460 LOCATE 17,20/lm:PRINT"X =";P
3470 LOCATE 22,6/lm:PRINT"X =";Q

3480 if surf$ = "no " then goto 3755
3490 for k = 0 to 240:xtest(k) = 0:next k
3495 fu = 1
3496 clr1 = 10:clr2 = 11
3497 if graphics$ = "h" then clr1 = 1:clr2 = 1
3498 if graphics$ = "l" then clr1 = 2:clr2 = 1
3500 FOR K = 0 TO ln
3505 KK=K MOD 2
3510 X = Q + K*(P - Q)/ln
3520 FOR L=0 TO ln
3530 Y = S + L*(R - S)/ln
3535 rr=r
3540 Z = FNf#(formula$)
3545 wid(kk,L) = 1
3550 IF (Zuu or ts = 0) then wid(kk,L)=0
3560 XCODE = ln - K + 2*L
3570 A = (xm+1)/2 - L*(xm+1)/2/ln + K*(xm+1)/4/ln
3580 B = ym-1 - K*(ym-1)/3/ln - (Z - TT)*(ym-1)*2/3/(uu - TT)
3600 HEIGHT(KK,L) = B
3620 if xtest(xcode) = 0 and ts =1 then
3625 YMAX(XCODE) = B: YMIN(XCODE) = B
3630 IF xcode>2 and xtest(xcode-2)=1 and xtest(xcode-1)=0 THEN_
YMAX(XCODE-1)=(B+YMAX(XCODE-2))/2:YMIN(XCODE-1)=YMAX(XCODE-1):_
xtest(xcode-1)=1
3131 xtest(xcode) = 1
end if
3640 IF B >= YMAX(XCODE) THEN YMAX(XCODE) = B: ptcode(kk,L) = 1:CLR=clr1
3650 IF B <= YMIN(XCODE) THEN YMIN(XCODE) = B: ptcode(kk,L) =-1:CLR=clr2
3660 IF B > YMIN(XCODE) AND B < YMAX(XCODE) THEN ptcode(kk,L) = 0
3670 IF L = 0 THEN 3705
3680 D = (B + HEIGHT(KK,L-1))/2
3690 IF YMAX(XCODE-1) < D THEN YMAX(XCODE-1) = D
3700 IF YMIN(XCODE-1) > D THEN YMIN(XCODE-1) = D
3705 if ts <> 0 and ptcode(kk,L) <> 0 and wid(kk,L) = 1 then
3710 IF L>0 AND ptcode(kk,l-1)<>0 and wid(kk,L-1) = 1_
THEN LINE(A,B)-(A+(xm+1)/2/ln,HEIGHT(KK,L-1)),CLR
3713 IF L>0 AND ptcode(kk,L)<0 and ptcode(kk,l-1)=0 and wid(kk,L-1) = 1_
THEN LINE(A,B)-(A+(xm+1)/4/ln,(B+height(kk,l-1))/2),clr
3716 IF L>0 AND ptcode(kk,L)>0 and ptcode(kk,l-1)=0 and wid(kk,L-1)=1_
THEN LINE(A,B)-(A+(xm+1)/4/ln,(B+height(kk,l-1))/2),clr
3730 IF K>0 AND ptcode(kk,L)<0 and ptcode(1-kk,l)=0 and wid(1-kk,L)=1_
THEN LINE(A,B)-(A-(xm+1)/8/ln,(B+height(1-kk,l))/2),clr
3732 IF K>0 AND ptcode(kk,L)>0 and ptcode(1-kk,l)=0 and wid(1-kk,L)=1_
THEN LINE(A,B)-(A-(xm+1)/8/ln,(B+height(1-kk,l))/2),clr
3735 IF K>0 AND ptcode(1-kk,l)<>0 and wid(1-kk,L)=1_
THEN LINE(A,B)-(A-(xm+1)/4/ln,HEIGHT(1-KK,L)),CLr
3737 end if
if wid(kk,L)=1 and L>0 and ptcode(kk,L)=0 then
if ptcode(kk,L-1)=1 and wid(kk,L-1)=1 then_
line(A+(xm+1)/4/ln,(B+Height(kk,L-1))/2)-(A+(xm+1)/2/ln,Height(kk,L-1)),clr
if wid(1-kk,L)=1 and ptcode(1-kk,L)=1 then_
line(A-(xm+1)/4/ln,height(1-kk,L))-(A-(xm+1)/8/ln,(B+height(1-kk,L))/2),clr
end if
3738 ts = 1
3740 NEXT L
3750 NEXT K

3755 if curv$ = "no " then goto 3871
if graphics$ = "l" then clr3 = 3 else clr3 = 15
3770 C = (xm+1)/4:D = (ym-1)*2/3
3780 FOR K = 0 TO TVAL
3785 T = PT + K*(QT - PT)/TVAL
3787 rr=r
3790 fu = 2: x = fnf#(formula$)
3800 fu = 3: y = fnf#(formula$)
3810 fu = 4: z = fnf#(formula$)
3820 L = ln*Y/(S - R)
3830 A = (xm+1)/4 + (xm+1)/2*(Y - R)/(S - R) - (xm+1)/4*(X - P)/(Q - P)
3840 B = (ym-1)*2/3 + (ym-1)/3*(X - P)/(Q - P) - (Z - TT)*(ym-1)*2/3/(uu - TT)
3842 IF K = 0 THEN 3860
3844 IF (X < P) OR (Y < R) OR (Z < TT) THEN 3860
3846 IF (X > Q) OR (Y > S) OR (Z > uu) THEN 3860
3850 LINE (A,B)-(C,D),clr3
3860 C = A:D = B
3870 NEXT K

3871 'redraw axes that show
3872 LINE (0,(ym-1)/3)-((xm+1)/4,0),ccc
3873 LINE ((xm+1)/4,0)-(3*(xm+1)/4,0),ccc
3874 LINE (3*(xm+1)/4,0)-(3*(xm+1)/4,(ym-1)*2/3),ccc
3875 LINE (3*(xm+1)/4,(ym-1)*2/3)-((xm+1)/2,ym-1),ccc
3876 LINE ((xm+1)/2,ym-1)-((xm+1)/2,(ym-1)/3),ccc
3877 LINE ((xm+1)/2,(ym-1)/3)-(3*(xm+1)/4,0),ccc
3878 LINE ((xm+1)/2,(ym-1)/3)-(0,(ym-1)/3),ccc
3879 LINE ((xm+1)/2,ym-1)-(0,ym-1),ccc
3880 LINE (0,ym-1)-(0,(ym-1)/3),ccc

3885 if graphics$ = "e" then COLOR 8
3893 get (0,0)-(3*(xm+1)/4,174), picture%
3896 get (0,175)-(3*(xm+1)/4,ym), picture2%
3897 Zz$=INKEY$:IF Zz$="" THEN 3897
3898 if surf$ = "no " then goto 3903
3899 locate 23,1
3900 print "z = ";fun$
3903 if curv$ = "no " then goto 3909
3904 locate 24,1
3905 print "x = ";funx$;"; y = ";funy$;"; z = ";funz$;
3909 Zz$=INKEY$:IF Zz$="" THEN 3909
if graphics$ <> "e" then screen 2: screen 0
goto 6000

'3-dimensional graph in parametric form
4291 print "Wait while I think..........."
if graphics$ = "h" then colr = 1:clr = 1
if graphics$ = "l" then colr = 1: clr = 1
if graphics$ = "e" and colr < 10 then colr = 10:clr = 15
colr = colr + 1:if colr = 14 then colr = 10
if graphics$ = "h" then colr = 1
if graphics$ = "l" and colr > 2 then colr = 1
if graphics$ = "l" and clr > 2 then clr = 1
4292 if surf$ = "no " then 4299
4293 formula$ = funa$ + " "
4294 fu = 1: gosub 9000
4295 formula$ = funb$ + " "
4296 fu = 2: gosub 9000
4297 formula$ = func$ + " "
4298 fu = 3: gosub 9000
4299 if curv$ = "no " then 4306
4300 formula$ = funx$ + " "
4301 fu = 4: gosub 9000
4302 formula$ = funy$ + " "
4303 fu = 5: gosub 9000
4304 formula$ = funz$ + " "
4305 fu = 6: gosub 9000

4306 cls
if graphics$ = "e" then color ,0
if graphics$ = "h" then screen 2
if graphics$ = "l" then screen 1
4307 if BB$ = "y" then cls:put(0,0),picture%:put(0,175),picture2%:goto 4480
4320 LINE (0,(ym-1)/3)-((xm+1)/4,0),ccc
4322 LINE ((xm+1)/4,0)-(3*(xm+1)/4,0),ccc
4324 LINE (3*(xm+1)/4,0)-(3*(xm+1)/4,(ym-1)*2/3),ccc
4330 LINE (3*(xm+1)/4,(ym-1)*2/3)-((xm+1)/2,ym-1),ccc
4340 LINE ((xm+1)/2,ym-1)-((xm+1)/2,(ym-1)/3),ccc
4350 LINE ((xm+1)/2,(ym-1)/3)-(3*(xm+1)/4,0),ccc
4360 LINE ((xm+1)/2,(ym-1)/3)-(0,(ym-1)/3),ccc
4370 LINE ((xm+1)/2,ym-1)-(0,ym-1),ccc
4380 LINE (0,ym-1)-(0,(ym-1)/3),ccc
4390 LINE ((xm+1)/4,(ym-1)*2/3)-((xm+1)/4,0),ccc
4400 LINE ((xm+1)/4,(ym-1)*2/3)-(3*(xm+1)/4,(ym-1)*2/3),ccc
4410 LINE ((xm+1)/4,(ym-1)*2/3)-(0,ym-1),ccc
4420 LOCATE 2,22/lm:PRINT"Z =";UU
4430 LOCATE 14,22/lm:PRINT"Z =";TT
4440 LOCATE 15,22/lm:PRINT"Y =";R
4450 LOCATE 15,54/lm:PRINT"Y =";S
4460 LOCATE 17,20/lm:PRINT"X =";P
4470 LOCATE 22,6/lm:PRINT"X =";Q

4480 if surf$ = "no " then goto 4770
4500 FOR kr = 0 TO LN
4505 kkr = kr mod 2
4510 U = PU + kr*(QU - PU)/LN
4520 FOR lr = 0 TO LNV
4530 V = PV + lr*(QV - PV)/LNV
4532 rr=r
4535 fu = 1: X = FNF#(formula$)
4540 fu = 2: Y = FNF#(formula$)
4545 fu = 3: Z = FNF#(formula$)
4547 ptcode(kkr,Lr) = 1
4550 IF P < Q AND (X < P OR X > Q) THEN ptcode(kkr,Lr) = 0: goto 4740
4551 IF P > Q AND (X > P OR X < Q) THEN ptcode(kkr,Lr) = 0: goto 4740
4552 IF R > S AND (Y > R OR Y < S) THEN ptcode(kkr,Lr) = 0: goto 4740
4553 IF R < S AND (Y < R OR Y > S) THEN ptcode(kkr,Lr) = 0: goto 4740
4554 IF TT < UU AND (Z < TT OR Z > UU) THEN ptcode(kkr,Lr) = 0: goto 4740
4555 IF TT > UU AND (Z > TT OR Z < UU) THEN ptcode(kkr,Lr) = 0: goto 4740
4560 'XCODE = LN - kr + 2*lr
4570 A = (xm+1)/4+(Y-R)*(xm+1)/2/(S-R)-(X-P)*(xm+1)/4/(Q-P)
4580 B = (ym-1)*2/3+(X-P)*(ym-1)/3/(Q-P)-(Z-TT)*(ym-1)*2/3/(UU-TT)
4595 WID(kkr,lr) = A
4600 HEIGHT(kkr,lr) = B
4710 if ptcode(kkr,Lr)=1 and ptcode(kkr,Lr-1)=1 and lr>0 THEN LINE(A,B)-(C,D),COLR
4730 IF ptcode(kkr,Lr)=1 and ptcode(1-kkr,Lr)=1 and kr>0_
THEN LINE(A,B)-(WID(1-kkr,lr),HEIGHT(1-kkr,lr)),COLR
4735 C = A: D = B
4740 NEXT Lr
4750 NEXT kr

4755 if curv$ = "no " then goto 4880
4770 C = (xm+1)/4:D = (ym-1)*2/3
4780 FOR K = 0 TO TVAL
4785 T = PT + K*(QT - PT)/TVAL
4790 rr=r
4800 fu = 4: X = FNF#(formula$)
4805 fu = 5: Y = FNF#(formula$)
4810 fu = 6: Z = FNF#(formula$)
4820 L = LN*Y/(S - R)
4830 A = (xm+1)/4 + (xm+1)/2*(Y - R)/(S - R) - (xm+1)/4*(X - P)/(Q - P)
4840 B = (ym-1)*2/3 + (ym-1)/3*(X - P)/(Q - P) - (Z - TT)*(ym-1)*2/3/(UU - TT)
4842 IF K = 0 THEN 4860
4844 IF (X < P) OR (Y < R) OR (Z < TT) THEN 4860
4846 IF (X > Q) OR (Y > S) OR (Z > UU) THEN 4860
4850 LINE (A,B)-(C,D),CLR
4860 C = A:D = B
4870 NEXT K

4880 'redraw axes that show
5320 LINE (0,(ym-1)/3)-((xm+1)/4,0),ccc
5322 LINE ((xm+1)/4,0)-(3*(xm+1)/4,0),ccc
5324 LINE (3*(xm+1)/4,0)-(3*(xm+1)/4,(ym-1)*2/3),ccc
5330 LINE (3*(xm+1)/4,(ym-1)*2/3)-((xm+1)/2,ym-1),ccc
5340 LINE ((xm+1)/2,ym-1)-((xm+1)/2,(ym-1)/3),ccc
5350 LINE ((xm+1)/2,(ym-1)/3)-(3*(xm+1)/4,0),ccc
5360 LINE ((xm+1)/2,(ym-1)/3)-(0,(ym-1)/3),ccc
5370 LINE ((xm+1)/2,ym-1)-(0,ym-1),ccc
5380 LINE (0,ym-1)-(0,(ym-1)/3),ccc

5880 if graphics$ = "e" then COLOR 8
5893 get (0,0)-(3*(xm+1)/4,174), picture%
5896 get (0,175)-(3*(xm+1)/4,ym), picture2%
5897 Zz$=INKEY$:IF Zz$="" THEN 5897
5898 if surf$ = "no " then goto 5903
5899 locate 23,1
5900 print "x = ";funa$;"; y = ";funb$;"; z = ";func$
5903 if curv$ = "no " then goto 5909
5904 locate 24,1
5905 print "x = ";funx$;"; y = ";funy$;"; z = ";funz$;
5909 Zz$=INKEY$:IF Zz$="" THEN 5909
if graphics$ <> "e" then screen 2: screen 0
goto 6000



'parsing routine AOS
9000 if logic$ = "r" then goto 9200 'goto 9200 if logic is RPN
'reading function
' initialize all memories
for i = 1 to 100:sa%(i) = 0: fstep%(fu,i) = 0: next i
for i = 1 to 50: const#(fu,i) = 0: next i
B$ = ""
k=1
j=1
' Read the formula and interpret the symbols
for i = 1 to len(formula$)
C$ = mid$(formula$,i,1)
if C$ = "+" then if (RIGHT$(B$,1) <> "e") or (RIGHT$(B$,2) = "be") then gosub testb:sa%(j) = 16 :j = j + 1:goto 9120
if C$ = "-" then if (RIGHT$(B$,1) <> "e") or (RIGHT$(B$,2) = "be") then gosub testb:sa%(j) = 17 :j = j + 1:goto 9120
if C$ = " " then gosub testb:goto 9120
if C$ = "(" then gosub testb: sa%(j) = 15 :j = j + 1:goto 9120
if C$ = ")" then gosub testb: sa%(j) = 21 :j = j + 1:goto 9120
if C$ = "*" then gosub testb: sa%(j) = 19 :j = j + 1:goto 9120
if C$ = "/" then gosub testb: sa%(j) = 18 :j = j + 1:goto 9120
if C$ = "^" then gosub testb: sa%(j) = 20 :j = j + 1:goto 9120
B$ = B$ + C$
goto 9120

testb:
if B$ = "" then goto 9110
if B$ = " " then B$ = "": goto 9110
if B$ = "sin" then sa%(j) = 1: goto 9105
if B$ = "cos" then sa%(j) = 2: goto 9105
if B$ = "tan" then sa%(j) = 3: goto 9105
if B$ = "arctan" then sa%(j) = 4: goto 9105
if B$ = "sqr" then sa%(j) = 5: goto 9105
if B$ = "sqrt" then sa%(j) = 6: goto 9105
if B$ = "cube" then sa%(j) = 7: goto 9105
if B$ = "cuberoot" then sa%(j) = 8: goto 9105
if B$ = "abs" then sa%(j) = 9: goto 9105
if B$ = "sgn" then sa%(j) = 10: goto 9105
if B$ = "int" then sa%(j) = 11: goto 9105
if B$ = "ln" then sa%(j) = 12: goto 9105
if B$ = "log" then sa%(j) = 13: goto 9105
if B$ = "exp" then sa%(j) = 14: goto 9105
if B$ = "x" then sa%(j) = 22: goto 9105
if B$ = "y" then sa%(j) = 23: goto 9105
if B$ = "t" then sa%(j) = 24: goto 9105
if B$ = "u" then sa%(j) = 25: goto 9105
if B$ = "v" then sa%(j) = 26: goto 9105
const#(fu,k) = val(B$): sa%(j) = 100 + k :k = k + 1
9105 j = j + 1
B$ = ""
9110 return
9120 next i

'Interpreting routine; changing to RPN
pz = 1
if sa%(2) = 0 then fstep%(fu,1) = sa%(1): goto 9199
for j = 1 to 101
if (sa%(j) = 21) or (j = 101) then 'Look for first parenthesis closed
m = j - 1
9111 if m = 0 then goto 9169
if j = 101 then m = 0: goto 9112
if sa%(m) <> 15 then m = m - 1: goto 9111 'Find first preceding (
if m = j - 1 then goto 9169
sa%(j) = 99: sa%(m) = 99
if m = j - 2 then goto 9121
9112 for n = m + 2 to j - 2
if sa%(n) = 20 then
qz = n - 1: rz = n + 1
9131 if sa%(qz) = 99 then qz = qz - 1:goto 9131 'Delete the ( and )
9141 if sa%(rz) = 99 then rz = rz + 1:goto 9141
fstep%(fu,pz) = sa%(qz):pz = pz + 1:sa%(qz) = 99
fstep%(fu,pz) = sa%(rz):pz = pz + 1:sa%(rz) = 99
fstep%(fu,pz) = 20:pz = pz + 1:sa%(n) = 100 + k ' Evaluate powers
fstep%(fu,pz) = 200 + k:pz = pz + 1:k = k + 1
end if
next n
for n = m + 2 to j - 1
if (sa%(n) = 5) or (sa%(n) = 7) then 'Evaluate square and cube
qz = n - 1
9151 if sa%(qz) = 99 then qz = qz - 1: goto 9151
fstep%(fu,pz) = sa%(qz):pz = pz + 1
fstep%(fu,pz) = sa%(n): pz = pz + 1
fstep%(fu,pz) = 200 + k: sa%(qz) = 100 + k:sa%(n) = 99
pz = pz + 1:k = k + 1
end if
next n
for n = m + 1 to j - 2
if (sa%(n) > 0) and (sa%(n) < 15) then 'Evaluate other functions
rz = n + 1
9161 if sa%(rz) = 99 then rz = rz + 1: goto 9161
fstep%(fu,pz) = sa%(rz): pz = pz + 1
fstep%(fu,pz) = sa%(n): pz = pz + 1
sa%(n) = 100 + k:fstep%(fu,pz) = 200 + k:pz = pz + 1: k = k + 1
sa%(rz) = 99
end if
next n
if sa%(m+1) = 17 then 'Initial - means change sign
rz = m + 2
9171 if sa%(rz) = 99 then rz = rz + 1: goto 9171
fstep%(fu,pz) = sa%(rz):sa%(rz) = 99:pz = pz + 1
fstep%(fu,pz) = 27:sa%(m+1) = 100 + k:pz = pz + 1
fstep%(fu,pz) = 200 + k: k = k + 1:pz = pz + 1
end if
for n = m + 2 to j - 2
if sa%(n) = 19 then 'Evaluate multipications
qz = n - 1:rz = n + 1
9181 if sa%(qz) = 99 then qz = qz - 1: goto 9181
9191 if sa%(rz) = 99 then rz = rz + 1: goto 9191
fstep%(fu,pz) = sa%(qz):sa%(qz) = 100 + k: pz = pz + 1
fstep%(fu,pz) = sa%(rz):sa%(rz) = 99:pz = pz + 1
fstep%(fu,pz) = 19:sa%(n) = 99:pz = pz + 1
fstep%(fu,pz) = 200 + k:pz = pz + 1:k = k + 1
end if
next n
for n = m + 2 to j - 2
if sa%(n) = 18 then 'Evaluate divisions
qz = n - 1:rz = n + 1
9102 if sa%(qz) = 99 then qz = qz - 1: goto 9102
9103 if sa%(rz) = 99 then rz = rz + 1: goto 9103
fstep%(fu,pz) = sa%(qz):sa%(qz) = 100 + k: pz = pz + 1
fstep%(fu,pz) = sa%(rz):sa%(rz) = 99:pz = pz + 1
fstep%(fu,pz) = 18:sa%(n) = 99:pz = pz + 1
fstep%(fu,pz) = 200 + k:pz = pz + 1:k = k + 1
end if
next n
for n = m + 2 to j - 2
if (sa%(n) = 16) or (sa%(n) = 17) then 'Evaluate + and -
qz = n - 1:rz = n + 1
9104 if sa%(qz) = 99 then qz = qz - 1: goto 9104
9106 if sa%(rz) = 99 then rz = rz + 1: goto 9106
fstep%(fu,pz) = sa%(qz):sa%(qz) = 100 + k: pz = pz + 1
fstep%(fu,pz) = sa%(rz):sa%(rz) = 99:pz = pz + 1
fstep%(fu,pz) = sa%(n):sa%(n) = 99:pz = pz + 1
fstep%(fu,pz) = 200 + k:pz = pz + 1:k = k + 1
end if
next n 'Then look for next parens closed, etc. Finally
end if 'evaluate the whole thing when all parens are done
9121 next j

goto 9179
9169 print"error in function"; formula$:end 'Too many or not enough parens open!


9179 'simplifying the RPN by eliminating redundant store and recall steps
for pz = 1 to 99
if (fstep%(fu,pz) > 200) and (fstep%(fu,pz+1) = fstep%(fu,pz) - 100) then
for uz = pz to 98
fstep%(fu,uz) = fstep%(fu,uz+2)
next uz
end if
next pz

for pz = 1 to 97 'More elimination of redundant store and recall
if (fstep%(fu,pz) > 200) and (fstep%(fu,pz+2) = fstep%(fu,pz) - 100) then
if (fstep%(fu,pz + 3) = 16) or (fstep%(fu,pz + 3) = 19) then
fstep%(fu,pz) = fstep%(fu,pz + 1)
for uz = pz + 1 to 98
fstep%(fu,uz) = fstep%(fu,uz + 2)
next uz
elseif (fstep%(fu,pz + 3) = 17) or (fstep%(fu,pz + 3) = 18) then
fstep%(fu,pz) = fstep%(fu,pz + 1)
fstep%(fu,pz + 1) = 28
for uz = pz + 2 to 99
fstep%(fu,uz) = fstep%(fu,uz + 1)
next uz
end if
end if
next pz

for pz = 1 to 99 'Elimination of excess STORE at end of program
if fstep%(fu,pz) = 0 and fstep%(fu,pz-1) > 200 then fstep%(fu,pz-1) = 0
if fstep%(fu,pz) = 0 then goto 9189
next pz

9189 for pz = 1 to 100
if fstep%(fu,pz) = 15 then goto 9169 'check for leftover (
next pz
'End of function parsing and simplifying routine

9199 return
' end AOS reading, parsing, converting, and simplifying



9200 'parsing routine RPN
9204 for i = 1 to 100
9205 fstep%(fu,i) = 0
9206 next i
j = 0
k = 1
9207 term$ = ""
9208 for i = 1 to len(formula$)
C$ = mid$(formula$,i,1)
9209
9210 if C$=" " or C$="+" or C$="-" or C$="*" or C$="/" or C$="^" then
9211 if term$ = "" then goto 9280
j = j + 1
if term$ = "exch" then fstep%(fu,j) = 28:goto 9280
9212 if term$ = "chs" then fstep%(fu,j) = 27:goto 9280
9213 if term$ = "abs" then fstep%(fu,j) = 9:goto 9280
9214 if term$ = "sgn" then fstep%(fu,j) = 10:goto 9280
9215 if term$ = "arctan" then fstep%(fu,j) = 4:goto 9280
9216 if term$ = "sqrt" then fstep%(fu,j) = 6:goto 9280
9219 if term$ = "sqr" then fstep%(fu,j) = 5:goto 9280
9220 if term$ = "cube" then fstep%(fu,j) = 7:goto 9280
9221 if term$ = "cuberoot" then fstep%(fu,j) = 8:goto 9280
9222 if term$ = "sin" then fstep%(fu,j) = 1:goto 9280
9223 if term$ = "cos" then fstep%(fu,j) = 2:goto 9280
9224 if term$ = "ln" then fstep%(fu,j) = 12:goto 9280
9227 if term$ = "log" then fstep%(fu,j) = 13:goto 9280
9230 if term$ = "exp" then fstep%(fu,j) = 14:goto 9280
9231 if term$ = "int" then fstep%(fu,j) = 11:goto 9280
9232 if term$ = "tan" then fstep%(fu,j) = 3:goto 9280
9233 if term$ = "+" then fstep%(fu,j) = 16:goto 9280
9234 if term$ = "-" then fstep%(fu,j) = 17:goto 9280
9235 if term$ = "*" then fstep%(fu,j) = 19:goto 9280
9236 if term$ = "/" then fstep%(fu,j) = 18:goto 9280
9239 if term$ = "^" then fstep%(fu,j) = 20:goto 9280
9244 if term$ = "x" then fstep%(fu,j) = 22:goto 9280
9245 if term$ = "y" then fstep%(fu,j) = 23:goto 9280
9247 if term$ = "u" then fstep%(fu,j) = 25:goto 9280
9248 if term$ = "v" then fstep%(fu,j) = 26:goto 9280
9249 if term$ = "t" then fstep%(fu,j) = 24:goto 9280
9251 if term$ = "sto1" then fstep%(fu,j) = 30:goto 9280
9252 if term$ = "sto2" then fstep%(fu,j) = 31:goto 9280
9253 if term$ = "sto3" then fstep%(fu,j) = 32:goto 9280
9254 if term$ = "rcl1" then fstep%(fu,j) = 33:goto 9280
9255 if term$ = "rcl2" then fstep%(fu,j) = 34:goto 9280
9256 if term$ = "rcl3" then fstep%(fu,j) = 35:goto 9280
9257 fstep%(fu,j) = 29:const#(fu,k) = val(term$):k = k + 1
9280 term$ = ""
if C$ <> " " then j = j + 1
if C$ = "+" then fstep%(fu,j) = 16
if C$ = "-" then fstep%(fu,j) = 17
if C$ = "*" then fstep%(fu,j) = 19
if C$ = "/" then fstep%(fu,j) = 18
if C$ = "^" then fstep%(fu,j) = 20
C$ = ""
9281 end if
9283 term$ = term$ + C$
next i

9284 return
'end RPN parsing

6000 cls
screen 2: screen 0 : ca = 11: cb = 14:cd=1:ce=4:color 11,4
6001 in = 30
6002 cls:print:print
if coord$ = "p" then
print "Surface x = f(u,v) = ";funa$
print " function: y = g(u,v) = ";funb$
print "Draw? z = h(u,v) = ";func$
end if
if coord$ = "r" then
print "Surface z = f(x,y) = ";fun$
print " function:
print "Draw?
end if
print
print "Curve x = f(t) = ";funx$
print " function: y = g(t) = ";funy$
print "Draw? z = h(t) = ";funz$
print
print "Limits: min x = ";p
print " min y = ";r
print " min z = ";tt
print
if coord$ = "p" then print " min u = ";pu else print
if coord$ = "p" then print " min v = ";pv else print
print " min t = ";pt
print
if coord$ = "p" then print "No. of lines in dir. of u is ";ln
if coord$ = "r" then print "No. of lines in each dir. is ";ln
if coord$ = "p" then print "No. of lines in dir. of v is ";lnv else print
print "No. of points on curve (t-values) ";tval
print
print "Draw new or over old graph? ";new$;
locate 24,1
if coord$ = "p" then coor$="parametric ":print " Use the same or a new color? ";col$;
if coord$ = "r" then coor$="rectangular":print "(Drawing over old graph is not recommended here.)";
locate 25,1
print "Return to opening menu? ";ret$;
locate 25,40
print "quit? ";quit$;
locate 10,65
print logica$;" logic
locate 11,65
print insert$;" mode
locate 14,55
print "Use up and down cursor
locate 15,55
print "keys to move between en-";
locate 16,55
print "tries. Typing then pro-";
locate 17,55
print "duces new entry. Use
locate 18,55
print "left and right keys to
locate 19,55
print "edit characters. Then
locate 20,55
print "typing overwrites or
locate 21,55
print "inserts (^V toggles).
locate 22,55
print "^G deletes character.;
locate 23,55
print "^T deletes to end of line.";
locate 24,55
print " toggles choices.";
locate 25,55
print " when done.";
locate 12,65
print grap$;" mode"
locate 11,30:print "max x = ";q
locate 12,30:print "max y = ";s
locate 13,30:print "max z = ";uu
if coord$ = "p" then locate 15,30:print "max u = ";qu
if coord$ = "p" then locate 16,30:print "max v = ";qv
locate 17,30:print "max t = ";qt
locate 5,7:print surf$
locate 9,7:print curv$
locate 1,1:print " Coordinate system is 3-dimensional ";coor$;

jn = 1
gosub 6100
gosub 6120

6050 LZ$ = inkey$: if LZ$ = "" then 6050
6060 if LZ$ = chr$(0)+chr$(80) then 'down arrow
gosub 6110
kn = 0
in = in + 1
gosub 6100
gosub 6120
end if
if LZ$ = chr$(0)+chr$(72) then 'up arrow
gosub 6110
kn = 0
in = in - 1
gosub 6100
gosub 6120
end if
if LZ$ = chr$(22) or LZ$ = chr$(0)+chr$(82) then '^V or INS
if insert$ = "insert" then
insert$ = "overwrite"
locate 11,65
print "overwrite mode"
else
insert$ = "insert"
locate 11,65
print "insert mode "
end if
end if
if LZ$ = chr$(13) then gosub 6130
if in > 0 and in < 8 and in <> 4 and in <> 30 then
if LZ$ = chr$(0)+chr$(75) then gosub 6140 'left arrow
if LZ$ = chr$(0)+chr$(77) then gosub 6140 'right arrow
end if
LZN = asc(LZ$)
if (LZN>39 and LZN<58 and LZN<>44) or (LZN=32) or (LZN=94) or (LZN>96 and LZN<123) then
kn = len(Q$)
Q$ = space$(kn)
goto 6030
end if
if LZ$ = chr$(27) then goto 6170 '
goto 6050

6100 if in = 0 then in = 30
if in = 31 then in = 1
if coord$ = "r" then
if in = 2 then in = 4
if in = 3 then in = 1
if in = 1 then lx = 3:ly = 25:Q$ = fun$:gosub 6190
if in = 17 then in = 21
if in = 20 then in = 16
if in = 27 or in = 18 or in = 24 then
if LZ$ = chr$(0)+chr$(72) then in = in - 1 else in = in + 1
end if
end if
if coord$ = "p" and in = 1 then lx = 3:ly = 25:Q$ = funa$:gosub 6190
if in = 2 then lx = 4:ly = 25:Q$ = funb$:gosub 6190
if in = 3 then lx = 5:ly = 25:Q$ = func$:gosub 6190
if in = 4 then lx = 5:ly = 7: Q$ = surf$
if in = 5 then lx = 7: ly = 23:Q$ = funx$:gosub 6190
if in = 6 then lx = 8: ly = 23:Q$ = funy$:gosub 6190
if in = 7 then lx = 9: ly = 23:Q$ = funz$:gosub 6190
if in = 8 then lx = 9: ly = 7: Q$ = curv$
if in = 9 then lx = 10:ly = 65:Q$ = logica$
if in = 10 then lx = 12:ly = 65:Q$ = grap$
if in = 11 then lx = 11:ly = 17:Q$ = str$(p)
if in = 12 then lx = 11:ly = 38:Q$ = str$(q)
if in = 13 then lx = 12:ly = 17:Q$ = str$(r)
if in = 14 then lx = 12:ly = 38:Q$ = str$(s)
if in = 15 then lx = 13:ly = 17:Q$ = str$(tt)
if in = 16 then lx = 13:ly = 38:Q$ = str$(uu)
if in = 17 then lx = 15:ly = 17:Q$ = str$(pu)
if in = 18 then lx = 15:ly = 38:Q$ = str$(qu)
if in = 19 then lx = 16:ly = 17:Q$ = str$(pv)
if in = 20 then lx = 16:ly = 38:Q$ = str$(qv)
if in = 21 then lx = 17:ly = 17:Q$ = str$(pt)
if in = 22 then lx = 17:ly = 38:Q$ = str$(qt)
if in = 23 then lx = 19:ly = 30:Q$ = left$(str$(ln)+" ",3)
if in = 24 then lx = 20:ly = 30:Q$ = left$(str$(lnv)+" ",3)
if in = 25 then lx = 21:ly = 35:Q$ = left$(str$(tval)+" ",5)
if in = 26 then lx = 23:ly = 30:Q$ = new$
if in = 27 then lx = 24:ly = 34:Q$ = col$
if in = 28 then lx = 25:ly = 26:Q$ = ret$
if in = 29 then lx = 25:ly = 47:Q$ = quit$
if in = 30 then lx = 1:ly = 51:Q$ = coor$
if in > 10 and in < 23 then
kn = len(Q$)
for hn = 1 to kn
if mid$(Q$,hn,1)="e" or mid$(Q$,hn,1)="E" then Q$=left$(Q$,9+hn-kn)+mid$(Q$,hn)
next hn
Q$ = left$(Q$+" ",10)
end if
return

6110 locate lx,ly:color ca,ce: print Q$;
return

6120 if in > 10 and in < 23 then locate lx,ly: print " ";
locate lx,ly:color cb,cd: print Q$;:color ca,ce
return

6130 if in = 30 then
if Q$<>"rectangular" then Q$ = "parametric "
if Q$="parametric " then Q$="rectangular":coord$="r":coor$=Q$:goto 6001
if Q$="rectangular" then Q$="parametric ":coord$="p":coor$=Q$:dimen$="2":goto 7001
end if
if in = 4 or in = 8 or in = 28 or in = 29 then
if Q$ = "yes" then q$ = "no " else q$ = "yes"
if in = 4 then surf$ = q$
if in = 8 then curv$ = q$
if in = 28 then ret$ = q$
if in = 29 then quit$ = q$
locate lx, ly
color cb,cd
print q$;
color ca,ce
end if
if in = 9 then
if q$ = "aos" then q$ = "rpn" else q$ = "aos"
logica$ = Q$
locate lx,ly
color cb,cd
print Q$
color ca,ce
end if
if in = 10 then
if Q$ = "ega" then Q$ = "cga lo": goto 6040
if Q$ = "cga lo" then Q$ = "cga hi":goto 6040
if Q$ = "cga hi" then Q$ = "ega":colr=10:clr=15
6040 grap$ = q$
locate lx,ly
color cb,cd
print Q$;
color ca,ce:print " mode "
end if
if in = 26 then
if Q$ = "new" then Q$ = "old" else q$ = "new"
new$ = q$
locate lx,ly
color cb,cd
print Q$
color ca,ce
end if
if in = 27 then
if Q$ = "same" then Q$ = "new " else q$ = "same"
col$ = q$
locate lx,ly
color cb,cd
print Q$
color ca,ce
end if
return

6140 'editing routine
kn = len(Q$)
6010 gosub 6150
6020 LZ$ = inkey$: if LZ$ = "" then 6020
if LZ$ = chr$(22) or LZ$ = chr$(0)+chr$(82) then '^V or INS
if insert$ = "insert" then
insert$ = "overwrite"
locate 6,65
print "overwrite mode"
else
insert$ = "insert"
locate 6,65
print "insert mode "
end if
end if
if LZ$ = chr$(0)+chr$(75) then jn = jn - 1:goto 6010 'left arrow
if LZ$ = chr$(0)+chr$(77) then jn = jn + 1:goto 6010 'right arrow
if LZ$=chr$(27) or LZ$=chr$(0)+chr$(72) or LZ$=Chr$(0)+chr$(80) then goto 6160
LZN = asc(LZ$)
if (LZN>39 and LZN<58 and LZN<>44) or (LZN=32) or (LZN=94) or (LZN>96 and LZN<123) then
if in > 10 and in < 23 then kn = 10
if in = 23 or in = 24 then kn = 3
if in = 25 then kn = 5
6030 if insert$="insert" then Q$ = left$(Q$,jn-1)+LZ$+mid$(Q$,jn,kn-jn)
if insert$="overwrite" then Q$ = left$(Q$,jn-1)+LZ$+mid$(Q$,jn+1)
jn = jn + 1
end if
if LZ$ = chr$(7) or LZ$ = chr$(0)+chr$(83) then '^G or DEL
Q$ = left$(Q$,jn-1)+mid$(Q$,jn+1)+" "
end if
if LZ$ = chr$(20) then '^T
Q$ = left$(Q$,jn-1)+space$(kn-jn)
end if
if LZ$ = chr$(8) and jn > 1 then '
Q$ = left$(Q$,jn-2)+mid$(Q$,jn)+" "
jn = jn - 1
end if
goto 6010

6150 locate lx, ly
if jn < 1 then jn = kn
if jn > kn then jn = 1
color cb,cd
print left$(Q$,jn - 1);
color cb,2
print mid$(q$,jn,1);
color cb,cd
print mid$(q$,jn + 1);
color ca,ce
return

6160 'exit edit routine
gosub 6110
if in > 0 and in < 8 and in <> 4 then gosub 6180
if coord$ = "p" and in = 1 then funa$ = Q$
if coord$ = "r" and in = 1 then fun$ = Q$
if in = 2 then funb$ = Q$
if in = 3 then func$ = Q$
if in = 5 then funx$ = Q$
if in = 6 then funy$ = Q$
if in = 7 then funz$ = Q$
if in = 11 then p = val(Q$)
if in = 12 then q = val(Q$)
if in = 13 then r = val(Q$)
if in = 14 then s = val(Q$)
if in = 15 then tt = val(Q$)
if in = 16 then uu = val(Q$)
if in = 17 then pu = val(Q$)
if in = 18 then qu = val(Q$)
if in = 19 then pv = val(Q$)
if in = 20 then qv = val(Q$)
if in = 21 then pt = val(Q$)
if in = 22 then qt = val(Q$)
if in = 23 then ln = val(Q$)
if in = 24 then lnv = val(Q$)
if in = 25 then tval = val(Q$)
jn = 1
goto 6060


6170 'graph the function
LZ$ = "%":in = 1
if quit$ = "yes" then screen 0: cls: end
if ret$ = "yes" then ret$ = "no ": goto 2000
if logica$ = "aos" then logic$ = "a" else logic$ = "r"
if coord$ = "r" then
if p >= q then in = 11:goto 6002
if r >= s then in = 13:goto 6002
if tt>=uu then in = 15:goto 6002
end if
if p = q then in = 11:goto 6002
if r = s then in = 13:goto 6002
if tt = uu then in = 15:goto 6002
if curv$ = "yes" then
if pt = qt then in = 21:goto 6002
if tval < 1 then in = 25:goto 6002
if tval > 1000 then tval = 1000
end if
if ln > 80 then ln = 80
if ln < 1 then in = 23:goto 6002
if coord$ = "p" and surf$ = "yes" then
if pu = qu then in = 17:goto 6002
if pv = qv then in = 19:goto 6002
if lnv > 80 then lnv = 80
if lnv < 1 then in = 24:goto 6002
end if
if curv$ = "no " and surf$ = "no " then goto 2000
if grap$ = "cga lo" then graphics$ = "l":screen 1
if grap$ = "cga hi" then graphics$ = "h":screen 2
if grap$ = "ega" then graphics$ = "e":screen 9
if col$ = "new " then clr = 29 - clr else colr = colr - 1
if new$ = "new" then BB$ = "n" else BB$ = "y"
cls
gosub 2002
if coord$ = "p" then goto 4291 else goto 3290

2002 if graphics$ = "l" then xm = 319 else xm = 639
if graphics$ = "l" then lm = 2 else lm = 1
if graphics$ = "e" then ccc = 8:rad = 1:asp = .82
if graphics$ = "l" then ccc = 3:rad = .88:asp = .91
if graphics$ = "h" then ccc = 1:rad = 1.75:asp = .46
if graphics$ = "h" then ah = 2 else ah = 1
if graphics$ = "l" then al = 2 else al = 1
ym = 199
if graphics$ = "e" then
ym = 349
screen 9,1
palette
palette 1,4
palette 2,16
palette 3,1
palette 4,5
palette 5,20
palette 6,56
palette 7,7
palette 8,36
palette 9,60
palette 10,38
palette 11,54
palette 12,50
palette 13,11
palette 14,61
palette 15,63
color 8,32
end if
return

6180
hn = len(q$)
if mid$(q$,hn,1) = " " and hn > 0 then q$ = left$(q$,hn-1) else goto 6181
goto 6180
6181 return

6190
Q$ = Q$ + SPACE$(56-len(Q$))
return

  3 Responses to “Category : Science and Education
Archive   : AGR103.ZIP
Filename : AGR103.BAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/