home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / basic / bigcal2.bas < prev    next >
BASIC Source File  |  1994-07-13  |  10KB  |  349 lines
  1. 90 PRINT CHR$(26):      'Put your clear screen code here !!
  2. 100 PRINT TAB(25);"EXTENDED PRECISION CALCULATOR":PRINT
  3. 110 '
  4. 120 PRINT TAB(30); "JUDSON D. MCCLENDON":PRINT
  5. 130 ' 844 Sun Valley Road
  6. 140 ' Birmingham, AL 35215
  7. 150 '
  8. 160 ' Compuserve 74415,1003
  9. 170 '
  10. 180 PRINT TAB(20);" Modified for S-Basic by R.J. Sandel"
  11. 190 ' Added always dump and fundamental operations print.
  12. 191 ' Corrected obvious errors, and added initial instructions
  13. 192 PRINT:PRINT:PRINT:PRINT:
  14. 193 PRINT "Legal commands are: ADD, SUB, MUL, & DIV for math operations"
  15. 194 PRINT:PRINT "A or EA for Enter into Register A:  ";
  16. 195 PRINT " PA for Print A:   CA for Clear A "
  17. 196 PRINT: PRINT "XAB for Exchange A and B:   MAB for Move A into B:  ";
  18. 197 PRINT " similar for other registers":PRINT
  19. 198 PRINT "ZAP for Clear All:         END or QUIT or Q for termination.":PRINT
  20. 199 PRINT:PRINT "Warning !!! 100 place divisions take a while !!!":PRINT:PRINT
  21. 200 PRINT TAB(30);:INPUT "Enter maximum (10 to 100) precision desired ";SZ$
  22. 205                          ' SIZE = MAXIMUM DIGITS PRECISION
  23. 206 PRINT CHR$(26): '         Clear Screen Again
  24. 210 DEFINT A-Z : I=0:J=0:K=0:L=0
  25. 220 SIZE = VAL(SZ$)
  26. 221 IF SIZE <10  THEN 200
  27. 222 IF SIZE > 100 THEN 200
  28. 230 E1=0:E2=0:E3=0:E4=0:  ' DIGITS TO LEFT OF DECIMAL POINT
  29. 240 E6=0:E7=0:E8=0:E9=0:  ' NUMBER LENGTH
  30. 250 DIM EA(SIZE),EB(SIZE),EC(SIZE),EH(SIZE): ' REGISTERS EH IS TEMP HOLD
  31. 1000 ' *** Command Loop
  32. 1010 PRINT
  33. 1015 GOSUB 8000:PRINT
  34. 1020 LINE INPUT "ENTER COMMAND: ",COMMAND$
  35. 1030 IF COMMAND$="END" THEN END
  36. 1031 IF COMMAND$="Q"   THEN END
  37. 1032 IF COMMAND$="QUIT"   THEN END
  38. 1040 IF COMMAND$="ADD" THEN GOSUB 3000:GOTO 1000
  39. 1050 IF COMMAND$="SUB" THEN GOSUB 4000:GOTO 1000
  40. 1060 IF COMMAND$="MUL" THEN GOSUB 5000:GOTO 1000
  41. 1070 IF COMMAND$="DIV" THEN GOSUB 6000:GOTO 1000
  42. 1200 IF COMMAND$="DMP" THEN GOSUB 8000:GOTO 1000
  43. 1210 IF COMMAND$="EA" THEN GOSUB 8100:GOTO 1000
  44. 1211 IF COMMAND$="A"  THEN GOSUB 8100:GOTO 1000
  45. 1220 IF COMMAND$="PA" THEN GOSUB 8200:GOTO 1000
  46. 1230 IF COMMAND$="EB" THEN GOSUB 8300:GOTO 1000
  47. 1231 IF COMMAND$="B"  THEN GOSUB 8300:GOTO 1000
  48. 1240 IF COMMAND$="PB" THEN GOSUB 8400:GOTO 1000
  49. 1250 IF COMMAND$="EC" THEN GOSUB 8500:GOTO 1000
  50. 1251 IF COMMAND$="C"  THEN GOSUB 8500:GOTO 1000
  51. 1260 IF COMMAND$="PC" THEN GOSUB 8600:GOTO 1000
  52. 1270 IF COMMAND$="XAB" THEN GOSUB 8700:GOTO 1000
  53. 1280 IF COMMAND$="XAC" THEN GOSUB 8800:GOTO 1000
  54. 1290 IF COMMAND$="XBC" THEN GOSUB 8900:GOTO 1000
  55. 1300 IF COMMAND$="ZAP" THEN GOSUB 9000:GOTO 1000
  56. 1310 IF COMMAND$="MAB" THEN GOSUB 9100:GOTO 1000
  57. 1320 IF COMMAND$="MAC" THEN GOSUB 9200:GOTO 1000
  58. 1330 IF COMMAND$="CA" THEN GOSUB 9300:GOTO 1000
  59. 1340 IF COMMAND$="MBA" THEN GOSUB 9400:GOTO 1000
  60. 1350 IF COMMAND$="MBC" THEN GOSUB 9500:GOTO 1000
  61. 1360 IF COMMAND$="CB" THEN GOSUB 9600:GOTO 1000
  62. 1370 IF COMMAND$="MCA" THEN GOSUB 9700:GOTO 1000
  63. 1380 IF COMMAND$="MCB" THEN GOSUB 9800:GOTO 1000
  64. 1390 IF COMMAND$="CC" THEN GOSUB 9900:GOTO 1000
  65. 1900 PRINT "Invalid Command"
  66. 1910 GOTO 1000
  67. 3000 PRINT:PRINT " B = B + A ":PRINT
  68. 3010 IF E1<E2 THEN SC=E2-E1:GOSUB 7200
  69. 3020 IF E2<E1 THEN SC=E1-E2:GOSUB 7400
  70. 3030 IF E7<E6 THEN E7=E6
  71. 3100 FOR I=E6 TO 1 STEP -1
  72. 3110   EB(I)=EB(I)+EA(I)
  73. 3120   IF EB(I)>9 THEN EB(I-1)=EB(I-1)+1:EB(I)=EB(I)-10
  74. 3130 NEXT
  75. 3140 GOSUB 7700
  76. 3150 GOSUB 7800
  77. 3190 RETURN
  78. 4000 PRINT:PRINT " B = B - A ":PRINT
  79. 4010 IF E1<E2 THEN SC=E2-E1:GOSUB 7200
  80. 4020 IF E2<E1 THEN SC=E1-E2:GOSUB 7400
  81. 4030 IF E7<E6 THEN E7=E6
  82. 4100 FOR I=E6 TO 1 STEP -1
  83. 4110   EB(I)=EB(I)-EA(I)
  84. 4120   IF EB(I)<0 THEN EB(I-1)=EB(I-1)-1:EB(I)=EB(I)+10
  85. 4130 NEXT
  86. 4140 GOSUB 7700
  87. 4150 GOSUB 7800
  88. 4190 RETURN
  89. 5000 PRINT:PRINT " C = B * A ":PRINT
  90. 5010 GOSUB 9900
  91. 5020 E8=E7
  92. 5030 FOR I=E6 TO 1 STEP -1
  93. 5040   FOR K=E7 TO 0 STEP -1
  94. 5050     EC(K)=EC(K)+EB(K)*EA(I)
  95. 5060     IF K>=SIZE THEN 5100
  96. 5070     WHILE EC(K+1)>9
  97. 5080       EC(K)=EC(K)+1:EC(K+1)=EC(K+1)-10
  98. 5090     WEND
  99. 5100   NEXT
  100. 5110   FOR L=E8 TO 0 STEP -1
  101. 5120     EC(L+1)=EC(L)
  102. 5130   NEXT :EC(0)=0
  103. 5140   E8=E8+1
  104. 5150 NEXT
  105. 5160 E8=E6+E7:E3=E1+E2
  106. 5170 GOSUB 7900
  107. 5190 RETURN
  108. 6000 PRINT:PRINT " C = B / A ":PRINT
  109. 6010 IF E6=0 THEN PRINT "Divide by Zero":RETURN
  110. 6020 GOSUB 9900
  111. 6030 E9=E7:E4=E2:FOR I=0 TO E7:EH(I)=EB(I):NEXT
  112. 6040 IF E2<E1 THEN SC=E1-E2:GOSUB 7400
  113. 6050 IF E7<E6 THEN E7=E6
  114. 6060 E3=E2-E1+1 :E8=1
  115. 6090 ZF=0
  116. 6100 WHILE ZF=0
  117. 6110   I=0:WHILE ((I<=E6) AND (EA(I)=EB(I))):I=I+1:WEND
  118. 6120   IF I<=E6 AND EB(I)<EA(I) THEN GOSUB 6500:GOTO 6190
  119. 6130   EC(E8)=EC(E8)+1
  120. 6140   FOR I=E6 TO 1 STEP -1
  121. 6150     EB(I)=EB(I)-EA(I)
  122. 6160     IF EB(I)<0 THEN EB(I-1)=EB(I-1)-1:EB(I)=EB(I)+10
  123. 6170   NEXT
  124. 6190 WEND
  125. 6200 IF E8<E3 THEN E8=E3
  126. 6210 E7=E9:E2=E4:FOR I=0 TO E7:EB(I)=EH(I):NEXT
  127. 6270 GOSUB 7900
  128. 6290 RETURN
  129. 6500 ZF=1
  130. 6510 FOR I=1 TO E7+1
  131. 6520   IF EB(I)<>0 THEN ZF=0
  132. 6530   EB(I-1)=EB(I)
  133. 6540 NEXT
  134. 6560 IF E8<SIZE THEN E8=E8+1 ELSE ZF=1
  135. 6590 RETURN
  136. 7000 '  Get Shift Digits
  137. 7010 INPUT "Enter number of digits to shift: ",SC
  138. 7090 RETURN
  139. 7100 '  Shift A left (SC digits)
  140. 7110 FOR I=0 TO E6-SC
  141. 7120   EA(I)=EA(I+SC)
  142. 7130 NEXT
  143. 7140 FOR I=E6-SC+1 TO E6
  144. 7150   EA(I)=0
  145. 7160 NEXT
  146. 7170 E6=E6-SC:E1=E1-SC
  147. 7190 RETURN
  148. 7200 '  Shift A right (SC digits)
  149. 7210 FOR I=E6 TO 0 STEP -1
  150. 7220   EA(I+SC)=EA(I)
  151. 7230 NEXT
  152. 7240 FOR I=0 TO SC-1
  153. 7250   EA(I)=0
  154. 7260 NEXT
  155. 7270 E6=E6+SC:E1=E1+SC
  156. 7290 RETURN
  157. 7300 '  Shift B left (SC digits)
  158. 7310 FOR I=0 TO E7-SC
  159. 7320   EB(I)=EB(I+SC)
  160. 7330 NEXT
  161. 7340 FOR I=E7-SC+1 TO E7
  162. 7350   EB(I)=0
  163. 7360 NEXT
  164. 7370 E7=E7-SC:E2=E2-SC
  165. 7390 RETURN
  166. 7400 '  Shift B right (SC digits)
  167. 7410 FOR I=E7 TO 0 STEP -1
  168. 7420   EB(I+SC)=EB(I)
  169. 7430 NEXT
  170. 7440 FOR I=0 TO SC-1
  171. 7450   EB(I)=0
  172. 7460 NEXT
  173. 7470 E7=E7+SC:E2=E2+SC
  174. 7490 RETURN
  175. 7500 '  Shift C left (SC digits)
  176. 7510 FOR I=0 TO E8-SC
  177. 7520   EC(I)=EC(I+SC)
  178. 7530 NEXT
  179. 7540 FOR I=E8-SC+1 TO E8
  180. 7550   EC(I)=0
  181. 7560 NEXT
  182. 7570 E8=E8-SC:E3=E3-SC
  183. 7590 RETURN
  184. 7600 '  Shift C right (SC digits)
  185. 7610 FOR I=E8 TO 0 STEP -1
  186. 7620   EC(I+SC)=EC(I)
  187. 7630 NEXT
  188. 7640 FOR I=0 TO SC-1
  189. 7650   EC(I)=0
  190. 7660 NEXT
  191. 7670 E8=E8+SC:E3=E3+SC
  192. 7690 RETURN
  193. 7700 '  Normalize A
  194. 7710 WHILE (E6>E1) AND (EA(E6)=0):E6=E6-1:WEND
  195. 7720 IF E6=0 THEN E1=0:GOTO 7790
  196. 7730 IF EA(0)<>0 THEN SC=1:GOSUB 7200:GOTO 7790
  197. 7740 I=1:WHILE (I<E1) AND (EA(I)=0):I=I+1:WEND
  198. 7750 IF I>1 THEN SC=I-1:GOSUB 7100
  199. 7790 RETURN
  200. 7800 '  Normalize B
  201. 7810 WHILE (E7>E2) AND (EB(E7)=0):E7=E7-1:WEND
  202. 7820 IF E7=0 THEN E2=0:GOTO 7890
  203. 7830 IF EB(0)<>0 THEN SC=1:GOSUB 7400:GOTO 7890
  204. 7840 I=1:WHILE (I<E2) AND (EB(I)=0):I=I+1:WEND
  205. 7850 IF I>1 THEN SC=I-1:GOSUB 7300
  206. 7890 RETURN
  207. 7900 '  Normalize C
  208. 7910 WHILE (E8>E3) AND (EC(E8)=0):E8=E8-1:WEND
  209. 7920 IF E8=0 THEN E3=0:GOTO 7990
  210. 7930 IF EC(0)<>0 THEN SC=1:GOSUB 7600:GOTO 7990
  211. 7940 I=1:WHILE (I<E3) AND (EC(I)=0):I=I+1:WEND
  212. 7950 IF I>1 THEN SC=I-1:GOSUB 7500
  213. 7990 RETURN
  214. 8000 ' Dump Registers 
  215. 8010 GOSUB 8200
  216. 8020 GOSUB 8400
  217. 8030 GOSUB 8600
  218. 8090 RETURN
  219. 8100 ' Extract EA from string
  220. 8110 GOSUB 9300 :INPUT "Enter A: ",EN$ :E1=LEN(EN$)
  221. 8120 FOR I=1 TO LEN(EN$)
  222. 8130   X$=MID$(EN$,I,1)
  223. 8140   IF X$="." THEN E1=E6:GOTO 8180
  224. 8150   IF X$<"0" OR X$>"9" THEN PRINT "Error in A, char:";I
  225. 8160   E6=E6+1
  226. 8170   EA(E6)=VAL(X$)
  227. 8180 NEXT :GOSUB 7700
  228. 8190 RETURN
  229. 8200  ' PRINT A
  230. 8210 PRINT "A: "; :CC=3
  231. 8220 IF E1=0 THEN PRINT "0"; :CC=4
  232. 8230 FOR I=1 TO E6
  233. 8240   IF I=E1+1 THEN PRINT "."; :CC=CC+1
  234. 8250   PRINT USING "#";EA(I); :CC=CC+1
  235. 8260 IF I<>E1 THEN IF ABS(I-E1)MOD 5=0 THEN PRINT " ";
  236. 8261 CC=CC+1:IF CC>70 THEN PRINT:PRINT "   ";:CC=3
  237. 8262 IF E1=0 THEN PRINT "  ";:CC=4
  238. 8270 NEXT:PRINT
  239. 8290 RETURN
  240. 8300  ' EXTRACT EB FROM STRING
  241. 8310 GOSUB 9600 :INPUT "Enter B: ",EN$ :E2=LEN(EN$)
  242. 8320 FOR I=1 TO LEN(EN$)
  243. 8330   X$=MID$(EN$,I,1)
  244. 8340   IF X$="." THEN E2=E7:GOTO 8380
  245. 8350   IF X$<"0" OR X$>"9" THEN PRINT "Error in B, char:";I
  246. 8360   E7=E7+1
  247. 8370   EB(E7)=VAL(X$)
  248. 8380 NEXT :GOSUB 7800
  249. 8390 RETURN
  250. 8400  ' PRINT B
  251. 8410 PRINT "B: "; :CC=3
  252. 8420 IF E2=0 THEN PRINT "0"; :CC=4
  253. 8430 FOR I=1 TO E7
  254. 8440   IF I=E2+1 THEN PRINT "."; :CC=CC+1
  255. 8450   PRINT USING "#";EB(I); :CC=CC+1
  256. 8460   IF I<>E2 THEN IF ABS(I-E2)MOD 5=0 THEN PRINT " ";:CC=CC+1
  257. 8461   IF CC>70 THEN PRINT:PRINT "   ";:CC=3:IF E2=0 THEN PRINT "  ";:CC=4
  258. 8470 NEXT:PRINT
  259. 8490 RETURN
  260. 8500 '  Extract EC from string
  261. 8510 GOSUB 9900 :INPUT "Enter C: ",EN$ :E3=LEN(EN$)
  262. 8520 FOR I=1 TO LEN(EN$)
  263. 8530   X$=MID$(EN$,I,1)
  264. 8540   IF X$="." THEN E3=E8:GOTO 8580
  265. 8550   IF X$<"0" OR X$>"9" THEN PRINT "Error in C, char";I
  266. 8560   E8=E8+1
  267. 8570   EC(E8)=VAL(X$)
  268. 8580 NEXT :GOSUB 7900
  269. 8590 RETURN
  270. 8600 ' Print C
  271. 8610 PRINT "C: "; :CC=3
  272. 8620 IF E3=0 THEN PRINT "0"; :CC=4
  273. 8630 FOR I=1 TO E8
  274. 8640   IF I=E3+1 THEN PRINT "."; :CC=CC+1
  275. 8650   PRINT USING "#";EC(I); :CC=CC+1
  276. 8660   IF I<>E3 THEN IF ABS(I-E3)MOD 5=0 THEN PRINT " ";
  277. 8661   CC=CC+1:IF CC>70 THEN PRINT:PRINT "   ";
  278. 8662   CC=3:IF E3=0 THEN PRINT "  ";:CC=4
  279. 8670 NEXT:PRINT
  280. 8690 RETURN
  281. 8700 '  Exchange A BT
  282. 8710 IF E6>E7 THEN J=E6 ELSE J=E7
  283. 8720 FOR I=0 TO J:SWAP EA(I),EB(I):NEXT
  284. 8730 SWAP E6,E7:SWAP E1,E2
  285. 8790 RETURN
  286. 8800 '   Exchange A C
  287. 8810 IF E6>E8 THEN J=E6 ELSE J=E8
  288. 8820 FOR I=0 TO J:SWAP EA(I),EC(I):NEXT
  289. 8830 SWAP E6,E8:SWAP E1,E3
  290. 8890 RETURN
  291. 8900 '  Exchange B C 
  292. 8910 IF E7>E8 THEN J=E7 ELSE J=E8
  293. 8920 FOR I=0 TO J:SWAP EB(I),EC(I):NEXT
  294. 8930 SWAP E7,E8:SWAP E2,E3
  295. 8990 RETURN
  296. 9000 '  Clear all regs
  297. 9010 GOSUB 9300
  298. 9020 GOSUB 9600
  299. 9030 GOSUB 9900
  300. 9090 RETURN
  301. 9100 '  Move A B T
  302. 9110 IF E6>E7 THEN J=E6 ELSE J=E7
  303. 9120 FOR I=0 TO J:EB(I)=EA(I):NEXT
  304. 9130 E7=E6:E2=E1
  305. 9190 RETURN
  306. 9200 '  Move A C "
  307. 9210 IF E6>E8 THEN J=E6 ELSE J=E8
  308. 9220 FOR I=0 TO J:EC(I)=EA(I):NEXT
  309. 9230 E8=E6:E3=E1
  310. 9290 RETURN
  311. 9300  ' Clear A
  312. 9320 FOR I=0 TO E6:EA(I)=0:NEXT
  313. 9330 E6=0:E1=0
  314. 9390 RETURN
  315. 9400 '  Move B A
  316. 9410 IF E6>E7 THEN J=E6 ELSE J=E7
  317. 9420 FOR I=0 TO J:EA(I)=EB(I):NEXT
  318. 9430 E6=E7:E1=E2
  319. 9490 RETURN
  320. 9500 '  Move B C
  321. 9510 IF E7>E8 THEN J=E7 ELSE J=E8
  322. 9520 FOR I=0 TO J:EC(I)=EB(I):NEXT
  323. 9530 E8=E7:E3=E2
  324. 9590 RETURN
  325. 9600  ' Clear BNT
  326. 9620 FOR I=0 TO E7:EB(I)=0:NEXT
  327. 9630 E7=0:E2=0
  328. 9690 RETURN
  329. 9700 '  Move C A 
  330. 9710 IF E6>E8 THEN J=E6 ELSE J=E8
  331. 9720 FOR I=0 TO J:EA(I)=EC(I):NEXT
  332. 9730 E6=E8:E1=E3
  333. 9790 RETURN
  334. 9800 '  Move C B
  335. 9810 IF E7>E8 THEN J=E7 ELSE J=E8
  336. 9820 FOR I=0 TO J:EB(I)=EC(I):NEXT
  337. 9830 E7=E8:E2=E3
  338. 9890 RETURN
  339. 9900 '  Clear C
  340. 9920 FOR I=0 TO E8:EC(I)=0:NEXT
  341. 9930 E8=0:E3=0
  342. 9990 RETURN
  343. B(I)=EC(I):NEXT
  344. 9830 E7=E8:E2=E3
  345. 9890 RETURN
  346. 9900 '  Clear C
  347. 9920 FOR I=0 TO E8:EC(I)=0:NEXT
  348. 9930 E8=0:E3=0
  349. 9990