with TEXT_IO; with DIRECT_IO; with STRINGS_PACKAGE; use STRINGS_PACKAGE; with INFLECTIONS_PACKAGE; use INFLECTIONS_PACKAGE; with DICTIONARY_PACKAGE; use DICTIONARY_PACKAGE; procedure SORTER is -- This program sorts a file of lines (strings) on 5 substrings Mx..Nx -- Sort by stringwise (different cases), numeric, or POS enumeration package BOOLEAN_IO is new TEXT_IO.ENUMERATION_IO(BOOLEAN); use BOOLEAN_IO; package INTEGER_IO is new TEXT_IO.INTEGER_IO(INTEGER); use INTEGER_IO; package FLOAT_IO is new TEXT_IO.FLOAT_IO(FLOAT); use FLOAT_IO; use TEXT_IO; NAME_LENGTH : constant := 80; ST, ENTER_LINE : STRING(1..NAME_LENGTH) := (others => ' '); LS, LAST : INTEGER := 0; INPUT_NAME : STRING(1..80) := (others => ' '); LINE_LENGTH : constant := 300; -- ################################## -- Max line length on input file -- Shorter => less disk space to sort CURRENT_LENGTH : INTEGER := 0; subtype TEXT_TYPE is STRING(1..LINE_LENGTH); --type LINE_TYPE is -- record -- CURRENT_LENGTH : CURRENT_LINE_LENGTH_TYPE := 0; -- TEXT : TEXT_TYPE; -- end record; package LINE_IO is new DIRECT_IO(TEXT_TYPE); use LINE_IO; BLANK_TEXT : TEXT_TYPE := (others => ' '); LINE_TEXT : TEXT_TYPE := BLANK_TEXT; OLD_LINE : TEXT_TYPE := BLANK_TEXT; P_LINE : TEXT_TYPE := BLANK_TEXT; type SORT_TYPE is (A, C, G, U, N, F, P, R, S); package SORT_TYPE_IO is new TEXT_IO.ENUMERATION_IO(SORT_TYPE); use SORT_TYPE_IO; type WAY_TYPE is (I, D); package WAY_TYPE_IO is new TEXT_IO.ENUMERATION_IO(WAY_TYPE); use WAY_TYPE_IO; INPUT : TEXT_IO.FILE_TYPE; OUTPUT : TEXT_IO.FILE_TYPE; WORK : LINE_IO.FILE_TYPE; M1, M2, M3, M4, M5 : NATURAL := 1; N1, N2, N3, N4, N5 : NATURAL := LINE_LENGTH; Z1, Z2, Z3, Z4, Z5 : NATURAL := 0; S1, S2, S3, S4, S5 : SORT_TYPE := A; W1, W2, W3, W4, W5 : WAY_TYPE := I; ENTRY_FINISHED : exception; -- For section numbering of large documents and standards type SECTION_TYPE is record FIRST_LEVEL : INTEGER := 0; SECOND_LEVEL : INTEGER := 0; THIRD_LEVEL : INTEGER := 0; FOURTH_LEVEL : INTEGER := 0; FIFTH_LEVEL : INTEGER := 0; end record; NO_SECTION : constant SECTION_TYPE := (0, 0, 0, 0, 0); type APPENDIX_TYPE is (NONE, A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z); package APPENDIX_IO is new TEXT_IO.ENUMERATION_IO(APPENDIX_TYPE); type APPENDIX_SECTION_TYPE is record APPENDIX : APPENDIX_TYPE := NONE; SECTION : SECTION_TYPE := NO_SECTION; end record; NO_APPENDIX_SECTION : constant APPENDIX_SECTION_TYPE := (NONE, (0, 0, 0, 0, 0)); -- procedure PUT(OUTPUT : TEXT_IO.FILE_TYPE; S : SECTION_TYPE); -- procedure PUT(S : SECTION_TYPE); -- procedure GET(FROM : in STRING; -- S : out SECTION_TYPE; LAST : out POSITIVE); -- function "<"(A, B : SECTION_TYPE) return BOOLEAN; -- -- procedure PUT(OUTPUT : TEXT_IO.FILE_TYPE; S : APPENDIX_SECTION_TYPE); -- procedure PUT(S : APPENDIX_SECTION_TYPE); -- procedure GET(FROM : in STRING; -- S : out APPENDIX_SECTION_TYPE; LAST : out POSITIVE); -- function "<"(A, B : APPENDIX_SECTION_TYPE) return BOOLEAN; -- procedure PUT(OUTPUT : TEXT_IO.FILE_TYPE; S : SECTION_TYPE) is LEVEL : INTEGER := 0; procedure PUT_LEVEL(OUTPUT : TEXT_IO.FILE_TYPE; L : INTEGER) is begin if L > 9999 then PUT(OUTPUT, "****"); elsif L > 999 then PUT(OUTPUT, L, 4); elsif L > 99 then PUT(OUTPUT, L, 3); elsif L > 9 then PUT(OUTPUT, L, 2); elsif L >= 0 then PUT(OUTPUT, L, 1); else PUT(OUTPUT, "**"); end if; end PUT_LEVEL; begin if S.FIFTH_LEVEL <= 0 then if S.FOURTH_LEVEL <= 0 then if S.THIRD_LEVEL <= 0 then if S.SECOND_LEVEL <= 0 then LEVEL := 1; else LEVEL := 2; end if; else LEVEL := 3; end if; else LEVEL := 4; end if; else LEVEL := 5; end if; if S.FIRST_LEVEL <= 9 then PUT(OUTPUT, ' '); end if; PUT_LEVEL(OUTPUT, S.FIRST_LEVEL); if LEVEL = 1 then PUT(OUTPUT, '.'); PUT(OUTPUT, '0'); -- To match the ATLAS index convention end if; if LEVEL >= 2 then PUT(OUTPUT, '.'); PUT_LEVEL(OUTPUT, S.SECOND_LEVEL); end if; if LEVEL >= 3 then PUT(OUTPUT, '.'); PUT_LEVEL(OUTPUT, S.THIRD_LEVEL); end if; if LEVEL >= 4 then PUT(OUTPUT, '.'); PUT_LEVEL(OUTPUT, S.FOURTH_LEVEL); end if; if LEVEL >= 5 then PUT(OUTPUT, '.'); PUT_LEVEL(OUTPUT, S.FIFTH_LEVEL); end if; end PUT; procedure PUT(S : SECTION_TYPE) is LEVEL : INTEGER := 0; procedure PUT_LEVEL(L : INTEGER) is begin if L > 9999 then PUT("****"); elsif L > 999 then PUT(L, 4); elsif L > 99 then PUT(L, 3); elsif L > 9 then PUT(L, 2); elsif L >= 0 then PUT(L, 1); else PUT("**"); end if; end PUT_LEVEL; begin if S.FIFTH_LEVEL = 0 then if S.FOURTH_LEVEL = 0 then if S.THIRD_LEVEL = 0 then if S.SECOND_LEVEL = 0 then LEVEL := 1; else LEVEL := 2; end if; else LEVEL := 3; end if; else LEVEL := 4; end if; else LEVEL := 5; end if; if S.FIRST_LEVEL <= 9 then PUT(' '); end if; PUT_LEVEL(S.FIRST_LEVEL); PUT('.'); if LEVEL = 1 then PUT('0'); -- To match the ATLAS index convention end if; if LEVEL >= 2 then PUT_LEVEL(S.SECOND_LEVEL); end if; if LEVEL >= 3 then PUT('.'); PUT_LEVEL(S.THIRD_LEVEL); end if; if LEVEL >= 4 then PUT('.'); PUT_LEVEL(S.FOURTH_LEVEL); end if; if LEVEL >= 5 then PUT('.'); PUT_LEVEL(S.FIFTH_LEVEL); end if; end PUT; procedure GET(FROM : in STRING; S : out SECTION_TYPE; LAST : out INTEGER) is L : INTEGER := 0; FT : INTEGER := FROM'FIRST; LT : INTEGER := FROM'LAST; begin S := NO_SECTION; if TRIM(FROM)'LAST < FROM'FIRST then return; -- Empty string, no data -- Return default end if; GET(FROM, S.FIRST_LEVEL, L); if L+1 >= LT then LAST := L; return; end if; GET(FROM(L+2..LT), S.SECOND_LEVEL, L); if L+1 >= LT then LAST := L; return; end if; GET(FROM(L+2..LT), S.THIRD_LEVEL, L); if L+1 >= LT then LAST := L; return; end if; GET(FROM(L+2..LT), S.FOURTH_LEVEL, L); if L+1 >= LT then LAST := L; return; end if; GET(FROM(L+2..LT), S.FIFTH_LEVEL, L); LAST := L; return; exception when TEXT_IO.END_ERROR => LAST := L; return; when TEXT_IO.DATA_ERROR => LAST := L; return; when others => PUT(" Unexpected exception in GET(FROM; SECTION_TYPE) with input =>"); PUT(FROM); NEW_LINE; LAST := L; raise; end GET; function "<"(A, B : SECTION_TYPE) return BOOLEAN is begin if A.FIRST_LEVEL > B.FIRST_LEVEL then return FALSE; elsif A.FIRST_LEVEL < B.FIRST_LEVEL then return TRUE; else if A.SECOND_LEVEL > B.SECOND_LEVEL then return FALSE; elsif A.SECOND_LEVEL < B.SECOND_LEVEL then return TRUE; else if A.THIRD_LEVEL > B.THIRD_LEVEL then return FALSE; elsif A.THIRD_LEVEL < B.THIRD_LEVEL then return TRUE; else if A.FOURTH_LEVEL > B.FOURTH_LEVEL then return FALSE; elsif A.FOURTH_LEVEL < B.FOURTH_LEVEL then return TRUE; else if A.FIFTH_LEVEL > B.FIFTH_LEVEL then return FALSE; elsif A.FIFTH_LEVEL < B.FIFTH_LEVEL then return TRUE; else return FALSE; end if; end if; end if; end if; end if; return FALSE; end "<"; procedure PUT(OUTPUT : TEXT_IO.FILE_TYPE; S : APPENDIX_SECTION_TYPE) is use APPENDIX_IO; begin PUT(OUTPUT, S.APPENDIX); PUT(OUTPUT, ' '); PUT(OUTPUT, S.SECTION); end PUT; procedure PUT(S : APPENDIX_SECTION_TYPE) is use APPENDIX_IO; begin PUT(S.APPENDIX); PUT(' '); PUT(S.SECTION); end PUT; procedure GET(FROM : in STRING; S : out APPENDIX_SECTION_TYPE; LAST : out INTEGER) is use APPENDIX_IO; L : INTEGER := 0; FT : INTEGER := FROM'FIRST; LT : INTEGER := FROM'LAST; begin S := NO_APPENDIX_SECTION; if (FT = LT) or else (TRIM(FROM)'LENGTH = 0) then -- Empty/blank string, no data PUT("@"); return; -- Return default end if; --PUT_LINE("In GET =>" & FROM & '|'); begin GET(FROM, S.APPENDIX, L); --PUT("A"); if L+1 >= LT then LAST := L; return; end if; exception when others => S.APPENDIX := NONE; L := FT - 2; end; -- PUT("B"); -- GET(FROM(L+2..LT), S.SECTION.FIRST_LEVEL, L); -- if L+1 >= LT then -- LAST := L; -- return; -- end if; --PUT("C"); -- GET(FROM(L+2..LT), S.SECTION.SECOND_LEVEL, L); -- if L+1 >= LT then -- LAST := L; -- return; -- end if; --PUT("D"); -- GET(FROM(L+2..LT), S.SECTION.THIRD_LEVEL, L); -- if L+1 >= LT then -- LAST := L; -- return; -- end if; --PUT("E"); -- GET(FROM(L+2..LT), S.SECTION.FOURTH_LEVEL, L); -- if L+1 >= LT then -- LAST := L; -- return; -- end if; --PUT("F"); -- GET(FROM(L+2..LT), S.SECTION.FIFTH_LEVEL, L); -- LAST := L; --PUT("G"); GET(FROM(L+2..LT), S.SECTION, L); --PUT("F"); return; exception when TEXT_IO.END_ERROR => LAST := L; return; when TEXT_IO.DATA_ERROR => LAST := L; return; when others => PUT (" Unexpected exception in GET(FROM; APPENDIX_SECTION_TYPE) with input =>"); PUT(FROM); NEW_LINE; LAST := L; return; end GET; function "<"(A, B : APPENDIX_SECTION_TYPE) return BOOLEAN is begin if A.APPENDIX > B.APPENDIX then return FALSE; elsif A.APPENDIX < B.APPENDIX then return TRUE; else if A.SECTION.FIRST_LEVEL > B.SECTION.FIRST_LEVEL then return FALSE; elsif A.SECTION.FIRST_LEVEL < B.SECTION.FIRST_LEVEL then return TRUE; else if A.SECTION.SECOND_LEVEL > B.SECTION.SECOND_LEVEL then return FALSE; elsif A.SECTION.SECOND_LEVEL < B.SECTION.SECOND_LEVEL then return TRUE; else if A.SECTION.THIRD_LEVEL > B.SECTION.THIRD_LEVEL then return FALSE; elsif A.SECTION.THIRD_LEVEL < B.SECTION.THIRD_LEVEL then return TRUE; else if A.SECTION.FOURTH_LEVEL > B.SECTION.FOURTH_LEVEL then return FALSE; elsif A.SECTION.FOURTH_LEVEL < B.SECTION.FOURTH_LEVEL then return TRUE; else if A.SECTION.FIFTH_LEVEL > B.SECTION.FIFTH_LEVEL then return FALSE; elsif A.SECTION.FIFTH_LEVEL < B.SECTION.FIFTH_LEVEL then return TRUE; else return FALSE; end if; end if; end if; end if; end if; end if; end "<"; procedure PROMPT_FOR_ENTRY(ENTRY_NUMBER : STRING) is begin PUT("Give starting column and size of "); PUT(ENTRY_NUMBER); PUT_LINE(" significant sort field "); PUT(" with optional sort type and way => "); end PROMPT_FOR_ENTRY; procedure GET_ENTRY (MX, NX : out NATURAL; SX : out SORT_TYPE; WX : out WAY_TYPE ) is M : NATURAL := 1; N : NATURAL := LINE_LENGTH; S : SORT_TYPE := A; W : WAY_TYPE := I; Z : NATURAL := 0; procedure ECHO_ENTRY is begin PUT(" Sorting on LINE("); PUT(M,3); PUT(".."); PUT(N, 3); PUT(")"); PUT(" with S = "); PUT(S); PUT(" and W = "); PUT(W); NEW_LINE(2); end ECHO_ENTRY; begin M := 0; N := LINE_LENGTH; S := A; W := I; GET_LINE(ENTER_LINE, LS); if LS = 0 then raise ENTRY_FINISHED; end if; INTEGER_IO.GET(ENTER_LINE(1..LS), M, LAST); begin INTEGER_IO.GET(ENTER_LINE(LAST+1..LS), Z, LAST); if M = 0 or Z = 0 then PUT_LINE("Start or size of zero, you must be kidding, aborting"); raise PROGRAM_ERROR; elsif M + Z > LINE_LENGTH then PUT_LINE("Size too large, going to end of line"); N := LINE_LENGTH; else N := M + Z - 1; end if; SORT_TYPE_IO.GET(ENTER_LINE(LAST+1..LS), S, LAST); WAY_TYPE_IO.GET(ENTER_LINE(LAST+1..LS), W, LAST); MX := M; NX := N; SX := S; WX := W; ECHO_ENTRY; return; exception when PROGRAM_ERROR => PUT_LINE("PROGRAM_ERROR raised in GET_ENTRY"); raise; when others => MX := M; NX := N; SX := S; WX := W; ECHO_ENTRY; return; end; end GET_ENTRY; function IGNORE_SEPARATORS(S : STRING) return STRING is T : STRING(S'FIRST..S'LAST) := LOWER_CASE(S); begin for I in S'FIRST+1..S'LAST-1 loop if (S(I-1) /= '-' and then S(I-1) /= '_') and then (S(I) = '-' or else S(I) = '_') and then (S(I+1) /= '-' and then S(I+1) /= '_') then T(I) := ' '; end if; end loop; return T; end IGNORE_SEPARATORS; function LTU(C, D : CHARACTER) return BOOLEAN is begin if (D = 'v') then if (C < 'u') then return TRUE; else return FALSE; end if; elsif (D = 'j') then if (C < 'i') then return TRUE; else return FALSE; end if; elsif (D = 'V') then if (C < 'U') then return TRUE; else return FALSE; end if; elsif (D = 'J') then if (C < 'I') then return TRUE; else return FALSE; end if; else return C < D; end if; end LTU; function EQU(C, D : CHARACTER) return BOOLEAN is begin if (D = 'u') or (D = 'v') then if (C = 'u') or (C = 'v') then return TRUE; else return FALSE; end if; elsif (D = 'i') or (D = 'j') then if (C = 'i') or (C = 'j') then return TRUE; else return FALSE; end if; elsif (D = 'U') or (D = 'V') then if (C = 'U') or (C = 'V') then return TRUE; else return FALSE; end if; elsif (D = 'I') or (D = 'J') then if (C = 'I') or (C = 'J') then return TRUE; else return FALSE; end if; else return C = D; end if; end EQU; function GTU(C, D : CHARACTER) return BOOLEAN is begin if D = 'u' then if (C > 'v') then return TRUE; else return FALSE; end if; elsif D = 'i' then if (C > 'j') then return TRUE; else return FALSE; end if; elsif D = 'U' then if (C > 'V') then return TRUE; else return FALSE; end if; elsif D = 'I' then if (C > 'J') then return TRUE; else return FALSE; end if; else return C > D; end if; end GTU; function LTU(S, T : STRING) return BOOLEAN is begin for I in 1..S'LENGTH loop -- Not TRIMed, so same length if EQU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then null; elsif GTU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then return FALSE; elsif LTU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then return TRUE; end if; end loop; return FALSE; end LTU; function GTU(S, T : STRING) return BOOLEAN is begin for I in 1..S'LENGTH loop if EQU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then null; elsif LTU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then return FALSE; elsif GTU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then return TRUE; end if; end loop; return FALSE; end GTU; function EQU(S, T : STRING) return BOOLEAN is begin if S'LENGTH /= T'LENGTH then return FALSE; end if; for I in 1..S'LENGTH loop if not EQU(S(S'FIRST+I-1), T(T'FIRST+I-1)) then return FALSE; end if; end loop; return TRUE; end EQU; function SLT (X, Y : STRING; -- Make LEFT and RIGHT ST : SORT_TYPE := A; WT : WAY_TYPE := I) return BOOLEAN is AS : STRING(X'RANGE) := X; BS : STRING(Y'RANGE) := Y; MN, NN : INTEGER := 0; FN, GN : FLOAT := 0.0; --FS, GS : SECTION_TYPE := NO_SECTION; FS, GS : APPENDIX_SECTION_TYPE := NO_APPENDIX_SECTION; PX, PY : PART_ENTRY; -- So I can X here RX, RY : PART_OF_SPEECH_TYPE; -- So I can X here begin if ST = A then AS := LOWER_CASE(AS); BS := LOWER_CASE(BS); if WT = I then return AS < BS; else return AS > BS; end if; elsif ST = C then if WT = I then return AS < BS; else return AS > BS; end if; elsif ST = G then AS := IGNORE_SEPARATORS(AS); BS := IGNORE_SEPARATORS(BS); if WT = I then return AS < BS; else return AS > BS; end if; elsif ST = U then AS := LOWER_CASE(AS); BS := LOWER_CASE(BS); if WT = I then return LTU(AS, BS); else return GTU(AS, BS); end if; elsif ST = N then INTEGER_IO.GET(AS, MN, LAST); INTEGER_IO.GET(BS, NN, LAST); if WT = I then return MN < NN; else return MN > NN; end if; elsif ST = F then FLOAT_IO.GET(AS, FN, LAST); FLOAT_IO.GET(BS, GN, LAST); if WT = I then return FN < GN; else return FN > GN; end if; elsif ST = P then PART_ENTRY_IO.GET(AS, PX, LAST); PART_ENTRY_IO.GET(BS, PY, LAST); if WT = I then return PX < PY; else return (not (PX < PY)) and (not (PX = PY)); end if; elsif ST = R then PART_OF_SPEECH_TYPE_IO.GET(AS, RX, LAST); PART_OF_SPEECH_TYPE_IO.GET(BS, RY, LAST); if WT = I then return RX < RY; else return (not (RX < RY)) and (not (RX = RY)); end if; elsif ST = S then --PUT_LINE("AS =>" & AS & '|'); GET(AS, FS, LAST); --PUT_LINE("BS =>" & BS & '|'); GET(BS, GS, LAST); --PUT_LINE("GOT AS & BS"); if WT = I then return FS < GS; else return (not (FS < GS)) and (not (FS = GS)); end if; else return FALSE; end if; exception when others => TEXT_IO.PUT_LINE("exception in SLT showing LEFT and RIGHT"); TEXT_IO.PUT_LINE(X & "&"); TEXT_IO.PUT_LINE(Y & "|"); raise; end SLT; function SORT_EQUAL (X, Y : STRING; ST : SORT_TYPE := A; WT : WAY_TYPE := I) return BOOLEAN is AS : STRING(X'RANGE) := X; BS : STRING(Y'RANGE) := Y; MN, NN : INTEGER := 0; FN, GN : FLOAT := 0.0; FS, GS : APPENDIX_SECTION_TYPE := NO_APPENDIX_SECTION; PX, PY : PART_ENTRY; RX, RY : PART_OF_SPEECH_TYPE; begin if ST = A then AS := LOWER_CASE(AS); BS := LOWER_CASE(BS); return AS = BS; elsif ST = C then return AS = BS; elsif ST = G then AS := IGNORE_SEPARATORS(AS); BS := IGNORE_SEPARATORS(BS); return AS = BS; elsif ST = U then AS := LOWER_CASE(AS); BS := LOWER_CASE(BS); return EQU(AS, BS); elsif ST = N then INTEGER_IO.GET(AS, MN, LAST); INTEGER_IO.GET(BS, NN, LAST); return MN = NN; elsif ST = F then FLOAT_IO.GET(AS, FN, LAST); FLOAT_IO.GET(BS, GN, LAST); return FN = GN; elsif ST = P then PART_ENTRY_IO.GET(AS, PX, LAST); PART_ENTRY_IO.GET(BS, PY, LAST); return PX = PY; elsif ST = R then PART_OF_SPEECH_TYPE_IO.GET(AS, RX, LAST); PART_OF_SPEECH_TYPE_IO.GET(BS, RY, LAST); return RX = RY; elsif ST = S then GET(AS, FS, LAST); GET(BS, GS, LAST); return FS = GS; else return FALSE; end if; exception when others => TEXT_IO.PUT_LINE("exception in LT showing LEFT and RIGHT"); TEXT_IO.PUT_LINE(X & "|"); TEXT_IO.PUT_LINE(Y & "|"); raise; end SORT_EQUAL; function LT (LEFT, RIGHT : TEXT_TYPE) return BOOLEAN is begin if SLT(LEFT(M1..N1), RIGHT(M1..N1), S1, W1) then return TRUE; elsif SORT_EQUAL(LEFT(M1..N1), RIGHT(M1..N1), S1, W1) then if ((N2 > 0) and then SLT(LEFT(M2..N2), RIGHT(M2..N2), S2, W2) ) then return TRUE; elsif ((N2 > 0) and then SORT_EQUAL(LEFT(M2..N2), RIGHT(M2..N2), S2, W2)) then if ((N3 > 0) and then SLT(LEFT(M3..N3), RIGHT(M3..N3), S3, W3 )) then return TRUE; elsif ((N3 > 0) and then SORT_EQUAL(LEFT(M3..N3), RIGHT(M3..N3), S3, W3)) then if ((N4 > 0) and then SLT(LEFT(M4..N4), RIGHT(M4..N4), S4, W4) ) then return TRUE; elsif ((N4 > 0) and then SORT_EQUAL(LEFT(M4..N4), RIGHT(M4..N4), S4, W4)) then if ((N5 > 0) and then SLT(LEFT(M5..N5), RIGHT(M5..N5), S5, W5) ) then return TRUE; end if; end if; end if; end if; end if; return FALSE; exception when others => TEXT_IO.PUT_LINE("exception in LT showing LEFT and RIGHT"); TEXT_IO.PUT_LINE(LEFT & "|"); TEXT_IO.PUT_LINE(RIGHT & "|"); raise; end LT; procedure OPEN_FILE_FOR_INPUT(INPUT : in out TEXT_IO.FILE_TYPE; PROMPT : STRING := "File for input => ") is LAST : NATURAL := 0; begin GET_INPUT_FILE: loop CHECK_INPUT: begin NEW_LINE; PUT(PROMPT); GET_LINE(INPUT_NAME, LAST); OPEN(INPUT, IN_FILE, INPUT_NAME(1..LAST)); exit; exception when others => PUT_LINE(" !!!!!!!!! Try Again !!!!!!!!"); end CHECK_INPUT; end loop GET_INPUT_FILE; end OPEN_FILE_FOR_INPUT; procedure CREATE_FILE_FOR_OUTPUT(OUTPUT : in out TEXT_IO.FILE_TYPE; PROMPT : STRING := "File for output => ") is NAME : STRING(1..80) := (others => ' '); LAST : NATURAL := 0; begin GET_OUTPUT_FILE: loop CHECK_OUTPUT: begin NEW_LINE; PUT(PROMPT); GET_LINE(NAME, LAST); if TRIM(NAME(1..LAST))'LENGTH /= 0 then CREATE(OUTPUT, OUT_FILE, NAME(1..LAST)); else CREATE(OUTPUT, OUT_FILE, TRIM(INPUT_NAME)); end if; exit; exception when others => PUT_LINE(" !!!!!!!!! Try Again !!!!!!!!"); end CHECK_OUTPUT; end loop GET_OUTPUT_FILE; end CREATE_FILE_FOR_OUTPUT; function GRAPHIC(S : STRING) return STRING is T : STRING(1..S'LENGTH) := S; begin for I in S'RANGE loop if CHARACTER'POS(S(I)) < 32 then T(I) := ' '; end if; end loop; return T; end GRAPHIC; begin NEW_LINE; PUT_LINE("Sorts a text file of lines four times on substrings M..N"); PUT_LINE("A)lphabetic (all case) C)ase sensitive, iG)nore seperators, U)i_is_vj,"); PUT_LINE(" iN)teger, F)loating point, S)ection, P)art entry, or paR)t of speech"); PUT_LINE(" I)ncreasing or D)ecreasing"); NEW_LINE; OPEN_FILE_FOR_INPUT(INPUT, "What file to sort from => "); NEW_LINE; PROMPT_FOR_ENTRY("first"); begin GET_ENTRY(M1, N1, S1, W1); exception when PROGRAM_ERROR => raise; when others => null; end; begin PROMPT_FOR_ENTRY("second"); GET_ENTRY(M2, N2, S2, W2); PROMPT_FOR_ENTRY("third"); GET_ENTRY(M3, N3, S3, W3); PROMPT_FOR_ENTRY("fourth"); GET_ENTRY(M4, N4, S4, W4); PROMPT_FOR_ENTRY("fifth"); GET_ENTRY(M5, N5, S5, W5); exception when PROGRAM_ERROR => raise; when ENTRY_FINISHED => null; when TEXT_IO.DATA_ERROR | TEXT_IO.END_ERROR => null; end; --PUT_LINE("CREATING WORK FILE"); NEW_LINE; CREATE (WORK, INOUT_FILE, "WORK."); PUT_LINE("CREATED WORK FILE"); while not END_OF_FILE(INPUT) loop --begin GET_LINE(INPUT, LINE_TEXT, CURRENT_LENGTH); --exception when others => --TEXT_IO.PUT_LINE("INPUT GET exception"); --TEXT_IO.PUT_LINE(LINE_TEXT(1..CURRENT_LENGTH) & "|"); --end; --PUT_LINE(LINE_TEXT(1..CURRENT_LENGTH)); --PUT_LINE("=>" & HEAD(LINE_TEXT(1..CURRENT_LENGTH), LINE_LENGTH) & "|"); if TRIM(LINE_TEXT(1..CURRENT_LENGTH)) /= "" then --begin WRITE(WORK, HEAD(LINE_TEXT(1..CURRENT_LENGTH), LINE_LENGTH) ); --exception when others => --TEXT_IO.PUT_LINE("WORK WRITE exception"); --TEXT_IO.PUT_LINE(LINE_TEXT(1..CURRENT_LENGTH) & "|"); --end; end if; end loop; CLOSE(INPUT); PUT_LINE("Begin sorting"); LINE_HEAPSORT: declare L : LINE_IO.POSITIVE_COUNT := SIZE(WORK) / 2 + 1; IR : LINE_IO.POSITIVE_COUNT := SIZE(WORK); I, J : LINE_IO.POSITIVE_COUNT; begin TEXT_IO.PUT_LINE("SIZE OF WORK = " & INTEGER'IMAGE(INTEGER(SIZE(WORK)))); MAIN: loop if L > 1 then L := L - 1; READ(WORK, LINE_TEXT, L); OLD_LINE := LINE_TEXT; else READ(WORK, LINE_TEXT, IR); OLD_LINE := LINE_TEXT; READ(WORK, LINE_TEXT, 1); WRITE(WORK, LINE_TEXT, IR); IR := IR - 1; if IR = 1 THEN WRITE(WORK, OLD_LINE, 1); exit MAIN; end if; end if; I := L; J := L + L; while J <= IR loop if J < IR then READ(WORK, LINE_TEXT, J); READ(WORK, P_LINE, J+1); --if LT (LINE.TEXT, P_LINE.TEXT) then if LT (LINE_TEXT, P_LINE) then J := J + 1; end if; end if; READ(WORK, LINE_TEXT, J); --if OLD_LINE.TEXT < LINE.TEXT then if LT (OLD_LINE , LINE_TEXT) then WRITE(WORK, LINE_TEXT, I); I := J; J := J + J; else J := IR + 1; end if; end loop; WRITE(WORK, OLD_LINE, I); end loop MAIN; exception when CONSTRAINT_ERROR => PUT_LINE("HEAP CONSTRAINT_ERROR"); when others => PUT_LINE("HEAP other_ERROR"); end LINE_HEAPSORT; PUT_LINE("Finished sorting in WORK"); CREATE_FILE_FOR_OUTPUT(OUTPUT, "Where to put the output => "); --RESET(WORK); Set_Index(WORK, 1); while not END_OF_FILE(WORK) loop READ(WORK, LINE_TEXT); if TRIM(GRAPHIC(LINE_TEXT))'LENGTH > 0 then --PUT_LINE(TRIM(LINE_TEXT, RIGHT)); PUT_LINE(OUTPUT, TRIM(LINE_TEXT, RIGHT)); end if; end loop; CLOSE(WORK); CLOSE(OUTPUT); PUT_LINE("Done!"); NEW_LINE; exception when PROGRAM_ERROR => PUT_LINE("SORT terminated on a PROGRAM_ERROR"); CLOSE(OUTPUT); when TEXT_IO.DATA_ERROR => --Terminate on primary start or size = 0 PUT_LINE("SORT terminated on a DATA_ERROR"); PUT_LINE(LINE_TEXT); CLOSE(OUTPUT); when CONSTRAINT_ERROR => --Terminate on blank line for file name PUT_LINE("SORT terminated on a CONSTRAINT_ERROR"); CLOSE(OUTPUT); when TEXT_IO.DEVICE_ERROR => --Ran out of space to write output file PUT_LINE("SORT terminated on a DEVICE_ERROR"); DELETE(OUTPUT); CREATE_FILE_FOR_OUTPUT(OUTPUT, "Wherelse to put the output => "); RESET(WORK); while not END_OF_FILE(WORK) loop READ(WORK, LINE_TEXT); PUT_LINE(OUTPUT, LINE_TEXT); --(1..LINE.CURRENT_LENGTH)); end loop; CLOSE(OUTPUT); end SORTER;