10 REM ******************************
20 REM * Register, sortera  Ver 2.0
30 REM * Bos Engborg 850303
40 REM * <2369>
50 REM * Namn -regsort-             *
60 REM ******************************
61 REM Sorteringsrutinen ur 'ABC om programmering och dokumentation'
70 REM Variabler 
80 REM v$,registernamn
90 REM m%,antal rader i register
100 REM m0%,radbredd
110 REM x%,antal element max att sortera,(max p} varje bokstav)
120 GOSUB 140 : GOSUB 250 : GOTO 330
130 REM **** registerutskrift ****
140 REM ** input register data **
150 DIM V$=30%
160 OPEN 'dr1:register.dta' ASFILE 1
170 INPUTLINE #1,V$ : V$=LEFT$(V$,LEN(V$)-2%)
180 INPUT #1,M%
190 INPUT #1,M0%
200 CLOSE 1
210 X%=PEEK(65063%)+PEEK(65064%)*256-PEEK(65056%)-PEEK(65057%)*256-300%
220 X%=(X%/M%/(M0%+6%))-10%
230 RETURN 
240 REM 
250 REM ** huvud 40 **
260 ; INP(3)CHR$(12)
270 ; CUR(0%,10%)'REGISTER  '
280 ; TAB(1%)V$
290 ; CUR(2,1%)'Max sortering av element'X%
300 ; CUR(3%,0%)CHR$(151%)STRING$(39%,35%);
310 ; CUR(19%,0%)CHR$(151%)STRING$(39%,35%);
320 RETURN 
330 REM 
340 REM 
350 DIM N1%(5%),N%(5%,5%),A$=5%,U0$=26%,U1$=82%,W$=2%,S3$=2%,S4$=2%
360 DIM B$(M%-1%)=M0%,B1$(X%,M%-1%)=M0%,X$=M0%,S1$=M0%,S2$=M0%
370 ; CUR(2%,0%)
380 FOR I%=1% TO M%
390 ; : ; I%'....'
400 NEXT I%
410 ; : ; M%+1%'.. 01234567890....AaBbCcDdEeFfGgHhIi'
420 ; : ; M%+2%'.. AaBbCcDdEeFfGg.......0123456789'
430 ; : ; M%+3'.. 000111222333444555666777888999'
440 ; CUR(20%,1%)'Sortera enl ('M%+1%'-'M%+3%')'; : GET W$ : ; W$;
450 IF ASC(W$)-48%<M%+1% OR ASC(W$)-48%>M%+3% THEN 440
460 IF ASC(W$)-48=M%+1% THEN U1$='0123456789AaBbCcDdEe@`FfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUu^~VvWwXxYyZz]}[{\|'
470 IF ASC(W$)-48=M%+2% THEN U1$='AaBbCcDdEe@`FfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUu^~VvWwXxYyZz]}[{\|0123456789'
480 IF ASC(W$)-48=M%+3% THEN U1$='000000000000111111111111222222222222333333444444555555666666777777888999'
490 ONERRORGOTO 490
500 ; CUR(21%,1%)'Vilken rad skall sorteras (1-'M%')'; : INPUT S9%
510 ONERRORGOTO 0
520 IF S9%<1 OR S9%>M% THEN 500 : S9%=S9%-1%
530 OPEN 'dr1:register.'+A$ ASFILE 6
540 INPUT #6,A%
550 CLOSE 6
560 GOSUB 250
570 ; CUR(22%,1%)'V{nta !!!!!!!!!!!!!'
580 FOR I%=1% TO 5% : PREPARE 'DR1:'+NUM$(I%)+'.ALF' ASFILE I% : NEXT I%
590 OPEN 'dr1:poster.'+A$ ASFILE 6
600 FOR Y%=1% TO A%
610 FOR B%=0% TO M%-1%
620 INPUTLINE #6,B$(B%) : B$(B%)=LEFT$(B$(B%),LEN(B$(B%))-2%)
630 NEXT B%
640 Z%=0% : Z%=INSTR(1%,U1$,LEFT$(B$(S9%),1%))
650 IF Z% 670
660 GOTO 770
670 Q%=INT((Z%-1%)/12)+1%
680 IF Q%=6% THEN Q%=5%
690 FOR B%=0% TO M%-1%
700 ; #Q%,B$(B%)
710 NEXT B%
720 N1%(Q%)=N1%(Q%)+1%
730 ; CUR(20%,1%)'Fil'Q%' antal 'RIGHT$(NUM$(1000+N1%(Q%)),3%)' r{knare 'RIGHT$(NUM$(1000+Y%),3%);
740 FOR J1%=1% TO 5%
750 ; CUR(3%+J1%,5%)'#'J1%' 'RIGHT$(NUM$(1000%+N1%(J1%)),3%)
760 NEXT J1%
770 NEXT Y%
780 FOR J1%=1% TO 5% : CLOSE J1% : NEXT J1%
790 A1%=0%
800 GOSUB 250
810 ; CUR(22%,1%)'V{nta !!!!'
820 FOR J%=1% TO 5% : OPEN 'dr1:'+NUM$(J%)+'.alf' ASFILE 6
830 IF J%=5% THEN L0%=24% ELSE L0%=12%
840 U0$=MID$(U1$,J%*12%-11%,L0%)
850 ; CUR(4%,1%)U0$
860 FOR I%=1% TO 5% : PREPARE 'dr1:'+NUM$(J%*10+I%)+'.alf' ASFILE I% : ; #I%,' ' : CLOSE I% : NEXT I%
870 FOR I%=1% TO 5% : OPEN 'DR1:'+NUM$(J%*10+I%)+'.ALF' ASFILE I% : NEXT I%
880 FOR I%=1% TO N1%(J%)
890 A1%=A1%+1% : REM r{knare
900 FOR B%=0% TO M%-1%
910 INPUTLINE #6,X$ : B$(B%)=LEFT$(X$,LEN(X$)-2%)
920 NEXT B%
930 Z%=0% : Z%=INSTR(1%,U0$,LEFT$(B$(S9%),1%))
940 IF Z% THEN 960
950 GOTO 1060
960 Q%=INT((Z%-1%)/(L0%/6))+1%
970 IF Q%=6% THEN Q%=5%
980 FOR B%=0% TO M%-1%
990 ; #Q%,B$(B%)
1000 NEXT B% : N%(J%,Q%)=N%(J%,Q%)+1%
1010 Q1%=J%*10+Q%
1020 ; CUR(20%,1%)'Fil nr';Q1%;' antal 'RIGHT$(NUM$(1000%+N%(J%,Q%)),3%)' r{knare'A1%
1030 FOR B%=1% TO 5%
1040 ; CUR(4%+J%,(B%-1%)*8%+1%)'#'RIGHT$(NUM$(100%+J%*10+B%),3%)' 'RIGHT$(NUM$(1000%+N%(J%,B%)),3%)
1050 NEXT B%
1060 NEXT I%
1070 CLOSE 6% : KILL 'dr1:'+NUM$(J%)+'.alf' : NEXT J%
1080 FOR I%=1% TO 5% : CLOSE I% : NEXT I%
1090 ; CUR(22%,1%)'Sorterar !!!!!!!!!!!!      '
1100 PREPARE 'dr1:poster.'+A$ ASFILE 1
1110 A1%=0%
1120 FOR J%=1% TO 5% : FOR J1%=1% TO 5%
1130 OPEN 'dr1:'+NUM$(J%*10+J1%)+'.alf' ASFILE 2
1140 FOR I%=1% TO N%(J%,J1%)
1150 A1%=A1%+1%
1160 ; CUR(20%,1%)'Fil'J%*10+J1%' antal 'RIGHT$(NUM$(1000+N%(J%,J1%)),3%)' r{knare 'RIGHT$(NUM$(1000+A1%),3%)
1170 FOR B%=0% TO M%-1%
1180 INPUTLINE #2,B1$(I%,B%) : B1$(I%,B%)=LEFT$(B1$(I%,B%),LEN(B1$(I%,B%))-2%)
1190 NEXT B%
1200 NEXT I%
1210 M1%=N%(J%,J1%)
1220 M1%=INT(M1%/2)
1230 IF M1%=0% THEN 1490
1240 N1%=N%(J%,J1%)-M1%
1250 FOR L%=1% TO N1%
1260 L1%=L%
1270 K%=L1%+M1%
1280 REM if satser
1290 S1$=B1$(L1%,S9%) : S2$=B1$(K%,S9%)
1300 IF S1$=S2$ THEN S%=0% : GOTO 1390
1310 S1%=LEN(S1$) : S2%=LEN(S2$)
1320 S3%=0%
1330 S3%=S3%+1%
1340 IF S3%>S1% THEN S%=2% : GOTO 1390
1350 IF S3%>S2% THEN S%=1% : GOTO 1390
1360 S3$=MID$(S1$,S3%,1%) : S4$=MID$(S2$,S3%,1%)
1370 IF S3$=S4$ THEN 1330
1380 S%=(INSTR(1%,U1$,S3$)>INSTR(1%,U1$,S4$))+2%
1390 IF S%=2% 1460 ELSE IF S%=0 B1$(I%,S%)='xxxxxxxxxxxx'
1400 FOR B%=0% TO M%-1%
1410 X$=B1$(L1%,B%) : B1$(L1%,B%)=B1$(K%,B%) : B1$(K%,B%)=X$
1420 NEXT B%
1430 L1%=L1%-M1%
1440 IF L1%<1% THEN 1460
1450 GOTO 1270
1460 NEXT L%
1470 GOTO 1220
1480 CLOSE 2
1490 REM sortering slut
1500 FOR I%=1% TO N%(J%,J1%)
1510 FOR B%=0% TO M%-1%
1520 ; #1,B1$(I%,B%)
1530 NEXT B%
1540 NEXT I%
1550 KILL 'dr1:'+NUM$(J%*10+J1%)+'.alf'
1560 NEXT J1% : NEXT J%
1570 CLOSE 1
1580 ; CUR(23%,1%)'Klart !!!!!!!!!!!!!!!!!!!!!!!!'; : FOR I=0 TO 5000 : NEXT I
1590 CHAIN 'register'