1000 DEFINT A-Z
1010 ON ERROR GOTO 3760
1020 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,

	C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),

	SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
1040 NK=0:DIM S(NC,4)		'field #, num?, length, pad?
1050 Y=T2-T1+1
1060 DIM D(Y)
1070 X=INT(LOG(Y)/LOG(2))
1080 DIM LST(X),HST(X)		'lo and hi stacks
1090 '


				ENTER HERE TO RE-SPECIFY


1100 GOSUB 4010
1110 D$(0)="":ERASE D$:DIM D$(T2-T1+1)	' do here for recycle (erased below)
1120 PRINT"SORT -- March 20, 1982
1125 ' by Dan Dugan -- public domain
1130 PRINT:PRINT"Arranges a selected set of records in numerical or alphabetical order.
1140 PRINT"To quit this activity, enter 'x' in response to a 'y/n' question.
1150 IF T1=1 AND T2=N THEN GOTO 1200
1160 PRINT:PRINT"Shall the output include the records outside the range sorted? (n/y) ";
1170 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="n"
1180 PRINT A$: IF A$="y" THEN S9=1
1190 IF A$="x" THEN 3400
1200 PRINT
1210 PRINT"Please define the key fields for sorting in '"F$".'  The fields are:
1220 PRINT: GOSUB 4190 ' show
1230 PRINT"The file will be re-arranged according to the contents of the key fields.
1240 PRINT"Enter the primary key field number first, then any others you wish to
1250 PRINT"be sorted within that order, etc.
1260 S6=1:KLEN=0:KLENFLAG=0 ' any alph field will change S6 to 0; key length
1270 PRINT:FOR I=1 TO NC
1280	PRINT I;".  ";:

	INPUT"Enter field number of key field (0 when done) ";S(I,1)
1290	IF S(I,1)=0 THEN 1420
1300	IF S(I,1)<1 OR S(I,1)>NC THEN PRINT"Field"S(I,1)"???  Enter again."

		GOTO 1280
1310	S(I,2)=0:IF RIGHT$(N$(S(I,1)),1)="n" THEN S(I,2)=1 ELSE S6=0
1320		'(if just one is alpha, do alpha sort)
1330	INPUT"Number of characters in field to use (RETURN for all)";S(I,3)
1332	IF S(I,3) THEN 1334 ELSE 1340
1334	S(I,4)=0:PRINT"Do you want to pad shorter fields to that length? (n/y) ";

		:A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n"
1335	PRINT A$:IF A$="y" THEN S(I,4)=1
1340	IF S(I,3) THEN 1350 ELSE PRINT"You want to sort on all characters of ";

		:GOTO 1360
1350	PRINT"You want to sort on the first"S(I,3)"characters of ";
1360	PRINT LEFT$(N$(S(I,1)),4)"? (y/n) ";:

		A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y"
1370	PRINT A$:IF A$="x" THEN 3400
1380	IF A$<>"y" THEN PRINT"Entry cancelled; ready for key"I"again.":GOTO 1280
1390	IF S(I,3) THEN KLEN=KLEN+S(I,3) ELSE KLEN=KLEN+10:KLENFLAG=1
1400	PRINT
1410 NEXT I
1420 NK=I-1
1430 IF S(1,1)=0 THEN 3400	'quit
1440 PRINT:PRINT"Ascending order? (y/n) ";
1450 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="y"
1460 PRINT A$: IF A$="n" THEN S8=1
1470 IF A$="x" THEN 3400
1480 '


		OUTPUT SWITCH (P7)


1490 P7=0
1500 PRINT:PRINT"Shall the product of the sort overlay the original file? (y/n) ";
1510 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="y"
1520 PRINT A$:IF A$="x" THEN 3400
1530 IF A$="n" THEN P7=1:GOTO 1600
1540 IF A$<>"y" THEN 1500
1550 '

		YES, OVERLAY


1560 IF (T1=1 AND T2=N) OR S9=1 THEN 1630
1570 PRINT:PRINT"NOT ALLOWED - Overlaying part of file on file will erase records
1580 PRINT"outside of range.": PRINT:GOTO 1480
1590 '


		NAME OUTPUT FILE


1600 PRINT:INPUT"Name of sort product file (no prefix or suffix) ";F2$
1610 IF F2$="" THEN 1480
1620 X$=F2$:GOSUB 3920:F2$=Y$ ' ucv
1630 '


				SHOW SORT SET-UP


1640 GOSUB 4010 'cs
1650 PRINT"SETUP FOR SORT
1660 PRINT: IF T1=1 AND T2=N THEN PRINT"Sort all records ("N")": GOTO 1710
1670 PRINT"Sorting range of records from"T1"to"T2"
1680 ON S9+1 GOTO 1690,1700
1690	PRINT"The output will be the range of records only.": GOTO 1710
1700	PRINT"The output will be the entire file with the selected range sorted.
1710 PRINT:PRINT"Records will be put in order by examining":

	PRINT"the contents of the sort key fields."
1720 PRINT:FOR I=1 TO NK
1730	PRINT TAB(29);:PRINT USING"##";I;:

	PRINT".  "LEFT$(N$(S(I,1)),4);
1740	PRINT TAB(40);:IF S(I,3) THEN PRINT S(I,3) ELSE PRINT" all"
1750 NEXT I
1760 PRINT:IF KLENFLAG THEN 1762 ELSE 1766
1762 PRINT"ESTIMATED string space needed for the key array is"KLEN*(T2-T1+1):

	GOTO 1768
1766 PRINT"String space needed for the key array is"KLEN*(T2-T1+1)
1768 PRINT"and the available space is"FRE(X$)".
1770 PRINT"This program can't tell whether there is enough space on disk "

	DD$(5)" for tempo-
1780 PRINT"rary storage of the key array.
1790 PRINT:PRINT"The records will be sorted in ";
1800 IF S8=0 THEN PRINT"ascending ";: GOTO 1820
1810 PRINT"descending ";
1820 IF S6=0 THEN PRINT"alphabetical ";: GOTO 1840
1830 PRINT"numerical ";
1840 PRINT"order."
1850 PRINT: PRINT"The output of the sort will ";
1860 IF P7=0 THEN PRINT"overlay the original file.":GOTO 1880
1870 PRINT"create a new DIMS file "F2$" on disk "DD$(4)"."
1880 PRINT:IF P7=0 AND (T1<>1 OR T2<>N) AND S9=0 THEN

	PRINT"You are aware that this process will erase records?
1885 IF P7 THEN 1890 ELSE 1900
1890 PRINT"The new file "F2$" will replace the safety copy of "F$".
1892 PRINT"You must then use PIP to move "F2$" to another disk,
1894 PRINT"and use the DEDIT 'backup' command on "F$" to re-create a
1896 PRINT"safety copy.
1900 '


				FINAL APPROVAL


1910 PRINT:PRINT"Is this exactly what you want? (y/n) ";
1920 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="y"
1930 PRINT A$
1940 IF A$="x" THEN 3400
1950 IF A$="n" THEN PRINT"Try again.":GOTO 1090
1960 IF A$<>"y" THEN GOTO 1910
1970 GOTO 2110
1980 '


				SORT CONTROLS GUIDE


1990 ' S() array holds key orders (field#, num? (1=num), length, pad?)
2000 ' NK = number of keys specified
2010 ' S6 = 0 alpha sort
2020 '      1 numeric sort
2030 ' S7 = 0 don't rename dupe file
2040 '      1 rename dupe file as F2$.D
2050 ' S8 = 0 ascending order
2060 '      1 descending order
2070 ' S9 = 0 output only sorted range of records
2080 '      1 output records above and below sorted range
2090 ' P7 = 0 overlay main file
2100 '      1 output to named file
2110 '


				PUT KEYS IN TEMP FILE


2120 GOSUB 4010
2130 PRINT"SORTING '"F$"'
2140 PRINT:PRINT"Extracting keys.":PRINT
2150 OPEN"O",3,DD$(5)+"KEYS.$$$"
2160 FOR I=T1 TO T2
2170	GOSUB 4270:GOSUB 4110 ' get record
2180	IF ASC(T$)=0 THEN X$=CHR$(126)+"(del)":GOTO 2320 ' sorts deletes to end
2190	GOSUB 3540 ' parse
2200	X$=""
2210	FOR X=1 TO NK
2220		IF S(X,3) THEN 2230 ELSE X$=X$+B$(S(X,1)):GOTO 2280
2230		Z$=LEFT$(B$(S(X,1)),S(X,3))
2240		Y=LEN(Z$)
2250		IF S(X,2)=1 THEN

			Y$=STRING$(S(X,3)-Y,CHR$(48)):

			X$=X$+Y$+Z$:GOTO 2280	'pad num field with left 0's
2252		IF S(X,4) THEN 2260 ELSE Y$="":GOTO 2270
2260		Y$=STRING$(S(X,3)-Y,CHR$(32))	'spaces to pad right
2270		X$=X$+Z$+Y$
2280	NEXT
2290	IF X$="" THEN X$=CHR$(126):GOTO 2320 ' makes empties go later
2300	IF S6 THEN 2320
2310	GOSUB 3920:X$=Y$	'ucv
2320	PRINT I,X$
2330	PRINT#3,X$
2340 NEXT
2350 CLOSE 3
2360 '

				LOAD INDEX AND KEY ARRAYS


2370 PRINT:PRINT"Loading key array:":PRINT
2380 OPEN"I",3,DD$(5)+"KEYS.$$$"
2390 I=T1:J=1:D$(0)=CHR$(0)
2400 IF EOF(3) THEN 2450
2410	LINE INPUT#3,D$(J)
2420	D(J)=I
2430	I=I+1:J=J+1
2440 GOTO 2400
2450 CLOSE 3
2460 KILL DD$(5)+"KEYS.$$$"
2470 '


				READY TO SORT ARRAY


2480 PRINT:PRINT"Sorting array.":PRINT
2490 ' from QUICKSORT by Sylvan Rubin DDJ #33 p.42
2500 LND=1:HND=J-1:STP=0
2510 '

	PARTITION


2520 GOSUB 4270		'exit
2530 IF LND>=HND THEN 2910 ' pop stack
2540 PRINT CHR$(80);:CTR=INT((LND+HND+1)/2) ' use center for pivot
2550 SWAP D(CTR),D(HND):SWAP D$(CTR),D$(HND)
2560 LO=LND-1:HI=HND
2570 PIV$=D$(HND):GOTO 2600 ' scan-l
2580 '

	EXCHANGE


2590 SWAP D(LO),D(HI):SWAP D$(LO),D$(HI)
2600 '

	SCAN-L


2610 LO=LO+1:ON S6+1 GOTO 2620,2630 ' alph, num
2620 ON S8+1 GOTO 2640,2650 ' asc, desc
2630 ON S8+1 GOTO 2660,2670
2640 IF D$(LO)<PIV$ THEN 2610 ELSE 2680
2650 IF D$(LO)>PIV$ THEN 2610 ELSE 2680
2660 IF VAL(D$(LO))<VAL(PIV$) THEN 2610 ELSE 2680
2670 IF VAL(D$(LO))>VAL(PIV$) THEN 2610 ELSE 2680
2680 '

	SCAN-H


2690 HI=HI-1:ON S6+1 GOTO 2700,2710
2700 ON S8+1 GOTO 2720,2730
2710 ON S8+1 GOTO 2740,2750
2720 IF D$(HI)>PIV$ THEN 2690 ELSE 2760
2730 IF D$(HI)<PIV$ THEN 2690 ELSE 2760
2740 IF VAL(D$(HI))>VAL(PIV$) THEN 2690 ELSE 2760
2750 IF VAL(D$(HI))<VAL(PIV$) THEN 2690 ELSE 2760
2760 IF LO<=HI THEN 2590
2770 '

	SWAP PIVOT


2780 SWAP D(LO),D(HND):SWAP D$(LO),D$(HND)
2790 '

	PUSH STACK


2800 IF (HI+1-LND)>(HND-LO) THEN 2860 ' stack low
2810 '

	STACK HIGH


2820 IF LO+2>HND THEN 2840
2830 STP=STP+1:LST(STP)=LO+1:HST(STP)=HND
2840 '

	SHIFT HIGHEND


2850 HND=HI:GOTO 2510 ' partition
2860 '

	STACK LOW


2870 IF LND+1>HI THEN 2900 ' shift lowend
2880 STP=STP+1:LST(STP)=LND:HST(STP)=HI
2890 '

	SHIFT LOWEND


2900 LND=LO+1:GOTO 2510 ' partition
2910 '

	POP STACK


2920 IF STP=0 THEN 2950 ' done
2930 LND=LST(STP):HND=HST(STP)
2940 STP=STP-1:GOTO 2510 ' partition
2950 PRINT:PRINT:PRINT"Array sorted.
2960 '


				OUTPUT


2970 NR=0 ' counts number of records in product file
2980 CLOSE 2:KILL DD$(4)+F$+".DD"+FT$:GOSUB 4080
2990 IF S9=0 GOTO 3060
3000 '


				COPY BLOCK BELOW T1


3010 IF T1=1 THEN 3060
3020 PRINT:PRINT"Outputting records below range.
3030 FOR I=1 TO T1-1
3040	GOSUB 3430 'output record
3050 NEXT
3060 '


				MOVE RECORDS PER INDEX ARRAY


3070 PRINT:PRINT"Now moving records from "

	DD$(3)" to "DD$(4)" in sorted order per index array.":PRINT
3080 ERASE D$ ' don't need strings
3090 FOR J=1 TO T2-T1+1
3100	I=D(J):GOSUB 3430
3110 NEXT
3120 '


				COPY BLOCK ABOVE


3130 IF S9=0 OR T2=N THEN 3180 ' skip block copy
3140 PRINT:PRINT"Outputting records above range
3150 FOR I=T2+1 TO N
3160	GOSUB 3430 ' output
3170 NEXT
3180 '



				SAVE HEADER AND TIDY UP


3190 PRINT:PRINT"Saving header;"NR"records
3200 T$=""
3210 I=0
3220 I=I+1
3230	T$=T$+N$(I)+CHR$(126)
3240	IF LEFT$(N$(I),4)="stop" THEN 3260
3250 GOTO 3220
3260 T$=T$+STR$(NR)+CHR$(126) ' NR at end
3270 NR=0 ' for header
3280 GOSUB 3470 ' put it
3290 PRINT"!"
3300 IF P7 THEN 3330	'rename product
3310 GOSUB 3620 ' copy dupe to main
3320 GOTO 3380
3330 '


		RENAME OUTPUT FILE


3340 CLOSE 2:NAME DD$(4)+F$+".DD"+FT$ AS DD$(4)+F2$+".D"+FT$:GOSUB 4080
3350 PRINT"Product file "F2$" is now on disk "DD$(4)" (backup erased).
3360 PRINT"After moving product to desired disk, use 'backup' command on "F$
3370 INPUT"to restore safety copy.  Hit RETURN to continue.    ";A$
3380 PRINT:PRINT:PRINT"Sort completed
3390 PRINT CHR$(7); 'beep
3400 '


				RETURN TO DEDIT


3410 PRINT:PRINT"Re-loading DEDIT.
3420 CHAIN DD$(1)+"DEDIT",1000
3430 '




				(SUB) OUTPUT RECORD "I"


3440 GOSUB 4110:PRINT T$ ' get rec I
3450 GOSUB 4270 ' exit
3460 NR=NR+1 ' # records in prod. file
3470 '


		PUT RECORD NR


3480 ON FT GOTO 3510,3490
3490 LSET S$=MID$(T$,129)
3500 PUT #2,FT*NR+2
3510 LSET S$=LEFT$(T$,128)
3520 PUT #2,FT*NR+1
3530 RETURN
3540 '




				(SUB) PARSE STRING


3550 K=0
3560 J=INSTR(T$,CHR$(126)) ' delimiter
3570 IF J=0 THEN RETURN
3580 K=K+1
3590 B$(K)=MID$(T$,1,J-1)
3600 T$=MID$(T$,J+1)
3610 GOTO 3560
3620 '



				(SUB) ERASE ORIGINAL FILE AND COPY DUP TO ORIG


3630 CLOSE
3640 PRINT
3650 KILL DD$(3)+F$+".D"+FT$
3660 PRINT"Copying dupe, overlaying original file.":PRINT
3670 GOSUB 4040 ' open both files
3680 FOR J=1 TO FT*(N+1)
3690	GET #2,J
3700	PRINT"&";
3710	LSET R$=S$
3720	PUT #1,J
3730	PRINT"*";
3740 NEXT J
3750 RETURN
3760 '



				ERROR HANDLING


3770 IF ERR=61 THEN RESUME 3780 ELSE 3810
3780	PRINT"Sorry - process halted because there isn't enough disk space
3790	PRINT"for the key file.
3800	INPUT"Hit return to recover.";A$:CLOSE:T=8:CHAIN DD$(1)+"DIMS",1000
3810 IF ERR=7 OR ERR=14 THEN RESUME 3820 ELSE 3850
3820	PRINT"Sorry - process halted because key array needed more memory
3830	PRINT"than is available.  Try again with shorter key specifications.
3840	INPUT"Hit return to try again.";A$:GOTO 1090
3850 IF ERR=58 THEN RESUME 3860 ELSE 3910
3860	PRINT"Sorry - file named "F2$" already exists.
3870	INPUT"Enter another name for the output file here:  ";X$
3880	IF X$="" THEN 3870
3890	GOSUB 3920:F2$=Y$	'ucv
3900	GOTO 3330
3910 ON ERROR GOTO 0
3920 '



				(SUB) UCV


3930 Y$=""
3940 FOR J=1 TO LEN(X$)
3950	Y$=Y$+" "
3960	X=ASC(MID$(X$,J,1))
3970	IF 96<X AND X<123 THEN MID$(Y$,J,1)=CHR$(X-32): GOTO 3990
3980	MID$(Y$,J,1)=MID$(X$,J,1)
3990 NEXT
4000 RETURN
4010 '



				(SUB) CLEAR SCREEN(TERM DEP)


4020 PRINT CHR$(12)
4030 RETURN
4040 '


				(SUB) OPEN UP FILES


4050 CLOSE
4060 OPEN"R",1,DD$(3)+F$+".D"+FT$
4070 FIELD #1,128 AS R$
4080 OPEN"R",2,DD$(4)+F$+".DD"+FT$
4090 FIELD #2,128 AS S$
4100 RETURN
4110 '



				(SUB) GET RECORD "I" IN T$


4120 T$=""
4130 ON FT GOTO 4160,4140
4140	GET#1,FT*I+2 ' latter half
4150	T$=LEFT$(R$,127)
4160	GET#1,FT*I+1
4170	T$=R$+T$
4180 RETURN
4190 '



				(SUB) SHOW FIELDS


4200 FOR J=1 TO NC
4210	IF C(J)=0 THEN 4240
4220	PRINT TAB(29);
4230	PRINT USING"##";J;:PRINT".  "LEFT$(N$(J),4)"  "RIGHT$(N$(J),1)
4240 NEXT
4250 PRINT
4260 RETURN
4270 '


				(SUB) EXIT TEST


4280 X$=INKEY$
4282 IF X$<>CHR$(27) THEN RETURN
4290 PRINT:PRINT"Process paused by ESCAPE from keyboard.
4300 PRINT"Do you want to continue (y,n or x) ? ";
4310 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y"
4320 PRINT A$:IF A$="x" THEN CLOSE 3:GOTO 3400
4330 IF A$<>"y" THEN CLOSE 3:GOTO 1090
4340 RETURN
 A$=CHR$(13) THEN A$="y"
4320 PRINT A$:IF A$="x" THEN CLOSE 3:GOTO