The ESORT.I include file resides on the Kyan Pascal 2.x Utilities Disk 1.
Source Code
PROCEDURE ESORT;
(* GLOBAL INPUTS:
FYLE : FILE TO BE SORTED
RLEN : RECORD LENGTH
OSET : BYTE OFFSET FROM START OF
RECORD TO KEY
ORDER : 0 OR + IF ASCENDING
NEGATIVE IF DESCENDING
KLEN : KEY FIELD LENGTH IN BYTES
KTYPE : TYPE OF KEY FIELD
ALPHA_FIELD, INTEGER_FIELD,
OR REAL_FIELD *)
VAR
FYLELIST :NAMEARRAY;
I,
FILEINDEX,r :INTEGER; (* INDEX TO FYLELIST PATHLIST *)
PROCEDURE MAIN;
CONST
MAXBYTES = 5000; (* MAX NUMBER OF BYTES IN ARRAYA *)
MAXRECORDS = 1000; (* MAX NUMBER OF RECORDS TO LOAD *)
TYPE
NODEPTR = ^NODE;
NODE = RECORD
INDEXA : INTEGER;
NEXTNODE : NODEPTR
END;
VAR
ARRAYA : ARRAY [1..MAXBYTES] OF CHAR;
BASE,CURRENT,
TARGET : NODEPTR;
F,G : FILE OF CHAR;
I,J,
RECLIMIT, (* NUMBER OF RECORDS WHICH FILL ARRAYA *)
KEYLENGTH, (* ACTUAL LENGTH OF KEY FIELD IN BYTES *)
RECNUMBER, (* NUMBER OF RECORDS READ SO FAR *)
SORTORDER, (* ORDER OF SORT (-1,0,1) *)
NEXTPOINTER : INTEGER;
DOINGPURGE,
FOUND_EOF,
NEEDNEWFILE : BOOLEAN;
PROCEDURE INIT_ESORT_VARS;
BEGIN
DOINGPURGE:=FALSE;
NEEDNEWFILE:=FALSE;
FILEINDEX:=1;
CASE KTYPE OF
ALPHA_FIELD : KEYLENGTH:=KLEN;
INTEGER_FIELD : KEYLENGTH:=2;
REAL_FIELD : KEYLENGTH:=8
END;
RECLIMIT := MAXBYTES DIV RLEN;
IF RECLIMIT > MAXRECORDS THEN RECLIMIT:=MAXRECORDS;
BASE:=NIL;
TARGET:=BASE;
RECNUMBER :=1;
NEXTPOINTER:=1;
IF ORDER < 0 THEN SORTORDER:=-1
ELSE SORTORDER:=1
END;
PROCEDURE NAME_TEMP_FILES;
(* APPEND SUFFIXES TO FILES IN FYLELIST .1 THRU .6 *)
VAR I,J:INTEGER;
BEGIN
I:=1;
REPEAT I:=I+1 UNTIL ((FYLE[I]=' ') OR (I=62));
FOR J:=1 TO 6 DO
BEGIN
FYLELIST[J]:=FYLE;
FYLELIST[J][I]:='.';
FYLELIST[J][I+1]:=CHR(J+ORD('0'))
END;
FYLELIST[7]:=FYLE
END;
FUNCTION COMPARE(FIRST,SECOND:NODEPTR):INTEGER;
(* FIRST,SECOND POINT TO NODES WHICH
CONTAIN THE INDEXES TO RECORD DATA
IN ARRAYA.
FUNCTION RETURNS -1 IF FIRST<SECOND
0 IF FIRST=SECOND
1 IF FIRST>SECOND
FUNCTION VALUE IS REVERSED BY 'ORDER' *)
TYPE
KEYRECTYPE = RECORD
CASE FIELD_TYPE OF
ALPHA_FIELD :(CVALUE:ARRAY[1..255] OF CHAR);
INTEGER_FIELD:(IVALUE:INTEGER);
REAL_FIELD :(RVALUE:INTEGER)
END;
VAR I,RESULT :INTEGER;
FIRSTKEY,
SECONDKEY:KEYRECTYPE;
DONE :BOOLEAN;
BEGIN
FOR I:=0 TO KEYLENGTH-1 DO
BEGIN
FIRSTKEY.CVALUE[I+1] :=ARRAYA[FIRST^.INDEXA +I+OSET];
SECONDKEY.CVALUE[I+1]:=ARRAYA[SECOND^.INDEXA+I+OSET];
END;
CASE KTYPE OF
ALPHA_FIELD :
BEGIN
I:=0;
REPEAT
I:=I+1;
IF FIRSTKEY.CVALUE[I]<SECONDKEY.CVALUE[I]
THEN RESULT:=-1
ELSE
IF FIRSTKEY.CVALUE[I]=SECONDKEY.CVALUE[I]
THEN RESULT:=0
ELSE RESULT:=1
UNTIL (RESULT<>0) OR (I=KLEN);
END; (* CASE ALPHA_FIELD *)
INTEGER_FIELD :
BEGIN
IF FIRSTKEY.IVALUE<SECONDKEY.IVALUE
THEN RESULT:=-1
ELSE
IF FIRSTKEY.IVALUE=SECONDKEY.IVALUE
THEN RESULT:=0
ELSE RESULT:=1
END;
REAL_FIELD :
BEGIN
IF FIRSTKEY.RVALUE<SECONDKEY.RVALUE
THEN RESULT:=-1
ELSE
IF FIRSTKEY.RVALUE=SECONDKEY.RVALUE
THEN RESULT:=0
ELSE RESULT:=1
END
END; (* CASE *)
COMPARE := SORTORDER * RESULT
END;
PROCEDURE INSERTNODE;
VAR TRAILER,LEADER:NODEPTR;
DONE:BOOLEAN;
BEGIN
IF BASE=NIL THEN BASE:=CURRENT
ELSE
BEGIN
IF COMPARE(CURRENT,BASE)=-1
THEN BEGIN
CURRENT^.NEXTNODE:=BASE;
BASE:=CURRENT
END
ELSE
BEGIN
LEADER:=BASE;
REPEAT
TRAILER:=LEADER;
LEADER:=LEADER^.NEXTNODE;
DONE:=(LEADER=NIL);
IF NOT DONE THEN DONE:=(COMPARE(LEADER,CURRENT)=1)
UNTIL DONE;
TRAILER^.NEXTNODE:=CURRENT;
CURRENT^.NEXTNODE:=LEADER;
LEADER:=CURRENT
END
END
END;
PROCEDURE REMOVENODE;
VAR WALKER:NODEPTR;
BEGIN
IF TARGET=BASE THEN BASE:=BASE^.NEXTNODE
ELSE
BEGIN
WALKER:=BASE;
WHILE WALKER^.NEXTNODE<>TARGET DO
WALKER:=WALKER^.NEXTNODE;
WALKER^.NEXTNODE:=TARGET^.NEXTNODE
END;
END;
PROCEDURE WRITENODE;
VAR I :INTEGER;
OLDTARGET:NODEPTR;
BEGIN
IF TARGET=NIL THEN TARGET:=BASE;
NEXTPOINTER:=TARGET^.INDEXA;
FOR I:=NEXTPOINTER TO NEXTPOINTER+RLEN-1 DO
WRITE(G,ARRAYA[I]);
IF NOT DOINGPURGE THEN REMOVENODE;
OLDTARGET:=TARGET;
TARGET:=TARGET^.NEXTNODE;
DISPOSE(OLDTARGET);
NEEDNEWFILE:=(TARGET=NIL);
(* TARGET=NIL WHEN AT END OF LIST *)
END;
PROCEDURE GETNODE;
(* READ NODE FROM FYLE, PUTTING DATA INTO ARRAYA
STARTING AT 'NEXTPOINTER' *)
VAR I:INTEGER;
CH:CHAR;
BEGIN
I:=0;
WHILE NOT (EOF(F) OR (I=RLEN)) DO BEGIN
READ(F,CH);
ARRAYA[NEXTPOINTER+I]:=CH;
I:=I+1
END;
IF NOT EOF(F) THEN
BEGIN
NEW(CURRENT);
CURRENT^.INDEXA:=NEXTPOINTER;
CURRENT^.NEXTNODE:=NIL;
INSERTNODE;
IF RECNUMBER=RECLIMIT THEN WRITENODE
ELSE
BEGIN
(* ARRAY ISN'T FULL YET SO LINEAR ALLOCATION IS OK *)
RECNUMBER :=RECNUMBER+1;
NEXTPOINTER:=NEXTPOINTER+RLEN
END
END;
END;
PROCEDURE PURGE;
VAR MARKER,OLDTARGET:NODEPTR;
BEGIN
DOINGPURGE:=TRUE;
MARKER:=TARGET;
WHILE TARGET<>NIL DO WRITENODE;
IF FILEINDEX=5 THEN
BEGIN
MERGE(FYLELIST,1,5,RLEN,KLEN,OSET,ORDER,KTYPE);
FILEINDEX:=1;
END;
FILEINDEX:=FILEINDEX+1;
REWRITE (G,FYLELIST[FILEINDEX]);
TARGET:=BASE;
WHILE TARGET<>MARKER DO WRITENODE;
END;
BEGIN
INIT_ESORT_VARS;
NAME_TEMP_FILES;
RESET (F,FYLE);
REWRITE (G,FYLELIST[1]);
WHILE NOT EOF(F) DO BEGIN
GETNODE;
IF NEEDNEWFILE THEN
BEGIN
IF FILEINDEX=5 THEN
BEGIN
MERGE(FYLELIST,1,5,RLEN,KLEN,OSET,ORDER,KTYPE);
FILEINDEX:=1
END;
FILEINDEX:=FILEINDEX+1;
REWRITE (G,FYLELIST[FILEINDEX])
END
END;
PURGE;
END;
BEGIN
MAIN;
MERGE(FYLELIST,7,FILEINDEX,RLEN,KLEN,OSET,ORDER,KTYPE);
FOR I:=1 TO 6 DO
r:=DELETE(FYLELIST[I]);
END;
No comments:
Post a Comment