| 70 |
GOSUB 7490 :CHAIN "X:ADBCHN.PRG",70 |
| 260 |
POKE 12348,16:CLEAR A:B=G |
| 270 |
P=S(0,L):IF M$(0)<D$(P,L) LET R=0:RETURN |
| 280 |
R=INT ((A+B)/2) |
| 290 |
P=S(R,L) |
| 300 |
IF D$(P,L)=M$(0) GOTO 340 |
| 310 |
IF B-A=1 LET R=R+1:P=S(R,L):RETURN |
| 320 |
IF D$(P,L)<M$(0) LET A=R:GOTO 280 |
| 330 |
B=R:GOTO 280 |
| 340 |
IF R IF D$(S(R-1,L),L)=M$(0) LET R=R-1:P=S(R,L):GOTO 340 |
| 350 |
RETURN |
| 370 |
L=2:CLEAR A:B=G:IF M$(0)="" CLEAR U,V:GOTO 400 |
| 380 |
U=VAL LEFT$ (M$(0),2):V=VAL MID$ (M$(0),4,2):W=1900:GOSUB 490 |
| 390 |
IF F5 GOSUB 6510 :GOTO 360 |
| 400 |
W=U+V*31 |
| 410 |
P=S(0,2):IF W<VAL LEFT$ (D$(P,5),2)+31*VAL MID$ (D$(P,5),4,2) LET R=0:RETURN |
| 420 |
R=INT ((A+B)/2):P=S(R,2):H=VAL LEFT$ (D$(P,5),2)+31*VAL MID$ (D$(P,5),4,2) |
| 430 |
IF H=W GOTO 470 |
| 440 |
IF B-A=1 LET R=R+1:P=S(R,L):RETURN |
| 450 |
IF H<W LET A=R:GOTO 420 |
| 460 |
B=R:GOTO 420 |
| 470 |
IF R LET H=S(R-1,2):IF VAL LEFT$ (D$(H,5),2)+31*VAL MID$ (D$(H,5),4,2)=W LET P=H:R=R-1:GOTO 470 |
| 480 |
RETURN |
| 2410 |
GOSUB 7490 :CHAIN "X:PFLEGADB.CHN",2410 |
| 3410 |
IF F7 OR F6>=G GOTO 3690 |
| 3420 |
IF F6 GOTO 3470 |
| 3430 |
RESTORE 3450 :GOTO 7290 |
| 3450 |
DATA 1,"Keine neuen Daten !" |
| 3460 |
DATA 2,"Sortieren",3690,"DATENPFLEGE",2410,"MENU",70 |
| 3470 |
USING "####":PRINT 0;" % einsortiert":D=3*F6:Z=0 |
| 3480 |
FOR I=F6 TO 1STEP -1 |
| 3490 |
FOR L=0 TO 2 |
| 3500 |
M$(0)=D$(G-I+1,L):IF L=2 LET M$(0)=LEFT$ (D$(G-I+1,5),5):GOSUB 370 :GOTO 3520 |
| 3510 |
GOSUB 260 |
| 3520 |
ON L GOTO 3530 ,3550 |
| 3530 |
IF D$(P,L)=M$(0) GOTO 3630 |
| 3540 |
GOTO 3560 |
| 3550 |
IF LEFT$ (D$(P,5),5)=M$(0) GOTO 3650 |
| 3560 |
FOR J=G-I TO R STEP -1:S(J+1,L)=S(J,L):NEXT J |
| 3570 |
S(R,L)=G-I+1 |
| 3580 |
Z=Z+1:CURSOR 0,0:PRINT Z/D*100 |
| 3590 |
NEXT L:NEXT I |
| 3600 |
CLEAR F6:USING |
| 3610 |
IF F8 GOTO 4180 |
| 3620 |
GOTO 40 |
| 3630 |
IF D$(P,NOT L+2)<D$(G-I+1,NOT L+2) LET R=R+1:P=S(R,L):IF R<G GOTO 3530 |
| 3640 |
GOTO 3560 |
| 3650 |
IF D$(P,0)<D$(G-I+1,0) LET R=R+1:P=S(R,L):IF R<G GOTO 3550 |
| 3660 |
GOTO 3560 |
| 3670 |
E=0:G=-1:F9=1:GOSUB 4480 :CLEAR F6,F9 |
| 3680 |
CLS :PRINT "Bitte Daten eingeben !":GOSUB 6300 :GOTO 2460 |
| 3690 |
D=3*(G+1)^2:Z=0:USING "####.#":PRINT 0;" % sortiert |
| 3710 |
FOR L=0 TO 1:FOR I=0 TO G:K=0:FOR J=0 TO G |
| 3720 |
IF D$(J,L)<=D$(I,L) LET K=K+1:IF D$(I,L)=D$(J,L) GOSUB 3830 |
| 3730 |
Z=Z+1:CURSOR 0,0:PRINT Z/D*100 |
| 3740 |
NEXT J:S(K,L)=I:NEXT I:NEXT L |
| 3750 |
FOR I=0 TO G:K=0:FOR J=0 TO G |
| 3760 |
U=VAL MID$ (D$(I,5),4,2)*31+VAL LEFT$ (D$(I,5),2) |
| 3770 |
V=VAL MID$ (D$(J,5),4,2)*31+VAL LEFT$ (D$(J,5),2) |
| 3780 |
IF V<=U LET K=K+1:IF U=V GOSUB 3830 |
| 3790 |
Z=Z+1:CURSOR 0,0:PRINT Z/D*100 |
| 3800 |
NEXT J:S(K,2)=I:NEXT I |
| 3810 |
USING :CLEAR F7,F6:IF F8 GOTO 4180 |
| 3820 |
GOTO 40 |
| 3830 |
O=-1:K=K-1:IF I=J RETURN |
| 3840 |
O=O+1:IF O=4 GOSUB 3880 :RETURN |
| 3850 |
IF D$(I,O)=D$(J,O) GOTO 3840 |
| 3860 |
IF D$(J,O)<D$(I,O) LET K=K+1 |
| 3870 |
RETURN |
| 3880 |
IF I<J LET K=K+1 |
| 3890 |
IF L OR I>J RETURN |
| 3900 |
BEEP 1,255,200 |
| 3910 |
CLS :PRINT "Doppelter Datensatz:":GOSUB 6300 |
| 3920 |
P=I:GOSUB 690 |
| 3930 |
PRINT " % sortiert":CURSOR 0,0:PRINT Z/D*100 |
| 3940 |
RETURN |
| 7290 |
CLS :READ F0:IF F0 READ M$(0):PRINT M$(0) |
| 7300 |
X=0:Y=F0:READ N:Q=INT (N/(4-F0)):S=16-4*Q |
| 7310 |
FOR I=0 TO N:J=INT (I/(4-F0)):CURSOR J*S,I-(4-F0)*J+F0:READ M$(0),Z(I) |
| 7320 |
PRINT " ";LEFT$ (M$(0),S+6-8*SGN Q):NEXT I |
| 7330 |
K=Y-F0+(4-F0)*X:IF K>N LET X=Q:Y=F0+N-(4-F0)*X:K=N |
| 7340 |
CURSOR X*S,Y:PRINT "->" |
| 7350 |
T=ASC INKEY$ :IF T=0 GOTO 7350 |
| 7360 |
BEEP 1,1,25 |
| 7370 |
IF T=5 CURSOR X*S,Y:PRINT " ":Y=Y+1:IF Y>3 LET Y=F0:X=X+1:IF X>Q CLEAR X |
| 7380 |
IF T=4 CURSOR X*S,Y:PRINT " ":Y=Y-1:IF Y<F0 LET Y=3:X=X-1:IF -X CLEAR X |
| 7390 |
IF T=14 CURSOR X*S,Y:PRINT " ":X=X+1:IF X>Q CLEAR X |
| 7400 |
IF T=15 CURSOR X*S,Y:PRINT " ":X=X-1:IF X<0 LET X=Q |
| 7410 |
IF T=13 CLS :CLEAR X,Y:GOTO Z(K) |
| 7420 |
GOTO 7330 |
| 7490 |
RESTORE 7500 :GOTO 7290 |
| 7500 |
DATA "Externer Programmteil !",1,"CE-140F o.k.",7510,"Abbruch",7520 |
| 7510 |
RETURN |
| 7520 |
CLS :END |
