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