home *** CD-ROM | disk | FTP | other *** search
/ Best Objectech Shareware Selections / UNTITLED.iso / boss / educ / math / 023 / group.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1989-08-16  |  10.4 KB  |  181 lines
  1. 1  '          REGROUP   ---   GROUP.BAS    by  Dr Russell Langley
  2. 2  GOTO 400
  3. 4  '<UNK! {000A}>*** Press Enter ***
  4. 5  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 30,400,421 :STOP 'quit, restart, show file details again.<UNK! {000A}><UNK! {000A}>--- Another go? ---
  8. 10  DO$="run this program again now":GOSUB 20:IF Z$="Y" THEN 2 ELSE 30
  9. 19  '<UNK! {000A}>--- Yes/No? ---
  10. 20  PRINT:PRINT"Do you want to "+DO$;
  11. 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
  12. 29  '<UNK! {000A}>--- Errors & End ---
  13. 30  IF ERR THEN BEEP ELSE RUN "MENU"
  14. 31  IF ERR=70 THEN LINE INPUT"Can't write to that disk.  Remove its Write-Protect tab, then press <Enter>.";Z$:RESUME
  15. 32  IF ERR=71 THEN LINE INPUT"That drive is empty or its gate is open.  Fix, then press <Enter>.";Z$:RESUME
  16. 33  IF ERR=210 THEN RESUME 9  'from #86
  17. 39  ON ERROR GOTO 0:END'<UNK! {000A}><UNK! {000A}>--- Messages ---
  18. 40  BEEP:PRINT "---> Sorry, that entry is illegal.":RETURN
  19. 41  BEEP:PRINT "---> Sorry, double quotes are not allowed here.":RETURN
  20. 43  COLOR 23,0:PRINT:PRINT"Working";:COLOR 7,0:RETURN
  21. 44  LOCATE,1:PRINT"Ok, done.";:GOTO 5
  22. 49  '<UNK! {000A}>*** Vetted Decoding of FF X(I,J) from X$ ***<UNK! {000A}>    Needs I, M, & Q(0)=1 from #96 or Q(0)=0 from #446.
  23. 50  K=1:L=M
  24. 51  KX=0:FOR J=K TO L:Y$=SPACE$(10):KY=0
  25. 52  KX=KX+1:IF KX>LEN(X$) THEN IF J=L THEN 54 ELSE 57
  26. 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
  27. 54  IF Q(0)=0 THEN L(J)=VAL(Y$) ELSE Q(J)=VAL(Y$)
  28. 55  NEXT J:IF KX>=LEN(X$) THEN 60
  29. 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
  30. 57  PLAY"L32O4CEG>C":PRINT"Not enough values in the line above.  Please re-do whole line.":GOTO 59
  31. 58  PLAY"L16O3CEL4>B":PRINT"That line contains a `non-numeric' entry.  Please re-do whole line."
  32. 59  Q(0)=-9
  33. 60  RETURN
  34. 79  '<UNK! {000A}>*** Disk Input of X(I,J), N, M, etc ***<UNK! {000A}>    Needs MNR, MNC.
  35. 80  IO$="I":GOSUB 110:CLS:PRINT "Loading data from disk.":INPUT #1,FL$,VR$
  36. 81  IF LEFT$(VR$,4)<>"(RL," THEN BEEP:PRINT "Unreadable file --- not made by our Data Filer/Editor program.":GOTO 86
  37. 82  INPUT #1,DT$,ID$,N,M,UT,VN$:PRINT "Filename: "FL$,"Made: "DT$,"Version: "VR$:PRINT"ID: "ID$:PRINT
  38. 83  IF UT<>0 THEN PRINT "This file is an upper triangular matrix, which this program can't use!":GOTO 86
  39. 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
  40. 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
  41. 86  CLOSE:BEEP:GOSUB 5:ERROR 210
  42. 87  '   Select variables
  43. 88  PRINT:IF VN$="N" THEN PRINT "The"M"variables are not named.":GOTO 90
  44. 89  PRINT "Variables in file are:":FOR J=1 TO M:INPUT #1,VN$(J):PRINT J;VN$(J),:NEXT J:PRINT
  45. 90  IF M=MNC THEN 100 ELSE PRINT
  46. 91  PRINT"How many filed column variables are to be IGNORED (0-"MID$(STR$(M-MNC),2)")";:INPUT ND:IF ND<0 OR ND>M-MNC THEN 91 ELSE IF ND=0 THEN 100
  47. 94  IF ND=1 THEN PRINT "Number of the variable to be IGNORED (1-"MID$(STR$(M),2)")";:INPUT X$:Q(1)=VAL(X$):IF Q(1)<1 OR Q(1)>M THEN GOSUB 40:GOTO 94 ELSE 97
  48. 95  PRINT MID$(STR$(ND),2)" numbers of variables to be IGNORED (in ascending order & Free Format):":INPUT X$:IF VAL(X$)<1 THEN GOSUB 40:GOTO 95
  49. 96  Q(0)=1:MM=M:M=ND:GOSUB 50:Q(0)=0:M=MM
  50. 97  KK=1:L=1:FOR J=1 TO M:IF J=Q(KK) THEN KK=KK+1 ELSE VN$(L)=VN$(J):L=L+1
  51. 98  NEXT J
  52. 99  '   Now read numerical data from disk
  53. 100  COLOR 23,0:PRINT"Loading numbers";:COLOR 7,0:FOR I=1 TO N:KK=1:LL=1:L=M
  54. 101  FOR J=1 TO L:INPUT #1,Z
  55. 102  IF J=Q(KK) THEN KK=KK+1 ELSE X(I,LL)=Z:LL=LL+1
  56. 103  NEXT J:NEXT I:CLOSE:LOCATE,1:M=M-ND:RETURN
  57. 109  '<UNK! {000A}>--- Get Filespec ---
  58. 110  IF IO$="O" AND FL$>"" THEN PRINT "Will you file this data under the name "FL$;:GOSUB 21:IF Z$="Y" THEN 115
  59. 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)
  60. 112  ER=0:FOR I=1 TO LEN(FL$):Z$=MID$(FL$,I,1):IF INSTR(" .,/\|?*:;[]+="+CHR$(34),Z$) THEN ER=1
  61. 113  NEXT I
  62. 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 2
  63. 115  INPUT "Which drive (A,B,C,D)";DR$:IF DR$="" THEN 115
  64. 116  DR$=CHR$(ASC(DR$) AND 95):IF INSTR("ABCD",DR$)=0 THEN 115
  65. 117  INPUT "Which directory (e.g. WORK, MYDATA, or Null Entry if root) ";DR2$:IF DR2$="" THEN DR$=DR$+":" ELSE DR$=DR$+":\"+DR2$+"\"
  66. 129  '<UNK! {000A}>--- Open File, IO$= "I" or "O" ---
  67. 130  IF IO$="I" THEN 134 ELSE ON ERROR GOTO 132:OPEN DR$+FL$ FOR INPUT AS #1
  68. 131  CLOSE:DO$="<OVERWRITE> existing "+FL$:GOSUB 20:IF Z$="N" THEN 110 ELSE 133
  69. 132  RESUME 133  'OK to start new file, since FL$ not present.
  70. 133  ON ERROR GOTO 30:OPEN DR$+FL$ FOR OUTPUT AS #1:RETURN  'print #1,Q$A$Q$Q$B$Q$:close
  71. 134  ON ERROR GOTO 136:OPEN DR$+FL$ FOR INPUT AS #1  'for input
  72. 135  ON ERROR GOTO 30:RETURN   'input #1,A$,B$:close
  73. 136  PRINT FL$" not found on Drive "DR$:RESUME 137
  74. 137  GOSUB 5:ON ERROR GOTO 30:CLS:ERASE X:SHELL "DIR "+DR$+"/W":GOSUB 5
  75. 138  DIM X(MXR,MXC)
  76. 139  GOTO 110 '<UNK! {000A}>*** Save data ***
  77. 140  IF ID$="" THEN LINE INPUT "Problem ID? ";ID$:GOTO 142
  78. 141  LINE INPUT "Problem ID (null = unchanged)? ";Z$:IF Z$>"" THEN ID$=Z$
  79. 142  Q$=CHR$(34):IO$="O":GOSUB 110
  80. 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$
  81. 144  IF VN$="Y" THEN FOR J=1 TO M:PRINT #1,Q$VN$(J)Q$;:NEXT J:PRINT #1,""
  82. 145  FOR I=1 TO N
  83. 146  FOR J=1 TO M:PRINT #1,X(GP(I-1),J);:NEXT J:NEXT I:CLOSE:PRINT "done."
  84. 147  DO$="backup this file under the name "+FL$:GOSUB 20:IF Z$="Y" THEN GOSUB 115:GOTO 143 ELSE RETURN
  85. 339  '<UNK! {000A}>--- Date ---
  86. 340  DAT$=MID$(DATE$,4,2)+" "+MID$("JanFebMarAprMayJunJulAugSepOctNovDec",-2+3*VAL(LEFT$(DATE$,2)),3)+" "+RIGHT$(DATE$,4):RETURN
  87. 349  '<UNK! {000A}>--- Integer Array Sorter  (J. Dorner) ---<UNK! {000A}>    Call by:   DEF SEG:INTSORT=VARPTR(INTSORT%(0)):CALL INTSORT(n,x%(0))
  88. 350  DIM INTSORT%(21):RESTORE 351:FOR I=0 TO 21:READ INTSORT%(I):NEXT I:DEF SEG:INTSORT=VARPTR(INTSORT%(0)):RETURN
  89. 351  DATA &H5590,&HEC8B,&H1BB,&H8B00,&H876,&HC8B,&H7449,&H8B19
  90. 352  DATA &H676,&H48B,&H4439,&H7302,&H8707,&H244,&H489,&HDB33
  91. 353  DATA &H4646,&HEEE2,&HDB0B,&HDC74,&HCA5D,&H4
  92. 399  '<UNK! {000A}>--- Start ---
  93. 400  KEY OFF:CLEAR:SCREEN 0,0,0,0:CLS:ON ERROR GOTO 30
  94. 401  DEFINT I-N,C,E,F,G,Q,S:MXR=400:MNR=4:MXC=20:MNC=2:MG=31
  95. 402  DIM I,J,K,L,M,N,Q,X$,Y$,Z$,X(MXR,MXC),C(MG),GP(MXR),L(MG),N(MG),Q(MG),VN$(MXC)
  96. 403  HD$="  R E G R O U P  ":VER$="(RL,6)"
  97. 404  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
  98. 405  PRINT TAB(K)"KEYTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENCLOSE"
  99. 406  PRINT TAB(K)"OPEN                                                       OPEN"
  100. 407  PRINT TAB(K)"OPEN  This program rearranges the order of persons (rows)  OPEN"
  101. 408  PRINT TAB(K)"OPEN  in a datafile. It allows persons who share the same  OPEN"
  102. 409  PRINT TAB(K)"OPEN  value of a `label' (0-30) to be grouped together.    OPEN"
  103. 410  PRINT TAB(K)"OPEN                                                       OPEN"
  104. 411  PRINT TAB(K)"OPEN  So all persons in Group `1' can be put at the top of OPEN"
  105. 412  PRINT TAB(K)"OPEN  the file, those in Group `2' can come next, & so on. OPEN"
  106. 413  PRINT TAB(K)"OPEN  You can specify any order of groups, like 4 2 5 3 1. OPEN"
  107. 414  PRINT TAB(K)"OPEN   Put any UNWANTED groups at the BOTTOM of the list,  OPEN"
  108. 415  PRINT TAB(K)"OPEN      and omit them when saving the regrouped file.    OPEN"
  109. 416  PRINT TAB(K)"OPEN         If trouble, try <Ctrl-Break> & GOTO 9.        OPEN"
  110. 417  PRINT TAB(K)"OPEN                                                       OPEN"
  111. 418  PRINT TAB(K)"SCREENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENLOAD":LOCATE ,,1:PRINT
  112. 419  '<UNK! {000A}>--- Get & Show Data ---
  113. 420  GOSUB 80
  114. 421  QB=2:CLOSE:PRINT"Filename: "FL$:IF VN$="N" THEN PRINT"Variables not named.":GOTO 423
  115. 422  FOR J=1 TO M:PRINT J;VN$(J),:NEXT J:PRINT
  116. 423  PRINT"Data read was ---":LN=0:FOR I=1 TO N:LN=LN+1
  117. 424  IF LN=21 THEN LN=1:GOSUB 6:IF IN$="/" THEN 426
  118. 425  PRINT"Row";STR$(I);": ";:FOR J=1 TO M:PRINT X(I,J);:NEXT J:PRINT:IF LN=0 THEN I=N
  119. 426  NEXT I:IF IN$<>"/" THEN GOSUB 5
  120. 427  '<UNK! {000A}>--- Identify variable containing the Group Label ---
  121. 428  PRINT"In the datafile, what VARIABLE # is the GROUP LABEL (1-"MID$(STR$(M),2)")";:INPUT LAB:IF LAB<1 OR LAB>M THEN BEEP:GOTO 428
  122. 429  PRINT"Ok.   Wait while I examine its values."
  123. 430  '<UNK! {000A}>--- Make integer array GP(I), I=0 to N-1, concatenating Group Label & Row #,        with max value of 30400 if 31 groups (0-30) & 400 rows.
  124. 431  FOR I=1 TO N:IF X(I,LAB) > 30 THEN BEEP:PRINT"ERROR.  Processing stopped because Row"I"has a label > 30.":GOSUB 5:GOTO 10
  125. 432  GP(I-1)=X(I,LAB)*1000+I
  126. 433  NEXT I
  127. 434  '<UNK! {000A}>--- Sort Labels in ascending order of groups ---
  128. 435  GOSUB 350:DEF SEG:INTSORT=VARPTR(INTSORT%(0)):CALL INTSORT(N,GP(0))
  129. 436  '<UNK! {000A}>--- Get label values L(J), J=1 to NG, & N(J)=# in Jth gp, C(J)=cum # of N(J)'s.
  130. 437  Z=0:J=1:L(J)=GP(0)\1000:N(J)=1:C(J)=0
  131. 438  FOR I=2 TO N
  132. 439  IF GP(I-1)\1000=GP(I-2)\1000 THEN N(J)=N(J)+1 ELSE C(J)=C(J-1)+N(J):IF J<MG THEN J=J+1:L(J)=GP(I-1)\1000:N(J)=1 ELSE I=N:Z=9
  133. 440  NEXT I:IF Z=0 THEN NG=J:C(J)=N:GOTO 443
  134. 441  PRINT"Variable #"LAB"contains more than"MG"(0-30) different group labels.":DO$="group persons by another variable":GOSUB 20:IF Z$="Y" THEN 428 ELSE 10
  135. 442  '<UNK! {000A}>--- Show ascending labels L(J), & seek a different sequence ---
  136. 443  PRINT"Variable #"LAB"has the following Group Labels:":FOR J=1 TO NG:PRINT L(J);:NEXT J:PRINT
  137. 444  PRINT"Is this order Ok for your regrouped datafile";:GOSUB 21:IF Z$="Y" THEN 459
  138. 445  '<UNK! {000A}>--- Get new group order, & check validity of entries ---
  139. 446  PRINT"Enter required sequence of groups ---"NG"Group Label Values in Free Format:":INPUT X$:MM=M:M=NG:Q(0)=0:GOSUB 50:M=MM:IF Q(0)=-9 THEN 446
  140. 447  KT=0:FOR J=1 TO NG:FOR K=1 TO NG
  141. 448  IF L(J)=GP(C(K-1))\1000 THEN KT=KT+1:K=NG
  142. 449  NEXT K:NEXT J:IF KT<NG THEN BEEP:PRINT"You've entered 1 or more WRONG LABEL VALUES.  Please re-do.":GOTO 446
  143. 450  '<UNK! {000A}>--- Remake GP(I-1), I=1 to N, by going thru X(I,TAB) for each label in turn ---
  144. 451  K=0:FOR J=1 TO NG
  145. 452  FOR I=1 TO N:IF X(I,LAB)=L(J) THEN GP(K)=X(I,LAB)*1000+I:K=K+1
  146. 453  NEXT I:NEXT J
  147. 454  '<UNK! {000A}>--- Count Group Sizes again ---
  148. 455  J=1:N(J)=1:C(J)=0:FOR I=2 TO N
  149. 456  IF GP(I-1)\1000=GP(I-2)\1000 THEN N(J)=N(J)+1 ELSE C(J)=C(J-1)+N(J):J=J+1:N(J)=1
  150. 457  NEXT I
  151. 458  '<UNK! {000A}>--- Show Outcome ---
  152. 459  CLS:PRINT TAB(20)"SUMMARY OF REGROUPED DATA":PRINT:PRINT TAB(22)"#   GROUP-LABEL   SIZE":F$="####":G$=F$+"     "+F$+"       "+F$:H$="TOTAL ="+F$
  153. 460  FOR J=1 TO NG:PRINT TAB(19);USING G$;J;L(J);N(J):IF J=15 THEN GOSUB 5
  154. 461  NEXT J:PRINT TAB(32);USING H$;N:PRINT
  155. 462  PRINT TAB(15)"Press <Enter> to see Regrouped Data";:LINE INPUT;"";Z$:LOCATE ,1:PRINT SPACE$(60);:LOCATE ,1:GOSUB 43:LOCATE ,1
  156. 463  FOR I=1 TO N:GP(I-1)=GP(I-1)-(GP(I-1)\1000)*1000:NEXT I
  157. 464  PRINT"REGROUPED DATA:":FOR I=1 TO N
  158. 465  PRINT"Row"STR$(I)": ";:FOR J=1 TO M:PRINT X(GP(I-1),J);:NEXT J:PRINT:IF I MOD 20=0 THEN GOSUB 5
  159. 466  NEXT I
  160. 467  '<UNK! {000A}>--- Delete Bottom Groups? ---
  161. 468  DO$="delete any groups from the bottom":GOSUB 20:IF Z$="N" THEN 473
  162. 469  PRINT"Delete how many groups (0-"MID$(STR$(NG-1),2)", or Null to re-view the data) ";:INPUT Z$:IF Z$="" THEN 459
  163. 470  Q=VAL(Z$):IF Q<0 OR Q>NG-1 THEN BEEP:GOTO 469 ELSE IF Q=0 THEN PRINT"Ok, none deleted!":GOTO 473
  164. 471  NG=NG-Q:N=C(NG)
  165. 472  '<UNK! {000A}>--- File Regrouped Data ---
  166. 473  PRINT:PRINT"Well, let's proceed now to save your rearranged datafile."
  167. 474  GOSUB 140
  168. 475  '<UNK! {000A}>--- Print Regrouped Data ---
  169. 476  BEEP:DO$="print this datafile on your printer":GOSUB 20:IF Z$="N" THEN 486
  170. 477  PRINT:COLOR 23,0:PRINT "Turn printer on, then press <ENTER>";:COLOR 7,0:LINE INPUT;"";Z$:LOCATE ,1:PRINT SPACE$(60)
  171. 478  LPRINT STRING$(79,"="):LPRINT" ":LPRINT CHR$(14);"R E G R O U P E D    D A T A";CHR$(20)   '= Wide letters on Epson printers.
  172. 479  LPRINT" ":LPRINT"Problem ID: "ID$
  173. 480  LPRINT" ":LPRINT"Filename: "FL$:LPRINT" ":IF VN$="N" THEN LPRINT"Variables not named." ELSE FOR J=1 TO M:LPRINT"Var"STR$(J)"="VN$(J)"  ";:NEXT J:LPRINT" "
  174. 481  LPRINT" ":LPRINT"   #   GROUP-LABEL   SIZE"
  175. 482  FOR J=1 TO NG:LPRINT USING G$;J;L(J);N(J):NEXT J:LPRINT USING SPACE$(13)+H$;N
  176. 483  LPRINT" ":LPRINT"DATA NOW:":FOR I= 1 TO N
  177. 484  LPRINT"Row"STR$(I)": ";:FOR J=1 TO M:LPRINT X(GP(I-1),J);:NEXT J:LPRINT
  178. 485  NEXT I:LPRINT" ":LPRINT STRING$(79,"=");STRING$(3,10)
  179. 486  GOTO 10
  180. 487  'end
  181.