home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / basic / deskmstr.lbr / CALC-DM.BQS / CALC-DM.BAS
Encoding:
BASIC Source File  |  1985-02-10  |  10.5 KB  |  271 lines
  1. 5 CLOSE
  2. 10 REM  CALC SUBPROGRAM
  3. 20 REM
  4. 30 REM  SET UP
  5. 40 REM
  6. 45 CL$=CHR$(26):RE$=CHR$(13):BS$=CHR$(8):BU$=CHR$(19)
  7. 50 EK$=CHR$(27):BL$=" ":NU$=""
  8. 55 SC=1:PR=2:F1=3:    REM device codes
  9. 60 MV=20:L3=0:DIM N$(MV),V(MV)
  10. 67 DIM I$(80),P$(80),S(80),S$(80) 
  11. 68 REM infix, postfix expressions, value, operand stacks
  12. 100 OU=SC:REM Default output to screen 
  13. 199 REM ******************************************
  14. 200 REM *** PRINT HEADER
  15. 220 REM
  16. 230 PRINT CL$
  17. 240 PRINT "--------------------------------------------------"
  18. 250 PRINT SPC(18);"Desk Calculator"
  19. 260 PRINT "--------------------------------------------------"
  20. 270 PRINT:PRINT "Enter formulas, variable assignments, or commands."
  21. 280 PRINT "Type HELP for a list of commands.":PRINT
  22. 299 REM ******************************************
  23. 300 REM *** PROMPT AND GET INFIX EXPRESSION
  24. 310 REM EXPORT: T$
  25. 330 REM 
  26. 334 IF ME$<>NU$ THEN PRINT ME$:REM Error message if any
  27. 335 IF OU=PR AND ME$<>NU$ THEN LPRINT ME$
  28. 336 ME$=NU$
  29. 337 PRINT:PRINT ": ";: REM prompt for input
  30. 338 IF OU=PR THEN LPRINT:LPRINT ": ";
  31. 340 LN=80:FC=32:LC=127:GOSUB 20000:REM GET LINE
  32. 350 IF EC$="ESC" THEN GOTO 800
  33. 360 IF T$=NU$ THEN GOTO 300: REM re-prompt
  34. 399 REM ****************************************
  35. 400 REM PARSE INFIX EXPRESSION INTO TOKENS
  36. 410 REM IMPORT: T$ 
  37. 420 REM EXPORT: I$(),I
  38. 430 REM
  39. 450 N$="NOTVAL":IN$="NOTID":REM value,identifier flags
  40. 455 I=0
  41. 460 FOR C=1 TO LEN(T$):REM For each char in expression
  42. 470    C$=MID$(T$,C,1)
  43. 475    IF C$=BL$ THEN GOTO 570
  44. 480    GOSUB 5000: REM GET CHARACTER TYPE (TP$)
  45. 485    IF TP$="Bad character" THEN ME$=TP$:GOTO 300
  46. 486    IF TP$<>"NUMERIC" AND N$="VAL" THEN N$="NOTVAL"
  47. 490    IF TP$="OPERATOR" AND IN$="ID" AND C$<>"=" THEN ID$=I$(I):GOSUB 1400:I$(I)=RIGHT$(STR$(NU),LEN(STR$(NU))-1):IF ME$<>NU$ THEN GOTO 300
  48. 491    IF TP$="OPERATOR" AND IN$="ID" THEN IN$="NOTID":GOTO 508
  49. 493    IF TP$="NUMERIC" AND N$="VAL" THEN GOTO 570
  50. 499    IF TP$="ALPHA" AND IN$="NOTID" THEN I=I+1:I$(I)=C$:IN$="ID":GOTO 570
  51. 502    IF TP$<>"OPERATOR" AND IN$="ID" THEN I$(I)=I$(I)+C$:GOTO 570
  52. 505    IF TP$="NUMERIC" AND N$="NOTVAL" THEN I=I+1:I$(I)=RIGHT$(STR$(VAL(RIGHT$(T$,LEN(T$)-C+1))),LEN(STR$(VAL(RIGHT$(T$,LEN(T$)-C+1))))-1):N$="VAL":GOTO 570
  53. 508 IF TP$="OPERATOR" THEN I=I+1:I$(I)=C$:GOTO 570
  54. 570 NEXT
  55. 580 IF IN$="ID" AND I>1 THEN ID$=I$(I):GOSUB 1400:I$(I)=RIGHT$(STR$(NU),LEN(STR$(NU))-1):IF ME$<>NU$ THEN GOTO 300
  56. 599 REM *******************************************
  57. 600 REM INTERPRET EXPRESSION
  58. 610 REM IMPORT: I$(I)
  59. 611 REM
  60. 612 IF I=0 THEN GOTO 300
  61. 613 LW$=I$(1):GOSUB 900:I1$=UP$
  62. 615 C$=LEFT$(I$(1),1):GOSUB 5000
  63. 617 IF TP$="NUMERIC" AND I$(2)="=" THEN ME$="Can't assign a value to a number":GOTO 300
  64. 620 IF I$(2)="=" AND I>=2 THEN GOSUB 1500:GOTO 300
  65. 621 IF I1$="HELP" THEN GOSUB 6000:GOTO 300 REM LIST COMMANDS
  66. 623 IF I1$="LIST" THEN GOSUB 1600:GOTO 300 REM LIST VARIABLE VALUES
  67. 625 IF I1$="CLEAR" THEN L3=0:FOR N=1 TO MV:N$(N)=NU$:NEXT:GOTO 300
  68. 630 IF I1$="PON" THEN OU=PR:GOTO 300:REM Output to printer
  69. 640 IF I1$="POFF" THEN OU=SC:GOTO 300
  70. 650 IF I1$="EXAMPLES1" THEN RESTORE:PRINT CL$:FOR X=1 TO 11:READ X$:PRINT X$:NEXT:GOTO 300
  71. 660 IF I1$="EXAMPLES2" THEN RESTORE:PRINT CL$:FOR X=1 TO 11:READ X$:NEXT:FOR X=12 TO 23:READ X$:PRINT X$:NEXT:GOTO 300
  72. 670 IF I=1 THEN ID$=I$(1):GOSUB 1400:IF ME$=NU$ THEN GOTO 690
  73. 671 IF ME$<>NU$ THEN GOTO 300
  74. 680 IB=1:GOSUB 1009: REM  Default: evaluate expression
  75. 690 PRINT BL$;NU:REM Display numeric answer
  76. 691 IF OU=PR THEN LPRINT BL$;NU
  77. 700 GOTO 300: REM end with ESC
  78. 800 DE$="DATA":GOSUB 2570:REM CHECK DISK ID
  79. 810 PRINT CL$:FOR N=1 TO 11:PRINT:NEXT
  80. 820 PRINT SPC(13);"Reloading Desk Master...":CHAIN "DESK-DM.BAS"
  81. 898 REM ****************************************** 
  82. 899 REM ******************************************
  83. 900 REM *** TRANSLATE UPPERCASE TO LOWERCASE ***
  84. 910 REM IMPORT: LW$ (lowercase string)
  85. 915 REM EXPORT: UP$ (UPPERCASE STRING)
  86. 920 UP$=NU$
  87. 930 FOR N=1 TO LEN(LW$)
  88. 940    C$=MID$(LW$,N,1)
  89. 950    IF C$>"Z" THEN C$=CHR$(ASC(C$)-32)
  90. 960    UP$=UP$+C$
  91. 970 NEXT
  92. 980 RETURN
  93. 999 REM ***************************************
  94. 1009 REM  *** CONVERT INFIX EXPRESSION TO POSTFIX ***
  95. 1030 REM IMPORT: I$(),I 
  96. 1035 REM EXPORT: P$(),P
  97. 1040 REM
  98. 1060 TP=0:P=0:REM Top of stack
  99. 1062 FOR C=IB TO I
  100. 1064    C$=I$(C)
  101. 1066    IF C$=")" THEN GOSUB 2000:GOTO 1090 
  102. 1068    PC=1:PS=1
  103. 1070    IF C$<>"/" AND C$<>"*" AND C$<>"-" AND C$<>"+" THEN GOTO 1084
  104. 1072    IF C$="*" OR C$="/" THEN PC=2
  105. 1074    IF TP=0 THEN PS=0: GOTO 1080
  106. 1076    IF S$(TP)="*" OR S$(TP)="/" THEN PS=2
  107. 1078    IF S$(TP)="(" THEN PS=0
  108. 1080    IF PC>PS THEN TP=TP+1:S$(TP)=C$:GOTO 1090
  109. 1082 IF PC<PS THEN P=P+1:P$(P)=S$(TP):TP=TP-1:GOTO 1068
  110. 1083 IF PC=PS THEN P=P+1:P$(P)=S$(TP):S$(TP)=C$:GOTO 1090
  111. 1084    IF C$="(" THEN TP=TP+1:S$(TP)=C$:GOTO 1090
  112. 1086    REM Identifier
  113. 1088    P=P+1:P$(P)=C$
  114. 1090 NEXT
  115. 1092 GOSUB 2000: REM EMPTY OPERATOR STACK
  116. 1099 REM ******************************************
  117. 1140 REM *** EXECUTE POSTFIXED EXPRESSION ***
  118. 1145 REM IMPORT: P$(),P
  119. 1146 REM EXPORT: NU
  120. 1150 TP=0:REM Stack top
  121. 1160 FOR C=1 TO P:REM For each post-fixed token
  122. 1170    C$=P$(C)
  123. 1175    REM Perform arithmetic operation
  124. 1180    IF C$="+" THEN TP=TP-1:S(TP)=S(TP)+S(TP+1):GOTO 1230
  125. 1190    IF C$="-" THEN TP=TP-1:S(TP)=S(TP)-S(TP+1):GOTO 1230
  126. 1200    IF C$="*" THEN TP=TP-1:S(TP)=S(TP)*S(TP+1):GOTO 1230
  127. 1210    IF C$="/" AND S(TP)=0 THEN ME$="You can't divide by zero!":GOTO 1260
  128. 1215    IF C$="/" THEN TP=TP-1:S(TP)=S(TP)/S(TP+1):GOTO 1230
  129. 1220    TP=TP+1:S(TP)=VAL(C$)
  130. 1230 NEXT
  131. 1250 NU=S(TP):REM The answer, at last!
  132. 1260 RETURN
  133. 1299 REM *****************************************
  134. 1300 REM *** PUT VALUE INTO VARIABLE TABLE ***
  135. 1310 REM IMPORT: NU,ID$
  136. 1315 REM EXPORT: ME$
  137. 1320 N=0
  138. 1330 N=N+1:REM For each variable in the table already
  139. 1340    IF N$(N)=ID$ THEN V(N)=NU:GOTO 1380
  140. 1350 IF N<L3 THEN GOTO 1330
  141. 1360 IF L3=MV THEN ME$="No more variables allowed. ":GOTO 1380
  142. 1370 L3=L3+1:N$(L3)=I$(1):V(L3)=NU:REM Add value to variable table
  143. 1380 RETURN
  144. 1399 REM *****************************************
  145. 1400 REM *** GET VALUE FROM VARIABLE TABLE ***
  146. 1410 REM IMPORT: ID$
  147. 1415 REM EXPORT: NU,ME$
  148. 1420 N=0
  149. 1430 N=N+1:REM For each value in the table
  150. 1435    IF N>L3 THEN ME$="Undefined variable":GOTO 1470
  151. 1440    IF N$(N)=ID$ THEN NU=V(N):GOTO 1470
  152. 1450 GOTO 1430
  153. 1460 ME$="Undefined variable"
  154. 1470 RETURN
  155. 1499 REM ******************************************
  156. 1500 REM *** ASSIGN A VALUE TO A VARIABLE ***
  157. 1510 REM IMPORT: I$(),I 
  158. 1515 REM EXPORT: IB,ME$
  159. 1520 C$=LEFT$(I$(3),1):GOSUB 5000 REM GET TYPE
  160. 1530 IF I=3 AND TP$="NUMERIC" THEN NU=VAL(I$(3))
  161. 1540 IF I=3 AND TP$="ALPHA" THEN ID$=I$(3):GOSUB 1400
  162. 1550 IF I>3 THEN IB=3:GOSUB 1009:REM POSTFIX AND EXECUTE
  163. 1555 IF ME$<>NU$ THEN GOTO 1599
  164. 1560 ID$=I$(1):GOSUB 1300 REM PUT VALUE IN TABLE
  165. 1570 RETURN
  166. 1599 REM ***************************************
  167. 1600 REM DISPLAY VARIABLES
  168. 1610 REM
  169. 1620 PRINT:PRINT
  170. 1625 IF L3<1 THEN PRINT "No variables set":GOTO 1680
  171. 1630 PRINT "::::::::::::: SET VARIABLES ::::::::::::":PRINT
  172. 1635 IF OU=PR THEN LPRINT "::::::::::::::: SET VARIABLES ::::::::::::::":LPRINT
  173. 1650 FOR N=1 TO L3
  174. 1660    PRINT N$(N);"=";V(N)
  175. 1665    IF OU=PR THEN LPRINT N$(N);"=";V(N) 
  176. 1670 NEXT
  177. 1680 RETURN
  178. 1699 REM *******************************************
  179. 2000 REM *** EMPTY OPERATOR STACK ***
  180. 2010 REM
  181. 2020 IF TP=0 THEN GOTO 2080
  182. 2030 FOR N=TP TO 1 STEP -1
  183. 2050    IF S$(TP)<>"(" THEN P=P+1:P$(P)=S$(TP)
  184. 2060    TP=TP-1
  185. 2070 NEXT
  186. 2080 RETURN
  187. 2099 REM *****************************************
  188. 2500 REM *** WAIT FOR RESPONSE ***
  189. 2510 PRINT:PRINT:PRINT
  190. 2520 PRINT SPC(13);"Hit any key to continue...";
  191. 2530 K$=INPUT$(1)
  192. 2540 RETURN
  193. 2550 REM *****************************************
  194. 2570 REM *** CHECK DISK ID ***
  195. 2580 DK$="NOID"
  196. 2590 OPEN "I",#F1,"IDENT-DM"
  197. 2600    INPUT #F1,DK$
  198. 2605 CLOSE #F1
  199. 2610 IF DK$="DATA" AND DE$="DATA" THEN GOTO 2670
  200. 2620 IF DK$="PROGRAM" AND DE$="PROGRAM" THEN GOTO 2670
  201. 2630 PRINT CL$:FOR N=1 TO 11:PRINT:NEXT
  202. 2640 PRINT "Insert the Desk Master ";DE$;" disk."
  203. 2645 RESTORE
  204. 2650 GOSUB 2500: REM PAUSE
  205. 2660 GOTO 2590
  206. 2670 RETURN
  207. 2679 REM ***************************************
  208. 5000 REM *** DETERMINE CHARACTER TYPE ***
  209. 5010 REM IMPORT: C$
  210. 5015 REM EXPORT: TP$
  211. 5025 TP$="Bad character"
  212. 5030 IF (C$>="A" AND C$<="Z") OR (C$>="a" AND C$<="z")THEN TP$="ALPHA"
  213. 5040 IF (C$>="0" AND C$<="9") OR C$="." THEN TP$="NUMERIC"
  214. 5050 IF C$=")" OR C$="(" OR C$="+" OR C$="-" OR C$="*"OR C$="/" OR C$="=" THEN TP$="OPERATOR"
  215. 5060 RETURN
  216. 5099 REM ****************************************
  217. 6000 REM *** LIST COMMANDS ***
  218. 6010 RESTORE:FOR N=1 TO 23:READ X$:NEXT
  219. 6020 FOR N=24 TO 33
  220. 6030    READ X$
  221. 6040    PRINT X$
  222. 6050    IF OU=PR THEN LPRINT X$
  223. 6060 NEXT
  224. 6065 PRINT
  225. 6070 PRINT "Like HELP, type command after colon.":PRINT
  226. 6080 RETURN
  227. 6099 REM ******************************************
  228. 7000 REM *** SOPHISTICATED ERROR ROUTINE ***
  229. 7010 ME$="Error in expression":GOTO 300
  230. 7020 REM So much for sophistication
  231. 7099 REM *****************************************
  232. 20000 REM *** GET LINE ***
  233. 20020 REM IMPORT: LN,FC,LC
  234. 20030 REM EXPORT: T$,EC$
  235. 20040 REM
  236. 20060 EC$=NU$:T$=NU$
  237. 20080 C=0: REM for each character input
  238. 20090 C=C+1: C$=INPUT$(1): REM get character 
  239. 20095   IF C$=BU$ THEN C$=BS$:PRINT C$;
  240. 20100   IF C$=EK$ THEN EC$="ESC":GOTO 20250
  241. 20150   IF C$=RE$ THEN PRINT:GOTO 20250
  242. 20160   IF (ASC(C$)<FC OR ASC(C$)>LC) AND C$<>BS$ THEN C=C-1:GOTO 20090
  243. 20170   IF C$=BS$ AND C=1 THEN PRINT;:GOTO 20060
  244. 20180   PRINT C$;:IF OU=PR THEN LPRINT C$; 
  245. 20190   IF C$=BS$ AND C<=2 THEN PRINT :PRINT ": ";:GOTO 20000
  246. 20200   IF C$=BS$ AND C>2 THEN C=C-2:T$=LEFT$(T$,C):GOTO 20090
  247. 20210 IF C=LN THEN T$=T$+C$:GOTO 20250 
  248. 20240 T$=T$+C$:GOTO 20090 REM add character and get another
  249. 20250 IF OU=PR THEN LPRINT
  250. 20251 RETURN
  251. 49999 REM ****************************************
  252. 50000 DATA "Simple calculations: "," "," "
  253. 50010 DATA ": 2+2","  4"," ",": 5*5","  25"," "
  254. 50020 DATA ": 2+(8/2)","  6"
  255. 50030 DATA "Assignments: "," "," " 
  256. 50040 DATA ": A=15"," ",": A","  15"," "
  257. 50050 DATA ": TOTAL=A+15"," ",": TOTAL","  30"
  258. 50060 DATA " "
  259. 50070 DATA "     List of commands"
  260. 50080 DATA " "
  261. 50090 DATA "PON.................TURNS PRINTER ON"
  262. 50100 DATA "POFF................TURNS PRINTER OFF"
  263. 50110 DATA "LIST................LIST VALUES OF VARIABLES"
  264. 50120 DATA "CLEAR...............ERASES ALL VARIABLES"
  265. 50130 DATA "HELP................LIST THESE COMMANDS"
  266. 50140 DATA "EXAMPLES1...........SIMPLE CALCULATIONS"
  267. 50150 DATA "EXAMPLES2...........VARIABLE ASSIGNMENTS"
  268. 50160 DATA " "
  269. 55555 END
  270. A "EXAMPLES1...........SIMPLE CALCULATIONS"
  271. 50150 DATA "EXAMPLES2...........VARIABLE