|
DataMuseum.dkPresents historical artifacts from the history of: MIKADOS |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about MIKADOS Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 7488 (0x1d40)
Types: TextFile
Notes: Mikados_K
Names: »SORTKUND.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »SORTKUND.K«
PROGRAM SORTKUND;
CONST NR=100;
TYPE
POST=RECORD
NR1,NR2:INTEGER;
FNAVN:PACKED ARRAY (1..4) OF CHAR;
KEY:PACKED ARRAY (1..26) OF CHAR;
UNAVN:PACKED ARRAY (1..30) OF CHAR;
ADR:PACKED ARRAY (1..30) OF CHAR;
LANDSBY:PACKED ARRAY (1..20) OF CHAR;
POSTNR:PACKED ARRAY (1..25) OF CHAR;
TLF:PACKED ARRAY (1..10) OF CHAR
END;
PROCSTAT=RECORD
NP,NROSTART:INTEGER
END;
NPFILE=FILE OF PROCSTAT;
VAR FIL:STRING(20);
NRPF,CF:NPFILE;
NRR:INTEGER;
T:FILE OF POST;
OKEY:PACKED ARRAY (1..26) OF CHAR;
QUQ:^INTEGER;
POSTER:ARRAY (1..NR) OF POST;
PROCEDURE SORT(VAR NROWF:INTEGER);
VAR O,I,J,AIP,AUP,REST,CAP,ACTIVE
:INTEGER;
ST:FILE OF POST;
IND:ARRAY (1..NR) OF INTEGER;
BEGIN
IND(1):=1;
IND(NR):=NR;
CAP:=NR-1;
NROWF:=0;
REST:=0;
AUP:=0;
POSTER(1).KEY:=T^.KEY;
POSTER(NR).KEY:=OKEY;
FOR I:=2 TO CAP DO
BEGIN
GET(T);
IF EOF(T) THEN
BEGIN
REST:=I-1;
CAP:=I-1;
CLOSE(T)
END
ELSE
WITH POSTER(I) DO
BEGIN
NR1:=T^.NR1;
NR2:=T^.NR2;
FNAVN:=T^.FNAVN;
KEY:=T^.KEY;
UNAVN:=T^.UNAVN;
ADR:=T^.ADR;
LANDSBY:=T^.LANDSBY;
POSTNR:=T^.POSTNR;
TLF:=T^.TLF;
IND(I):=I
END
END;
AIP:=CAP-1;
FOR I:=2 TO CAP DO
BEGIN
ACTIVE:=I;
FOR J:=I+1 TO CAP DO
IF POSTER(IND(ACTIVE)).KEY>POSTER(IND(J)).KEY THEN ACTIVE:=J;
IF ACTIVE>I THEN
BEGIN
AUP:=IND(ACTIVE);
IND(ACTIVE):=IND(I);
IND(I):=AUP
END
END;
(*NU ER POSTERNE SORTERET*)
AUP:=0;
REPEAT
IF REST>0 THEN CAP:=REST;
NROWF:=NROWF+1;
FIL(5):=CHR(NROWF DIV 100 +48);
FIL(6):=CHR(NROWF MOD 100 DIV 10 +48);
FIL(7):=CHR(NROWF MOD 10 +48);
REWRITE(ST,FIL);
ACTIVE:=2;
REPEAT
O:=IND(ACTIVE);
ST^:=POSTER(O);
PUT(ST);
AUP:=AUP+1;
OKEY:=POSTER(O).KEY;
GET(T);
IF (REST<>0) OR (T^.KEY=POSTER(NR).KEY) THEN
BEGIN
IF REST=0 THEN BEGIN REST:=ACTIVE-1 END;
ACTIVE:=ACTIVE+1
END
ELSE
BEGIN
POSTER(O):=T^;
AIP:=AIP+1;
IF POSTER(O).KEY>=OKEY THEN
BEGIN
I:=ACTIVE;
WHILE (I<CAP) AND (POSTER(IND(I+1)).KEY<POSTER(O).KEY) DO
BEGIN
IND(I):=IND(I+1);
I:=I+1
END;
IND(I):=O
END
ELSE
BEGIN
I:=ACTIVE;
WHILE (I>1) AND (POSTER(IND(I-1)).KEY>POSTER(O).KEY) DO
BEGIN
IND(I):=IND(I-1);
I:=I-1
END;
IND(I):=O;
ACTIVE:=ACTIVE+1
END
END
UNTIL ACTIVE>CAP;
FILLCHAR(ST^.KEY(1),26,CHR(126));
ST^.NR1:=0;
ST^.NR2:=0;
FILLCHAR(ST^.FNAVN(1),4,CHR(32));
FILLCHAR(ST^.UNAVN(1),30,CHR(32));
FILLCHAR(ST^.ADR(1),30,CHR(32));
FILLCHAR(ST^.LANDSBY(1),20,CHR(32));
FILLCHAR(ST^.POSTNR(1),25,CHR(32));
FILLCHAR(ST^.TLF(1),10,CHR(32));
PUT(ST);
CLOSE(ST);
UNTIL (REST=CAP) OR (REST=1);
OKEY:=POSTER(NR).KEY;
WRITELN('ANTAL INDLÆSTE, ANTAL UDSKREVNE ',AIP:6,AUP:6)
END;
PROCEDURE FLET(NROWF:INTEGER);
VAR I,J,AIP,AUP,RF,SM
:INTEGER;
FIL1,FIL2,FIL3,FIL4,FIL5,FIL6,FIL7,FIL8,FIL9:FILE OF POST;
BEGIN
AIP:=0;
FOR I:=1 TO NROWF DO
BEGIN
FIL(5):=CHR(I DIV 100 +48);
FIL(6):=CHR(I MOD 100 DIV 10 +48);
FIL(7):=CHR(I MOD 10 +48);
CASE I OF
1: BEGIN
RESET(FIL1,FIL);
GET(FIL1)
END;
2: BEGIN
RESET(FIL2,FIL);
GET(FIL2)
END;
3: BEGIN
RESET(FIL3,FIL);
GET(FIL3)
END;
4: BEGIN
RESET(FIL4,FIL);
GET(FIL4)
END;
5: BEGIN
RESET(FIL5,FIL);
GET(FIL5)
END;
6: BEGIN
RESET(FIL6,FIL);
GET(FIL6)
END;
7: BEGIN
RESET(FIL7,FIL);
GET(FIL7)
END;
8: BEGIN
RESET(FIL8,FIL);
GET(FIL8)
END;
9: BEGIN
RESET(FIL9,FIL);
GET(FIL9)
END
END;
AIP:=AIP+1;
END;
AUP:=0;
REPEAT
SM:=1;
T^:=FIL1^;
FOR I:=2 TO NROWF DO
CASE I OF
2: IF FIL2^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL2^ END;
3: IF FIL3^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL3^ END;
4: IF FIL4^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL4^ END;
5: IF FIL5^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL5^ END;
6: IF FIL6^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL6^ END;
7: IF FIL7^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL7^ END;
8: IF FIL8^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL8^ END;
9: IF FIL8^.KEY<T^.KEY THEN BEGIN SM:=I;T^:=FIL9^ END
END;
IF T^.KEY<OKEY THEN
BEGIN
PUT(T);AUP:=AUP+1;
CASE SM OF
1:GET(FIL1);
2:GET(FIL2);
3:GET(FIL3);
4:GET(FIL4);
5:GET(FIL5);
6:GET(FIL6);
7:GET(FIL7);
8:GET(FIL8);
9:GET(FIL9)
END;
END
UNTIL T^.KEY=OKEY;
CLOSE(T);
WRITELN('ANTAL SORTEREDE ',AUP:5);
END;
PROCEDURE PRINT;
BEGIN
GET(T);
WHILE NOT EOF(T) DO
BEGIN
WRITELN(LIST,T^.KEY:26,' , ',T^.FNAVN:4,' ':30,T^.NR1*10000.0+T^.NR2:8:-2);
WRITELN(LIST,' ':29,T^.UNAVN);
WRITELN(LIST,' ':29,T^.ADR);
WRITELN(LIST,' ':29,T^.LANDSBY);
WRITELN(LIST,' ':29,T^.POSTNR,'TLF: ':8,T^.TLF);
WRITELN(LIST,' ');
WRITELN(LIST,' ');
WRITELN(LIST,' ');
GET(T)
END
END;
BEGIN
WRITELN('SORTKUNDE');
FIL:='ALISTE:P1:30:K';
RESET(T,FIL);
FIL:='WORK000:P1:30:K';
FILLCHAR(T^.KEY(1),26,CHR(32));
FILLCHAR(OKEY(1),26,CHR(126));
NRR:=0;
SORT(NRR);
CLOSE(T);
FIL:='A1LISTE:P1:30:K';
REWRITE(T,FIL);
FIL:='WORK000:P1:30:K';
FILLCHAR(OKEY(1),26,CHR(126));
FLET(NRR);
FIL:='A1LISTE:P1:30:K';
RESET(T,FIL);
PRINT;
FIL:='PROCSTAT:P2:0:I';
(*$C-*)
REPEAT
REWRITE(NRPF,FIL);
SEEK(NRPF,1)
UNTIL IORESULT=0;
(*$C+*)
GET(NRPF);
NRPF^.NP:=1;
SEEK(NRPF,1);
PUT(NRPF);
REPEAT
GOTOXY(1,20);
WRITELN('Sæt plade 1 i drev 1 og tryk RETURN');
READLN;
(*$C-*)
REWRITE(CF,'C1:P1:0:J');
SEEK(CF,1)
(*$C+*)
UNTIL IORESULT=0;
CLOSE(CF);
CLOSE(NRPF);
CHAIN('INTRE *1','HOVSA:P1',QUQ)
END.