home *** CD-ROM | disk | FTP | other *** search
/ Best Objectech Shareware Selections / UNTITLED.iso / boss / educ / math / 023 / remak.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1989-08-20  |  9.2 KB  |  167 lines
  1. 1  '          REMAKE U.T.M.  ---  REMAK.BAS  ---  by  Dr Russell Langley
  2. 2  GOTO 400
  3. 4  '<UNK! {000A}>--- Press Enter ---
  4. 5  IF PR THEN RETURN ELSE PRINT TAB(40);:PRINT "Press <Enter> to continue.";:IN$=INKEY$:WHILE INKEY$<>CHR$(13):WEND:LOCATE,40:PRINT SPACE$(26):RETURN
  5. 6  PRINT TAB(14);:PRINT "Press <Enter> to continue, or `/' to end viewing.";:IN$=INKEY$:WHILE IN$<>CHR$(13) AND IN$<>"/":IN$=INKEY$:WEND:LOCATE,14:PRINT SPACE$(50):IF IN$="/" THEN I=N:RETURN ELSE RETURN
  6. 7  '<UNK! {000A}>*** Redirect to Block ***
  7. 9  ON QB GOTO 405,177,425 :STOP  '=start,printout,etc - CLOSE (exc 177)<UNK! {000A}><UNK! {000A}>--- Another go? ---
  8. 10  CLOSE:IF HD$="" THEN LPRINT STRING$(79,61)STRING$(4,10)
  9. 11  DO$="run this program again now":GOSUB 20:IF Z$="Y" THEN 2 ELSE 30
  10. 19  '<UNK! {000A}>--- Yes/No? ---
  11. 20  PRINT:PRINT"Do you want to "+DO$;
  12. 21  INPUT" (Y/N)";Z$:IF Z$="" THEN Z$="N":RETURN ELSE Z$=CHR$(ASC(Z$) AND 95):IF Z$="Y" OR Z$="N" THEN RETURN ELSE PRINT"WHAT?  ";:GOTO 21
  13. 29  '<UNK! {000A}>--- Errors & End ---
  14. 30  IF ERR THEN BEEP ELSE RUN"MENU"
  15. 31  IF ERR=70 THEN LINE INPUT"Can't write to that disk.  Remove its Write-Protect tab, then press <Enter>.";Z$:RESUME
  16. 32  IF ERR=71 THEN LINE INPUT"That drive is empty or its gate is open.  Fix, then press <Enter>.";Z$:RESUME
  17. 33  IF ERR=210 THEN RESUME 9  'from #86
  18. 39  ON ERROR GOTO 0:END'<UNK! {000A}><UNK! {000A}>--- Messages ---
  19. 40  BEEP:PRINT "---> Sorry, that entry is illegal.":RETURN
  20. 41  BEEP:PRINT "---> Sorry, double quotes are not allowed here.":RETURN
  21. 42  BEEP:PRINT"* * * Can't Do That.":QB=4:GOTO 9
  22. 43  COLOR 23,0:PRINT:PRINT"Working";:COLOR 7,0:RETURN
  23. 44  LOCATE,1:PRINT"Ok, done.";:GOTO 5
  24. 49  '<UNK! {000A}>*** Vetted Decoding of FF X(I,J) from X$ ***<UNK! {000A}>    Needs I, M, NU(0), & UT>0.
  25. 50  K=1:L=M:IF UT>0 THEN L=M-I+1
  26. 51  KX=0:FOR J=K TO L:Y$=SPACE$(10):KY=0
  27. 52  KX=KX+1:IF KX>LEN(X$) THEN IF J=L THEN 54 ELSE 57
  28. 53  Z$=MID$(X$,KX,1):IF INSTR("-.0123456789",Z$) THEN KY=KY+1:MID$(Y$,KY,1)=Z$:GOTO 52 ELSE IF Z$<>" " THEN 58 ELSE IF KY=0 THEN 52
  29. 54  IF NU(0) THEN NU(J)=VAL(Y$) ELSE X(I,J)=VAL(Y$)
  30. 55  NEXT J:IF KX>=LEN(X$) THEN 60
  31. 56  PLAY"L8O3CO2C":PRINT"Only the first"L"values have been read in that line.  Re-do it";:GOSUB 21:IF Z$="Y" THEN 59 ELSE 60
  32. 57  PLAY"L32O4CEG>C":PRINT"Not enough values in the line above.  Please re-do whole line.":GOTO 59
  33. 58  PLAY"L16O3CEL4>B":PRINT"That line contains a `non-numeric' entry.  Please re-do whole line."
  34. 59  INPUT X$:IF RIGHT$(X$,1)<>"/" THEN 51 ELSE X$=LEFT$(X$,LEN(X$)-1):N=I+(X$=""):IF X$>"" THEN 51
  35. 60  RETURN
  36. 79  '<UNK! {000A}>*** Disk Input of X(I,J), N, M, etc ***<UNK! {000A}>    Needs MNR, MNC, & ZZ$="UTOK" since UT is acceptable.
  37. 80  IO$="I":GOSUB 110:CLS:PRINT "Loading data from disk.":INPUT #1,FL$,VR$
  38. 81  IF LEFT$(VR$,4)<>"(RL," THEN BEEP:PRINT "Unreadable file --- not made by a program of this package.":GOTO 86
  39. 82  INPUT #1,DT$,ID$,N,M,UT,VN$:PRINT "Filename: "FL$,"Made: "DT$,"Version: "VR$:PRINT"ID: "ID$:PRINT
  40. 83  IF UT>0 THEN IF ZZ$<>"UTOK" THEN PRINT "This file is an upper triangular matrix, which this program can't use!":GOTO 86
  41. 84  PRINT"File has"N"rows of data. ";:IF N<MNR THEN PRINT "--- Not enough!":GOTO 86 ELSE IF N>MXR THEN PRINT"--- Too many!":GOTO 86
  42. 85  PRINT:PRINT"File has"M"column variables. ";:IF M<MNC THEN PRINT "--- Not enough!" ELSE IF M>MXC THEN PRINT"Too many!" ELSE 88
  43. 86  CLOSE:BEEP:GOSUB 5:ERROR 210
  44. 87  '   Select variables
  45. 88  PRINT:PRINT"The matrix was computed from"UT"rows of measurements.":PRINT:IF VN$="N" THEN PRINT "The"M"variables are not named.":GOTO 90
  46. 89  PRINT "Variables in file are:":FOR J=1 TO M:INPUT #1,VN$(J):PRINT J;VN$(J),:NEXT J:PRINT
  47. 90  GOSUB 5
  48. 99  '   Now read numerical data from disk
  49. 100  COLOR 23,0:PRINT"Loading numbers";:COLOR 7,0
  50. 101  FOR I=1 TO N:FOR J=I TO M:INPUT #1,X(I,J):X(J,I)=X(I,J):NEXT J:NEXT I 'reads UTM & fills it out.
  51. 102  CLOSE:LOCATE,1:RETURN
  52. 109  '<UNK! {000A}>--- Get Filespec ---
  53. 110  IF IO$="O" AND FL$>"" THEN PRINT "Will you file this data under the name "FL$;:GOSUB 21:IF Z$="Y" THEN 115
  54. 111  LINE INPUT "Filename (I will add .DAT extension)? ";FL$:IF FL$="" THEN 111 ELSE IF MID$(FL$,2,1)=":" THEN DR$=LEFT$(FL$,1):FL$=MID$(FL$,3)
  55. 112  ER=0:FOR I=1 TO LEN(FL$):Z$=MID$(FL$,I,1):IF INSTR(" .,/\|?*:;[]+="+CHR$(34),Z$) THEN ER=1
  56. 113  NEXT I
  57. 114  IF ER=0 AND FL$>"" AND LEN(FL$)<9 THEN FL$=FL$+".DAT" ELSE BEEP:PRINT "Invalid filename.  Will you try again";:GOSUB 21:IF Z$="Y" THEN 111 ELSE 30
  58. 115  INPUT "Which drive (A,B,C,D)";DR$:IF DR$="" THEN 115
  59. 116  DR$=CHR$(ASC(DR$) AND 95):IF INSTR("ABCD",DR$)=0 THEN 115
  60. 117  INPUT "Which directory (e.g. WORK, MYDATA, or Null Entry if root) ";DR2$:IF DR2$="" THEN DR$=DR$+":" ELSE DR$=DR$+":\"+DR2$+"\"
  61. 129  '<UNK! {000A}>--- Open File, IO$= "I" or "O" ---
  62. 130  IF IO$="I" THEN 134 ELSE ON ERROR GOTO 132:OPEN DR$+FL$ FOR INPUT AS #1
  63. 131  CLOSE:DO$="<OVERWRITE> existing "+FL$:GOSUB 20:IF Z$="N" THEN 110 ELSE 133
  64. 132  RESUME 133  'OK to start new file, since FL$ not present.
  65. 133  ON ERROR GOTO 30:OPEN DR$+FL$ FOR OUTPUT AS #1:RETURN  'print #1,Q$A$Q$Q$B$Q$:close
  66. 134  ON ERROR GOTO 136:OPEN DR$+FL$ FOR INPUT AS #1  'for input
  67. 135  ON ERROR GOTO 30:RETURN   'input #1,A$,B$:close
  68. 136  PRINT FL$" not found on Drive "DR$:RESUME 137
  69. 137  GOSUB 5:ON ERROR GOTO 30:CLS:ERASE X:SHELL "DIR "+DR$+"/W":GOSUB 5
  70. 138  DIM X(MXR,MXC):GOTO 110
  71. 139  '<UNK! {000A}>--- Save data U.T.M. using Z(I,J) ---
  72. 140  IF ID$="" THEN LINE INPUT"Problem ID? ";ID$:GOTO 142
  73. 141  LINE INPUT"Problem ID (null = unchanged)? ";Z$:IF Z$>"" THEN ID$=Z$
  74. 142  Q$=CHR$(34):IO$="O":GOSUB 110
  75. 143  PRINT "Saving data on disk ..... ";:PRINT #1,Q$FL$Q$Q$VER$Q$:PRINT #1,Q$DAT$Q$Q$ID$Q$;N;M;UT;Q$VN$Q$
  76. 144  IF VN$="Y" THEN FOR J=1 TO M:PRINT #1,Q$;VN$(NU(J));Q$;:NEXT J:PRINT #1,""
  77. 145  FOR I=1 TO N
  78. 146  FOR J=I TO M:PRINT #1,Z(I,J);:NEXT J:NEXT I:CLOSE:PRINT "done."
  79. 147  DO$="backup this file under the name "+FL$:GOSUB 20:IF Z$="Y" THEN GOSUB 115:GOTO 143 ELSE RETURN
  80. 159  '<UNK! {000A}>--- Show/Print Answers ---
  81. 160  PR=0:CLOSE:OPEN "SCRN:" FOR OUTPUT AS #2:QB=-(QB<>2)*QB-(QB=2)*QBB:RETURN
  82. 161  DO$="print these results":GOSUB 20:IF Z$="N" THEN PR=0:RETURN
  83. 162  PR=1:IF ID$="" THEN LINE INPUT "Problem ID? ";ID$:GOTO 164
  84. 163  LINE INPUT"Problem ID (null = unchanged)? ";Z$:IF Z$>"" THEN ID$=Z$
  85. 164  RETURN
  86. 165  QBB=QB:QB=2:CLS:LOCATE 8,1
  87. 166  PRINT TAB(12)"KEYTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENCLOSE"
  88. 167  PRINT TAB(12)"OPEN                                                       OPEN"
  89. 168  PRINT TAB(12)"OPEN                TURN  PRINTER  ON.                     OPEN"
  90. 169  PRINT TAB(12)"OPEN                                                       OPEN"
  91. 170  PRINT TAB(12)"OPEN    Then PRESS <ENTER> to start printing ..... or ..   OPEN"
  92. 171  PRINT TAB(12)"OPEN                                                       OPEN"
  93. 172  PRINT TAB(12)"OPEN    To send Printer Codes in Basic before printing,    OPEN"
  94. 173  PRINT TAB(12)"OPEN    press <Ctrl-Break>, & start printing by GOTO 9.    OPEN"
  95. 174  PRINT TAB(12)"OPEN                                                       OPEN"
  96. 175  PRINT TAB(12)"SCREENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENLOAD":IN$=INKEY$
  97. 176  IN$=INKEY$:IF IN$<>CHR$(13) THEN 176
  98. 177  CLS:PRINT"Printing .....":LOCATE 4,1:CLOSE:OPEN "LPT1:" FOR OUTPUT AS #2
  99. 178  IF HD$>"" THEN PRINT #2,STRING$(79,61):PRINT #2,DAT$;TAB(42-LEN(HD$)\2);HD$;TAB(73)VER$:PRINT #2,STRING$(79,61):HD$=""
  100. 179  PRINT #2,CHR$(10)"Problem: "ID$;CHR$(10)
  101. 180  RETURN
  102. 209  '<UNK! {000A}>--- Varnames ---
  103. 210  IF VN$="Y" THEN RETURN ELSE FOR L=1 TO M:IF L<10 THEN VN$(L)="Var #"+STR$(L) ELSE VN$(L)="Var #"+MID$(STR$(L),2)
  104. 211  NEXT L:RETURN
  105. 219  '<UNK! {000A}>--- Show full MxM Matrix Z(I,J) in format FMT$ ---
  106. 220  FMT$="######.#####":S12$=SPACE$(12):Z$=S12$
  107. 221  FOR K=1 TO M STEP 5:IF M<K+5 THEN L=M ELSE L=K+4
  108. 222  PRINT #2,:PRINT #2,S12$;:FOR J=K TO L:RSET Z$=VN$(NU(J)):PRINT #2,Z$;:NEXT J:PRINT #2,
  109. 223  FOR I=1 TO M:LSET Z$=VN$(NU(I)):PRINT #2,Z$;:FOR J=K TO L:PRINT #2,USING FMT$;Z(I,J);:NEXT J:PRINT #2,:NEXT I:PRINT #2,:IF L MOD 5=0 THEN GOSUB 5
  110. 224  NEXT K:RETURN
  111. 339  '<UNK! {000A}>--- Date ---
  112. 340  DAT$=MID$(DATE$,4,2)+" "+MID$("JanFebMarAprMayJunJulAugSepOctNovDec",-2+3*VAL(LEFT$(DATE$,2)),3)+" "+RIGHT$(DATE$,4):RETURN
  113. 399  '<UNK! {000A}>--- Start ---
  114. 400  KEY OFF:CLEAR:SCREEN 0,0,0,0:CLS:ON ERROR GOTO 30
  115. 401  DEFINT I-N,Q:Q$=CHR$(34):MXR=20:MNR=2:MXC=20:MNC=2
  116. 402  DEF FNSTRIP$(Z$)=LEFT$(Z$+"  ",INSTR(Z$+"  ","  ")-1)
  117. 403  DIM X(MXC,MXC),Z(MXC,MXC),NU(MXC),VN$(MXC)
  118. 404  HD$="  REMAKE  UPPER  TRIANGULAR  MATRIX  ":VER$="(RL,2)"
  119. 405  QB=1:CLOSE:CLS:GOSUB 340:PRINT DAT$;TAB(40-LEN(HD$)\2);:COLOR 0,7:PRINT HD$;:COLOR 7,0:PRINT TAB(73)VER$:LOCATE 4,1,0:K=12
  120. 406  PRINT TAB(K)"KEYTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENCLOSE"
  121. 407  PRINT TAB(K)"OPEN                                                       OPEN"
  122. 408  PRINT TAB(K)"OPEN    This program reads any Upper Triangular Matrix     OPEN"
  123. 409  PRINT TAB(K)"OPEN    (e.g. RMAT) filed by a program of this package,    OPEN"
  124. 410  PRINT TAB(K)"OPEN    based on 2-20 variables, and then lets you ---     OPEN"
  125. 411  PRINT TAB(K)"OPEN        (1)  Delete variables,  &/or                   OPEN"
  126. 412  PRINT TAB(K)"OPEN        (2)  Change the sequence of variables.         OPEN"
  127. 413  PRINT TAB(K)"OPEN    You can then file the revised version under the    OPEN"
  128. 414  PRINT TAB(K)"OPEN    same or a different filename.                      OPEN"
  129. 415  PRINT TAB(K)"OPEN                                                       OPEN"
  130. 416  PRINT TAB(K)"OPEN         If trouble, try <Ctrl-Break> & GOTO 9.        OPEN"
  131. 417  PRINT TAB(K)"OPEN                                                       OPEN"
  132. 418  PRINT TAB(K)"SCREENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENLOAD":LOCATE ,,1
  133. 419  DO$="proceed":GOSUB 20:IF Z$="N" THEN 30
  134. 420  '<UNK! {000A}>--- Get & keep original full Data Matrix, X(I,J) ---
  135. 421  IO$="I":ZZ$="UTOK":GOSUB 80
  136. 422  '<UNK! {000A}>--- Prepare Varnames ---
  137. 423  IF VN$="N" THEN FOR J=1 TO M:VN$(J)="Var #"+STR$(J):NEXT J
  138. 424  FOR J=1 TO M:VN$(J)=FNSTRIP$(VN$(J)):NEXT J
  139. 425  QB=1:CLOSE:FOR J=1 TO M:NU(J)=J:NEXT J
  140. 426  '<UNK! {000A}>--- Copy, fill out, & show original data in Z(I,J) ---
  141. 427  FOR I=1 TO M:FOR J=I TO M:Z(I,J)=X(I,J):Z(J,I)=Z(I,J):NEXT J:NEXT I
  142. 428  CLS:PRINT"Here is the full data matrix that was read:":GOSUB 160:GOSUB 220:PRINT
  143. 429  '<UNK! {000A}>--- Get New Requirements, new M & NU(J) ---
  144. 430  QB=3:MM=M   'MM = original M.
  145. 431  PRINT "How many variables do you want in the new matrix (2-";MID$(STR$(MM),2);") ";:INPUT M:IF M<MNC OR M>MM THEN BEEP:GOSUB 431
  146. 432  PRINT"Now enter the required NEW SEQUENCE of"M"variable numbers, in Free Format:"
  147. 433  LINE INPUT X$:NU(0)=UT:UT=0:I=1:GOSUB 50:UT=NU(0)  'Returns new NU(J)'s.
  148. 434  '<UNK! {000A}>--- Test validity of sequence numbers ---
  149. 435  FOR J=1 TO M:IF NU(J)<1 OR NU(J)>MM THEN PRINT"Value #"J"is out-of-bounds.  Please try again.":ER=1:J=M
  150. 436  IF J=M THEN 439
  151. 437  FOR K=J+1 TO M:IF NU(J)=NU(K) THEN PRINT"Value #"J" is duplicated.  Please try again.":ER=1:J=M:K=M
  152. 438  NEXT K
  153. 439  NEXT J:IF ER=1 THEN ER=0:BEEP:GOTO 433
  154. 440  '<UNK! {000A}>--- Rearrange Original Matrix X(I,J) into New Matrix Z(I,J) ---
  155. 441  FOR I=1 TO M:FOR J=I TO M
  156. 442  Z(I,J)=X(NU(I),NU(J)):Z(J,I)=Z(I,J)
  157. 443  NEXT J:NEXT I
  158. 444  '<UNK! {000A}>--- Show Rearranged Matrix ---
  159. 445  PRINT:PRINT"New matrix is:":GOSUB 220
  160. 446  PRINT"Is that what you want";:GOSUB 21:IF Z$="N" THEN M=MM:GOTO 425
  161. 447  '<UNK! {000A}>--- Printout? ---
  162. 448  DO$="print this new matrix":GOSUB 20:IF Z$="N" THEN 451
  163. 449  GOSUB 162:GOSUB 165:GOSUB 220:GOSUB 160
  164. 450  '<UNK! {000A}>--- File it now ---
  165. 451  PRINT"I'm now ready to file your revised matrix as an Upper Triangular Matrix.":GOSUB 140:GOTO 10
  166. 452  'end
  167.