philologue/whitakers-words
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
12834d4b8b9c77e1c7ca1cec532cd183d0310ffa
whitakers-words/word_package.adb
Michael Wolf 926705cb97 import from .zip file
2012-05-31 16:45:42 -05:00

2225 lines
103 KiB
Ada
Raw Blame History

with TEXT_IO;
with LATIN_FILE_NAMES; use LATIN_FILE_NAMES;
with STRINGS_PACKAGE; use STRINGS_PACKAGE;
with CONFIG; use CONFIG;
with UNIQUES_PACKAGE; use UNIQUES_PACKAGE;
with ADDONS_PACKAGE; use ADDONS_PACKAGE;
with WORD_PARAMETERS; use WORD_PARAMETERS;
with PREFACE;
with DEVELOPER_PARAMETERS; use DEVELOPER_PARAMETERS;
with LINE_STUFF; use LINE_STUFF;
with ENGLISH_SUPPORT_PACKAGE; use ENGLISH_SUPPORT_PACKAGE;
package body WORD_PACKAGE is
INFLECTIONS_SECTIONS_FILE : LEL_SECTION_IO.FILE_TYPE;
procedure PAUSE(OUTPUT : TEXT_IO.FILE_TYPE) is
use CONFIG;
PAUSE_LINE : STRING(1..300);
PAUSE_LAST : INTEGER := 0;
begin
if WORDS_MDEV(PAUSE_IN_SCREEN_OUTPUT) then
if METHOD = INTERACTIVE then
if TEXT_IO.NAME(OUTPUT) =
TEXT_IO.NAME(TEXT_IO.STANDARD_OUTPUT) then
TEXT_IO.PUT_LINE(TEXT_IO.STANDARD_OUTPUT,
" MORE - hit RETURN/ENTER to continue");
TEXT_IO.GET_LINE(TEXT_IO.STANDARD_INPUT, PAUSE_LINE, PAUSE_LAST);
end if;
elsif METHOD = COMMAND_LINE_INPUT then
TEXT_IO.PUT_LINE(TEXT_IO.STANDARD_OUTPUT,
" MORE - hit RETURN/ENTER to continue");
TEXT_IO.GET_LINE(TEXT_IO.STANDARD_INPUT, PAUSE_LINE, PAUSE_LAST);
elsif METHOD = COMMAND_LINE_FILES then
null; -- Do not PAUSE
end if;
end if;
exception
when others =>
TEXT_IO.PUT_LINE("Unexpected exception in PAUSE");
end PAUSE;
function MIN(A, B : INTEGER) return INTEGER is
begin
if A <= B then
return A; end if;
return B;
end MIN;
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 -- Not TRIMed, so same length
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;
procedure RUN_UNIQUES(S : in STRING; UNIQUE_FOUND : out BOOLEAN;
PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is
SL : constant STRING -- BAD NAME!!!!!!!!!!!!!!!!!!
:= LOWER_CASE(TRIM(S));
ST : constant STEM_TYPE := HEAD(SL, MAX_STEM_SIZE);
UNQL : UNIQUE_LIST; -- Unique list for a letter
begin
UNIQUE_FOUND := FALSE;
if SL(SL'FIRST) = 'v' then
UNQL := UNQ('u'); -- Unique list for a letter
elsif SL(SL'FIRST) = 'j' then
UNQL := UNQ('i'); -- Unique list for a letter
else
UNQL := UNQ(SL(SL'FIRST)); -- Unique list for a letter
end if;
--TEXT_IO.NEW_LINE;
--TEXT_IO.PUT_LINE("Called UNIQUES with =>" & SL & "|");
--TEXT_IO.NEW_LINE;
--TEXT_IO.PUT_LINE("UNQL ");
while UNQL /= null loop
-- If there is a match, add to PA
--TEXT_IO.PUT_LINE("UNIQUE =>" & UNQL.PR.STEM);
--if ST = LOWER_CASE(UNQL.PR.STEM) then
if EQU(ST, LOWER_CASE(UNQL.STEM)) then
PA_LAST := PA_LAST + 1;
PA(PA_LAST) := (UNQL.STEM,
(UNQL.QUAL,
0,
NULL_ENDING_RECORD,
X,
X),
UNIQUE,
UNQL.MNPC);
--TEXT_IO.PUT_LINE("UNIQUE HIT *********" & INTEGER'IMAGE(PA_LAST));
UNIQUE_FOUND := TRUE;
end if;
UNQL := UNQL.SUCC;
end loop;
end RUN_UNIQUES;
procedure RUN_INFLECTIONS(S : in STRING; SL : in out SAL;
RESTRICTION : DICT_RESTRICTION := REGULAR) is
-- Trys all possible inflections against the input word in S
-- and constructs a STEM_LIST of those that survive SL
use LEL_SECTION_IO;
use INFLECTION_RECORD_IO;
WORD : constant STRING := LOWER_CASE(TRIM(S));
LAST_OF_WORD : constant CHARACTER := WORD(WORD'LAST);
LENGTH_OF_WORD : constant INTEGER := WORD'LENGTH;
STEM_LENGTH : INTEGER := 0;
PR : PARSE_RECORD;
M : INTEGER := 1;
begin
--TEXT_IO.NEW_LINE;
--TEXT_IO.PUT_LINE("Called RUN_INFLECTIONS with =>" & WORD & "|");
if WORD'LENGTH = 0 then
SL(M) := NULL_PARSE_RECORD;
return;
end if;
SA := NOT_A_STEM_ARRAY;
-- Add all of these to list of possible ending records
-- since the blank ending agrees with everything
-- PACK/PRON have no blank endings
if ((RESTRICTION /= PACK_ONLY) and (RESTRICTION /= QU_PRON_ONLY)) and then
(WORD'LENGTH <= MAX_STEM_SIZE) then
for I in BELF(0, ' ')..BELL(0, ' ') loop
PR := (WORD & NULL_STEM_TYPE(LENGTH_OF_WORD+1..STEM_TYPE'LENGTH),
BEL(I), DEFAULT_DICTIONARY_KIND, NULL_MNPC);
SL(M) := PR;
M := M + 1;
end loop;
SA(LENGTH_OF_WORD) := PR.STEM; -- Is always a possibility (null ending)
end if;
-- Here we read in the INFLECTIONS_SECTION that is applicable
if RESTRICTION = REGULAR then
case LAST_OF_WORD is
when 'a' | 'c' | 'd' | 'e' | 'i' =>
READ(INFLECTIONS_SECTIONS_FILE, LEL, 1);
when 'm' | 'n' | 'o' | 'r' =>
READ(INFLECTIONS_SECTIONS_FILE, LEL, 2);
when 's' =>
READ(INFLECTIONS_SECTIONS_FILE, LEL, 3);
when 't' | 'u' =>
READ(INFLECTIONS_SECTIONS_FILE, LEL, 4);
when others =>
--PUT_LINE("Only blank inflections are found");
return;
end case;
elsif RESTRICTION = PACK_ONLY or RESTRICTION = QU_PRON_ONLY then
READ(INFLECTIONS_SECTIONS_FILE, LEL, 4);
end if;
-- Now do the non-blank endings -- Only go to LENGTH_OF_WORD
for Z in reverse 1..MIN(MAX_ENDING_SIZE, LENGTH_OF_WORD) loop
-- Check if Z agrees with a PDL SIZE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-- Maybe make PDL on size, if it has to be a list, or order by size if array
if LELL(Z, LAST_OF_WORD) > 0 then -- Any likely inflections at all
for I in LELF(Z, LAST_OF_WORD)..LELL(Z, LAST_OF_WORD) loop
if EQU(LOWER_CASE(LEL(I).ENDING.SUF(1..Z)),
LOWER_CASE(WORD(WORD'LAST-Z+1..WORD'LAST))) then
-- Add to list of possible ending records
--STEM_LENGTH := WORD'LENGTH - LEL(I).ENDING.SIZE;
STEM_LENGTH := WORD'LENGTH - Z;
--PUT(STEM_LENGTH);
--TEXT_IO.PUT_LINE("#######################################################");
if STEM_LENGTH <= MAX_STEM_SIZE then -- Reject too long words
-- Check if LEL IR agrees with PDL IR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
PR := (WORD(WORD'FIRST..STEM_LENGTH) &
NULL_STEM_TYPE(STEM_LENGTH+1..MAX_STEM_SIZE),
LEL(I), DEFAULT_DICTIONARY_KIND, NULL_MNPC);
SL(M) := PR;
M := M + 1;
SA(STEM_LENGTH) := PR.STEM; -- Gets set dozens of times
-- Could order the endings by length (suffix sort) so length changes slowly
--PUT_LINE("LENGTH = " & INTEGER'IMAGE(STEM_LENGTH)
--& " SA =>" & PR.STEM & "|");
end if;
end if;
end loop;
end if;
end loop;
--TEXT_IO.PUT_LINE("RUN_INF FOUND STEMS = " & INTEGER'IMAGE(M-1));
--exception
--when others =>
--TEXT_IO.PUT_LINE("exception RUN_INF FOUND STEMS = " & INTEGER'IMAGE(M-1));
--raise;
end RUN_INFLECTIONS;
procedure TRY_TO_LOAD_DICTIONARY(D_K : DICTIONARY_KIND) is
begin
-- PUT_LINE("Trying to load " & DICTIONARY_KIND'IMAGE(D_K) &
-- " dictionary from STEMFILE ");
STEM_IO.OPEN(STEM_FILE(D_K), STEM_IO.IN_FILE,
ADD_FILE_NAME_EXTENSION(STEM_FILE_NAME,
DICTIONARY_KIND'IMAGE(D_K)));
DICT_IO.OPEN(DICT_FILE(D_K), DICT_IO.IN_FILE,
ADD_FILE_NAME_EXTENSION(DICT_FILE_NAME,
DICTIONARY_KIND'IMAGE(D_K)));
LOAD_INDICES_FROM_INDX_FILE(ADD_FILE_NAME_EXTENSION(INDX_FILE_NAME,
DICTIONARY_KIND'IMAGE(D_K)), D_K);
DICTIONARY_AVAILABLE(D_K) := TRUE;
-- PUT_LINE("Successfully loaded " & DICTIONARY_KIND'IMAGE(D_K) &
-- " dictionary from STEMFILE ");
exception
when others =>
--PUT_LINE("Failed to load " & DICTIONARY_KIND'IMAGE(D_K) &
-- " dictionary from STEMFILE ");
DICTIONARY_AVAILABLE(D_K) := FALSE;
end TRY_TO_LOAD_DICTIONARY;
procedure DICTIONARY_SEARCH(SSA : STEM_ARRAY_TYPE;
PREFIX : PREFIX_ITEM;
SUFFIX : SUFFIX_ITEM;
D_K : DICTIONARY_KIND;
RESTRICTION : DICT_RESTRICTION := REGULAR) is
-- Prepares a PDL list of possible dictionary hits
-- Search a dictionary (D_K) looking for all stems that match
-- any of the stems that are physically possible with Latin inflections
use STEM_IO;
--type NAT_32 is range 0..2**31-1; --###############
J, J1, J2, JJ : STEM_IO.COUNT := 0;
INDEX_ON : constant STRING := SSA(SSA'LAST);
INDEX_FIRST, INDEX_LAST : STEM_IO.COUNT := 0;
DS : DICTIONARY_STEM;
FIRST_TRY, SECOND_TRY : BOOLEAN := TRUE;
function FIRST_TWO(W : STRING) return STRING is
-- 'v' could be represented by 'u', like the new Oxford Latin Dictionary
-- Fixes the first two letters of a word/stem which can be done right
S : constant STRING := LOWER_CASE(W);
SS : STRING(W'RANGE) := W;
function UI(C : CHARACTER) return CHARACTER is
begin
if (C = 'v') then
return 'u';
elsif (C = 'V') then
return 'U';
elsif (C = 'j') then
return 'i';
elsif (C = 'J') then
return 'I';
else
return C;
end if;
end UI;
begin
if S'LENGTH = 1 then
SS(S'FIRST) := UI(W(S'FIRST));
else
SS(S'FIRST) := UI(W(S'FIRST));
SS(S'FIRST+1) := UI(W(S'FIRST+1));
end if;
return SS;
end FIRST_TWO;
procedure LOAD_PDL is
begin
case RESTRICTION is
when REGULAR =>
if not (DS.PART.POFS = PACK or
(DS.PART.POFS = PRON and then
(DS.PART.PRON.DECL.WHICH = 1))) then
PDL_INDEX := PDL_INDEX + 1;
PDL(PDL_INDEX) := PRUNED_DICTIONARY_ITEM'(DS, D_K);
end if;
when PACK_ONLY =>
if DS.PART.POFS = PACK then
PDL_INDEX := PDL_INDEX + 1;
PDL(PDL_INDEX) := PRUNED_DICTIONARY_ITEM'(DS, D_K);
end if;
when QU_PRON_ONLY =>
if DS.PART.POFS = PRON and then
(DS.PART.PRON.DECL.WHICH = 1) then
PDL_INDEX := PDL_INDEX + 1;
PDL(PDL_INDEX) := PRUNED_DICTIONARY_ITEM'(DS, D_K);
end if;
when others =>
PDL_INDEX := PDL_INDEX + 1;
PDL(PDL_INDEX) := PRUNED_DICTIONARY_ITEM'(DS, D_K);
end case;
end LOAD_PDL;
begin
-- Now go through the dictionary list DL for the first letters
-- and make a reduced dictionary list PDL
--TEXT_IO.PUT_LINE("Entering DICTIONARY_SEARCH PDL_INDEX = " & INTEGER'IMAGE(PDL_INDEX));
if D_K = LOCAL then
INDEX_FIRST := FIRST_INDEX((FIRST_TWO(INDEX_ON)(1), 'a'), D_K);
INDEX_LAST := LAST_INDEX((FIRST_TWO(INDEX_ON)(1), 'a'), D_K);
else
INDEX_FIRST := FIRST_INDEX(FIRST_TWO(INDEX_ON), D_K);
INDEX_LAST := LAST_INDEX(FIRST_TWO(INDEX_ON), D_K);
end if;
if INDEX_FIRST > 0 and then INDEX_FIRST <= INDEX_LAST then
J1 := STEM_IO.COUNT(INDEX_FIRST); --######################
J2 := STEM_IO.COUNT(INDEX_LAST);
STEM_ARRAY_LOOP:
for K in SSA'RANGE loop
if TRIM(SSA(K))'LENGTH > 1 then
-- This may be checking for 0 and 1 letter SSAs which are done elsewhere
--TEXT_IO.PUT(INTEGER'IMAGE(K) & " SSA(K) =>" );
--TEXT_IO.PUT_LINE(SSA(K));
if D_K = LOCAL then -- Special processing for unordered DICT.LOC
for J in J1..J2 loop -- Sweep exaustively through the scope
SET_INDEX(STEM_FILE(D_K), STEM_IO.COUNT(J));
READ(STEM_FILE(D_K), DS);
if EQU(LOWER_CASE(DS.STEM), SSA(K)) then
--TEXT_IO.PUT_LINE("HIT LOC = " & DS.STEM & " - " & SSA(K));
LOAD_PDL;
end if;
end loop;
else -- Regular dictionaries
FIRST_TRY := TRUE;
SECOND_TRY := TRUE;
J := (J1 + J2) / 2;
BINARY_SEARCH:
loop
if (J1 = J2-1) or (J1 = J2) then
if FIRST_TRY then
--TEXT_IO.PUT_LINE("FIRST_TRY");
J := J1;
FIRST_TRY := FALSE;
elsif SECOND_TRY then
--TEXT_IO.PUT_LINE("SECOND_TRY");
J := J2;
SECOND_TRY := FALSE;
else
--TEXT_IO.PUT_LINE("THIRD_TRY exit BINARY_SEARCH");
JJ := J;
exit BINARY_SEARCH;
end if;
end if;
SET_INDEX(STEM_FILE(D_K), STEM_IO.COUNT(J));
READ(STEM_FILE(D_K), DS);
if LTU(LOWER_CASE(DS.STEM), SSA(K)) then
J1 := J;
J := (J1 + J2) / 2;
elsif GTU(LOWER_CASE(DS.STEM), SSA(K)) then
J2 := J;
J := (J1 + J2) / 2;
else
for I in reverse J1..J loop
SET_INDEX(STEM_FILE(D_K), STEM_IO.COUNT(I));
READ(STEM_FILE(D_K), DS);
if EQU(LOWER_CASE(DS.STEM), SSA(K)) then
JJ := I;
--TEXT_IO.PUT_LINE("PDL STEM " & DS.STEM & " " & INTEGER'IMAGE(INTEGER(DS.MNPC)));
LOAD_PDL;
else
exit;
end if;
end loop;
for I in J+1..J2 loop
SET_INDEX(STEM_FILE(D_K), STEM_IO.COUNT(I));
READ(STEM_FILE(D_K), DS);
if EQU(LOWER_CASE(DS.STEM), SSA(K)) then
JJ := I;
--TEXT_IO.PUT_LINE("PDL STEM " & DS.STEM & " " & INTEGER'IMAGE(INTEGER(DS.MNPC)));
LOAD_PDL;
else
exit BINARY_SEARCH;
end if;
end loop;
exit BINARY_SEARCH;
end if;
end loop BINARY_SEARCH;
J1 := JJ;
J2 := STEM_IO.COUNT(INDEX_LAST);
end if; -- On LOCAL check
end if; -- On LENGTH > 1
end loop STEM_ARRAY_LOOP;
end if;
--TEXT_IO.PUT_LINE("Leaving DICTIONARY_SEARCH PDL_INDEX = " & INTEGER'IMAGE(PDL_INDEX));
-- exception
-- when others =>
--TEXT_IO.PUT_LINE("exception DICTIONARY_SEARCH PDL_INDEX = " & INTEGER'IMAGE(PDL_INDEX));
-- raise;
end DICTIONARY_SEARCH;
procedure SEARCH_DICTIONARIES(SSA : in STEM_ARRAY_TYPE;
PREFIX : PREFIX_ITEM; SUFFIX : SUFFIX_ITEM;
RESTRICTION : DICT_RESTRICTION := REGULAR) is
use STEM_IO;
FC : CHARACTER := ' ';
begin
--PUT_LINE("Entering SEARCH_DICTIONARIES");
PDL := (others => NULL_PRUNED_DICTIONARY_ITEM);
PDL_INDEX := 0;
--PUT_LINE("Search for blank stems");
-- BDL is always used, so it is loaded initially and not called from disk
-- Check all stems of the dictionary entry against the reduced stems
-- Determine if there is a pure blank " " stem
if LEN(SSA(SSA'FIRST)) = 0 then -- a size would help?
--PUT("HIT on blank stem I = ");PUT('1');
--PUT(" STEM = ");PUT_LINE(BDL(1).STEM);
--PDL := new PRUNED_DICTIONARY_ITEM'(BDL(1), GENERAL, PDL);
PDL_INDEX := PDL_INDEX + 1;
PDL(PDL_INDEX) := PRUNED_DICTIONARY_ITEM'(BDL(1), GENERAL);
end if;
-- Now there is only one blank stem (2 of to_be), but need not always be so
-- Determine if there is a blank stem (SC = ' ')
-- Prepare for the posibility that one stem is short but there are others
FC := ' ';
if SSA(SSA'FIRST)(1) = ' ' then
if SSA'LENGTH > 1 and then SSA(SSA'FIRST+1)(2) = ' ' then
FC := SSA(SSA'FIRST+1)(1);
end if;
elsif SSA(SSA'FIRST)(2) = ' ' then
FC := SSA(SSA'FIRST)(1);
end if;
-- If there is a single letter stem (FC /= ' ') then
if FC /= ' ' then
for I in 2..BDL_LAST loop
-- Check all stems of the dictionary entry against the reduced stems
--if LOWER_CASE(BDL(I).STEM(1)) = FC then
if EQU(LOWER_CASE(BDL(I).STEM(1)), FC) then
--PUT("HIT on 1 letter stem I = ");PUT(I);PUT(" STEM = ");PUT_LINE(BDL(I).STEM);
PDL_INDEX := PDL_INDEX + 1;
PDL(PDL_INDEX) := PRUNED_DICTIONARY_ITEM'(BDL(I), GENERAL);
-- D_K set to GENERAL, but should not SPE have a chance? !!!!!!!!!
end if;
end loop;
end if;
if SSA'LENGTH = 0 then
-- PUT_LINE("Empty stem array, don't bother searching");
return;
-- elsif LEN(SSA(SSA'LAST)) <= 1 then
-- PUT_LINE("No two letter stems, have done searching");
-- else
-- PUT_LINE("Searching Dictionaries");
end if;
for D_K in DICTIONARY_KIND loop
if DICTIONARY_AVAILABLE(D_K) then
if not IS_OPEN(STEM_FILE(D_K)) then
OPEN(STEM_FILE(D_K), STEM_IO.IN_FILE,
ADD_FILE_NAME_EXTENSION(STEM_FILE_NAME,
DICTIONARY_KIND'IMAGE(D_K)));
end if;
DICTIONARY_SEARCH(SSA, PREFIX, SUFFIX, D_K, RESTRICTION);
CLOSE(STEM_FILE(D_K)); --??????
end if;
end loop;
--TEXT_IO.PUT_LINE("Leaving SEARCH_DICTIONARY PDL_INDEX = " & INTEGER'IMAGE(PDL_INDEX));
end SEARCH_DICTIONARIES;
procedure CHANGE_LANGUAGE(C : CHARACTER) is
begin if UPPER_CASE(C) = 'L' then
LANGUAGE := LATIN_TO_ENGLISH;
PREFACE.PUT_LINE("Language changed to " & LANGUAGE_TYPE'IMAGE(LANGUAGE));
elsif UPPER_CASE(C) = 'E' then
if ENGLISH_DICTIONARY_AVAILABLE(GENERAL) then
LANGUAGE:= ENGLISH_TO_LATIN;
PREFACE.PUT_LINE("Language changed to " & LANGUAGE_TYPE'IMAGE(LANGUAGE));
PREFACE.PUT_LINE("Input a single English word (+ part of speech - N, ADJ, V, PREP, ...)");
else
PREFACE.PUT_LINE("No English dictionary available");
end if;
else
PREFACE.PUT_LINE("Bad LANGAUGE input - no change, remains " & LANGUAGE_TYPE'IMAGE(LANGUAGE));
end if;
exception
when others =>
PREFACE.PUT_LINE("Bad LANGAUGE input - no change, remains " & LANGUAGE_TYPE'IMAGE(LANGUAGE));
end CHANGE_LANGUAGE;
procedure WORD(RAW_WORD : in STRING;
PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is
INPUT_WORD : constant STRING := LOWER_CASE(RAW_WORD);
PA_SAVE : INTEGER := PA_LAST;
UNIQUE_FOUND : BOOLEAN := FALSE;
SS, SSS : SAL := (others => NULL_PARSE_RECORD);
procedure ORDER_STEMS(SX : in out SAL) is
use INFLECTION_RECORD_IO;
use DICT_IO;
HITS : INTEGER := 0;
SL : SAL := SX;
SL_LAST : INTEGER := 0;
SM : PARSE_RECORD;
begin
if SX(1) = NULL_PARSE_RECORD then
return; end if;
--PUT_LINE("ORDERing_STEMS");
for I in SL'RANGE loop
exit when SL(I) = NULL_PARSE_RECORD;
SL_LAST := SL_LAST + 1;
end loop;
--PUT_LINE("In ORDER SL_LAST = " & INTEGER'IMAGE(SL_LAST));
-- Bubble sort since this list should usually be very small (1-5)
HIT_LOOP:
loop
HITS := 0;
SWITCH:
begin
-- Need to remove duplicates in ARRAY_STEMS
-- This sort is very sloppy
-- One problem is that it can mix up some of the order of PREFIX, XXX, LOC
-- I ought to do this for every set of results from different approaches
-- not just in one fell swoop at the end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
INNER_LOOP:
for I in 1..SL_LAST-1 loop
if SL(I+1) /= NULL_PARSE_RECORD then
if (SL(I+1).MNPC < SL(I).MNPC) or else
(SL(I+1).MNPC = SL(I).MNPC and then
SL(I+1).IR.ENDING.SIZE < SL(I).IR.ENDING.SIZE) or else
(SL(I+1).MNPC = SL(I).MNPC and then
SL(I+1).IR.ENDING.SIZE = SL(I).IR.ENDING.SIZE and then
SL(I+1).IR.QUAL < SL(I).IR.QUAL) or else
(SL(I+1).MNPC = SL(I).MNPC and then
SL(I+1).IR.ENDING.SIZE = SL(I).IR.ENDING.SIZE and then
SL(I+1).IR.QUAL = SL(I).IR.QUAL and then
SL(I+1).D_K < SL(I).D_K) then
--PUT(SL(I+1).IR.QUAL); PUT(" < "); PUT(SL(I).IR.QUAL); NEW_LINE;
SM := SL(I);
SL(I) := SL(I+1); SL(I+1) := SM;
SL(I+1) := SM;
HITS := HITS + 1;
--else
--PUT(SL(I+1).IR.QUAL); PUT(" >= "); PUT(SL(I).IR.QUAL); NEW_LINE;
end if;
else
exit INNER_LOOP;
end if;
end loop INNER_LOOP;
end SWITCH;
--NEW_LINE;
--PUT_LINE("In ORDER HITS = " & INTEGER'IMAGE(HITS ));
--NEW_LINE;
--for I in 1..SL_LAST loop
--PUT(SL(I)); NEW_LINE;
--end loop;
--PUT_LINE("--------------------------------------------------------");
exit when HITS = 0;
end loop HIT_LOOP;
SX := SL;
end ORDER_STEMS;
procedure ARRAY_STEMS(SX : in SAL;
PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is
SL : SAL := SX;
OPR : PARSE_RECORD := NULL_PARSE_RECORD;
begin
if SL(1) = NULL_PARSE_RECORD then
return;
else
OPR := NULL_PARSE_RECORD;
for I in SL'RANGE loop
if SL(I) /= NULL_PARSE_RECORD then
--PUT('*'); PUT(SL(I)); NEW_LINE;
SUPRESS_KEY_CHECK:
declare
function "<=" (A, B : PARSE_RECORD) return BOOLEAN is
use DICT_IO;
begin -- !!!!!!!!!!!!!!!!!!!!!!!!!!
if A.IR.QUAL = B.IR.QUAL and then
A.MNPC = B.MNPC then
return TRUE;
else
return FALSE;
end if;
end "<=";
begin
if SL(I) <= OPR then -- Get rid of duplicates, if ORDER is OK
--PUT('-'); PUT(SL(I)); NEW_LINE;
null;
else
PA_LAST := PA_LAST + 1;
--PUT('+'); PUT(SL(I)); NEW_LINE;
--PUT("SAL PR /= OPR and PA_LAST incremented to "); PUT(PA_LAST); NEW_LINE;
PA(PA_LAST) := SL(I);
OPR := SL(I);
end if;
end SUPRESS_KEY_CHECK;
else
exit;
end if;
end loop;
end if;
--TEXT_IO.PUT_LINE("At the end of ARRAY_STEMS");
--for I in 1..PA_LAST loop
--PUT(PA(I).STEM); PUT(" "); PUT(PA(I).IR); NEW_LINE;
--PUT(PA(I).D_K); PUT("> "); PUT(PA(I).AAMNPC.MNPC); NEW_LINE;
--end loop;
end ARRAY_STEMS;
procedure REDUCE_STEM_LIST(SL : in SAL; SXX : in out SAL;
-- Need in out if want to print it at the end
--procedure REDUCE_STEM_LIST(SL : in SAL; SXX : out SAL;
PREFIX : in PREFIX_ITEM := NULL_PREFIX_ITEM;
SUFFIX : in SUFFIX_ITEM := NULL_SUFFIX_ITEM) is
MNPC_PART : MNPC_TYPE := NULL_MNPC;
PDL_PART : PART_ENTRY;
COM : COMPARISON_TYPE := X;
NUM_SORT : NUMERAL_SORT_TYPE := X;
LS : INTEGER := 0;
M : INTEGER := 0;
PDL_KEY : STEM_KEY_TYPE;
PDL_P : PART_OF_SPEECH_TYPE;
SL_KEY : STEM_KEY_TYPE;
SL_P : PART_OF_SPEECH_TYPE;
function "<=" (LEFT, RIGHT : PART_OF_SPEECH_TYPE) return BOOLEAN is
begin
if RIGHT = LEFT or else
(LEFT = PACK and RIGHT = PRON) or else
RIGHT = X then
return TRUE;
else
return FALSE;
end if;
end "<=";
function "<=" (LEFT, RIGHT : GENDER_TYPE) return BOOLEAN is
begin
if (RIGHT = LEFT or else
(RIGHT = C and LEFT /= N) or else
(RIGHT = X)) then
return TRUE;
else
return FALSE;
end if;
end "<=";
function "<=" (LEFT, RIGHT : STEM_KEY_TYPE) return BOOLEAN is
begin
if (RIGHT = LEFT or else
(RIGHT = 0)) then
return TRUE;
else
return FALSE;
end if;
end "<=";
begin
SXX := (others => NULL_PARSE_RECORD); -- Essentially initializing
--for J in 1..PDL_INDEX loop
--NUMBER_IN_PDL := NUMBER_IN_PDL + 1;
--TEXT_IO.PUT(INTEGER'IMAGE(NUMBER_IN_PDL));
--TEXT_IO.PUT(" PDL "); TEXT_IO.PUT(PDL(J).DS.STEM);
--PART_ENTRY_IO.PUT(PDL(J).DS.PART);
--TEXT_IO.PUT(INTEGER'IMAGE(PDL(J).DS.KEY)); TEXT_IO.NEW_LINE;
--end loop;
--TEXT_IO.PUT_LINE("****************************");
--if WORDS_MODE(WRITE_STATISTICS_FILE) then
--declare
-- PSTAT : PRUNED_DICTIONARY_LIST := PDL;
--begin
-- TEXT_IO.PUT(STATS, "Number of PDL DICT hits");
-- TEXT_IO.SET_COL(STATS, 30);
-- INTEGER_IO.PUT(STATS, NUMBER_IN_PDL);
-- TEXT_IO.SET_COL(STATS, 40);
-- TEXT_IO.PUT(STATS, INPUT_WORD);
-- TEXT_IO.NEW_LINE(STATS);
--end;
--end if;
-------------------------------------------------------------
-- For the reduced dictionary list PDL
M := 0;
ON_PDL:
for J in 1..PDL_INDEX loop
PDL_PART := PDL(J).DS.PART;
PDL_KEY := PDL(J).DS.KEY;
MNPC_PART := PDL(J).DS.MNPC;
-- Is there any point in going through the process for this PDL
PDL_P := PDL(J).DS.PART.POFS; -- Used only for FIX logic below
-- If there is no SUFFIX then carry on
if (SUFFIX = NULL_SUFFIX_ITEM) then -- No suffix working, fall through
--PUT_LINE("No SUFFIX in REDUCE - Fall through to PREFIX check ");
null;
elsif
(PDL_P = N and then PDL_PART.N.DECL = (9, 8)) or -- No suffix for
(PDL_P = ADJ and then PDL_PART.ADJ.DECL = (9, 8)) then -- abbreviations
-- Can be no suffix on abbreviation");
goto END_OF_PDL_LOOP;
else -- There is SUFFIX, see if it agrees with PDL
if PDL_P <= SUFFIX.ENTR.ROOT and then -- Does SUFFIX agree in ROOT
((PDL_KEY <= SUFFIX.ENTR.ROOT_KEY) or else
((PDL_KEY = 0) and then
((PDL_P = N) or (PDL_P = ADJ) or (PDL_P = V)) and then
((SUFFIX.ENTR.ROOT_KEY = 1) or (SUFFIX.ENTR.ROOT_KEY = 2)))) then
--PUT_LINE("HIT HIT HIT HIT HIT HIT HIT HIT HIT SUFFIX SUFFIX in REDUCE");
case SUFFIX.ENTR.TARGET.POFS is -- Transform PDL_PART to TARGET
when N =>
PDL_PART := (N, SUFFIX.ENTR.TARGET.N);
when PRON =>
PDL_PART := (PRON, SUFFIX.ENTR.TARGET.PRON);
when ADJ =>
PDL_PART := (ADJ, SUFFIX.ENTR.TARGET.ADJ);
when NUM =>
PDL_PART := (NUM, SUFFIX.ENTR.TARGET.NUM);
when ADV =>
PDL_PART := (ADV, SUFFIX.ENTR.TARGET.ADV);
when V =>
PDL_PART := (V, SUFFIX.ENTR.TARGET.V);
when others =>
null; -- No others so far, except X = all
end case;
PDL_KEY := SUFFIX.ENTR.TARGET_KEY;
PDL_P := PDL_PART.POFS; -- Used only for FIX logic below
--PUT(" Changed to "); PUT(PDL_PART); PUT(PDL_KEY); NEW_LINE;
else
--PUT_LINE("In REDUCE_STEM_LIST There is no legal suffix");
-- exit;
goto END_OF_PDL_LOOP;
end if;
end if;
if (PREFIX = NULL_PREFIX_ITEM) then -- No PREFIX, drop through
--PUT_LINE("No PREFIX in REDUCE - Fall through to MATCHing ");
null;
elsif
(PDL_P = N and then PDL_PART.N.DECL = (9, 8)) or -- No prefix for
(PDL_P = ADJ and then PDL_PART.ADJ.DECL = (9, 8)) or -- abbreviations
(PDL_P = INTERJ or PDL_P = CONJ) then -- or INTERJ or CONJ
--PUT_LINE("In REDUCE_STEM_LIST no prefix on abbreviationi, interj, conj");
goto END_OF_PDL_LOOP;
else -- Check if PREFIX agrees
--PUT("PREFIX in REDUCE ");
--PUT(PDL_P); PUT(" <= "); PUT(PREFIX.ENTR.ROOT); PUT(" OR"); NEW_LINE;
--PUT(" "); PUT(PDL_PART); PUT(" <= ");
--PUT(PREFIX.ENTR.ROOT); NEW_LINE;
if (PDL_P = PREFIX.ENTR.ROOT) or -- = ROOT
(PDL_PART.POFS = PREFIX.ENTR.ROOT) then -- or part mod by suf
--PUT_LINE("PREFIX in REDUCE PART HIT");
null;
elsif (PREFIX.ENTR.ROOT = X) then -- or ROOT = X
if PDL_P = N or PDL_P = PRON or
PDL_P = ADJ or PDL_P = ADV or PDL_P = V then
-- Dont prefix PREP, CONJ, ...
-- PUT_LINE("PREFIX in REDUCE X HIT");
null;
end if;
else
goto END_OF_PDL_LOOP;
--PUT_LINE("In REDUCE_STEM_LIST There is no legal prefix");
-- exit;
end if;
end if;
-- SUFFIX and PREFIX either agree or don't exist (agrees with everything)
--PUT("ON_PDL:+ "); PUT(PDL(J).DS.STEM); PUT(PDL(J).DS.PART);
--PUT(PDL(J).DS.KEY); NEW_LINE;
--PUT_LINE(ADD_PREFIX(PDL(J).DS.STEM, PREFIX) & "|");
--PUT_LINE(ADD_SUFFIX(ADD_PREFIX(PDL(J).DS.STEM, PREFIX), SUFFIX) & "|");
LS := LEN(ADD_SUFFIX(ADD_PREFIX(PDL(J).DS.STEM, PREFIX), SUFFIX));
--PUT("LS = LEN of "); PUT(ADD_SUFFIX(ADD_PREFIX(PDL(J).DS.STEM, PREFIX), SUFFIX
--PUT(" = "); PUT(LS); NEW_LINE;
--TEXT_IO.PUT_LINE("Entering ON_SL loop");
ON_SL:
for I in SL'RANGE loop
exit when SL(I) = NULL_PARSE_RECORD;
--TEXT_IO.PUT("SL(I) "); PARSE_RECORD_IO.PUT(SL(I)); TEXT_IO.NEW_LINE;
--TEXT_IO.PUT(" PDL "); TEXT_IO.PUT(PDL(J).DS.STEM);
--PART_ENTRY_IO.PUT(PDL(J).DS.PART);
--TEXT_IO.PUT(INTEGER'IMAGE(PDL(J).DS.KEY)); TEXT_IO.NEW_LINE;
--TEXT_IO.PUT("LS "); TEXT_IO.PUT(INTEGER'IMAGE(LS));
--TEXT_IO.PUT(" LEN SL(I).STEM "); TEXT_IO.PUT_LINE(INTEGER'IMAGE(LEN(SL(I).STEM)));
if LS = LEN(SL(I).STEM) then
-- Scan through the whole unreduced stem list
-- Single out those stems that match (pruned) dictionary entries
--^^^^^^^^^^^^^^^^^should be able to do this better with new arrangement
SL_KEY := SL(I).IR.KEY;
SL_P := SL(I).IR.QUAL.POFS;
if (
((PDL_KEY <= SL(I).IR.KEY) ) or else
((PDL_KEY = 0) and then
(((PDL_P = N) or (PDL_P = ADJ) or (PDL_P = V)) and then
((SL(I).IR.KEY = 1) or (SL(I).IR.KEY = 2)) ))
) and then -- and KEY
( PDL_PART.POFS = EFF_PART(SL(I).IR.QUAL.POFS) ) then
--TEXT_IO.PUT_LINE("####################### PDL - SL MATCH ############");
if
(PDL_PART.POFS = N and then
PDL_PART.N.DECL <= SL(I).IR.QUAL.N.DECL and then
PDL_PART.N.GENDER <= SL(I).IR.QUAL.N.GENDER) then
--TEXT_IO.PUT_LINE(" HIT N ");
-- Need to transfer the gender of the noun dictionary item
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => N,
N => (
PDL_PART.N.DECL,
SL(I).IR.QUAL.N.CS,
SL(I).IR.QUAL.N.NUMBER,
PDL_PART.N.GENDER ) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif
(PDL_PART.POFS = PRON and then
PDL_PART.PRON.DECL <= SL(I).IR.QUAL.PRON.DECL) then
--PUT(" HIT PRON ");
-- Need to transfer the kind of the pronoun dictionary item
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => PRON,
PRON => (
PDL_PART.PRON.DECL,
SL(I).IR.QUAL.PRON.CS,
SL(I).IR.QUAL.PRON.NUMBER,
SL(I).IR.QUAL.PRON.GENDER ) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif (PDL_PART.POFS = ADJ) and then
(PDL_PART.ADJ.DECL <= SL(I).IR.QUAL.ADJ.DECL) and then
((SL(I).IR.QUAL.ADJ.CO <= PDL_PART.ADJ.CO ) or
((SL(I).IR.QUAL.ADJ.CO = X) or (PDL_PART.ADJ.CO = X))) then
-- Note the reversal on comparisom
--PUT(" HIT ADJ ");
-- Need to transfer the gender of the dictionary item
-- Need to transfer the CO of the ADJ dictionary item
if PDL_PART.ADJ.CO in POS..SUPER then
-- If the dictionary entry has a unique CO, use it
COM := PDL_PART.ADJ.CO;
else
-- Otherwise, the entry is X, generate a CO from KEY
COM := ADJ_COMP_FROM_KEY(PDL_KEY);
end if;
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => ADJ,
ADJ => (
PDL_PART.ADJ.DECL,
SL(I).IR.QUAL.ADJ.CS,
SL(I).IR.QUAL.ADJ.NUMBER,
SL(I).IR.QUAL.ADJ.GENDER,
COM ) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif (PDL_PART.POFS = NUM) and then
(PDL_PART.NUM.DECL <= SL(I).IR.QUAL.NUM.DECL) and then
(PDL_KEY = SL(I).IR.KEY) then
--PUT(" HIT NUM ");
if PDL_PART.NUM.SORT = X then
-- If the entry is X, generate a CO from KEY
NUM_SORT:= NUM_SORT_FROM_KEY(PDL_KEY);
else
-- Otherwise, the dictionary entry has a unique CO, use it
NUM_SORT := PDL_PART.NUM.SORT;
end if;
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => NUM,
NUM => (
PDL_PART.NUM.DECL,
SL(I).IR.QUAL.NUM.CS,
SL(I).IR.QUAL.NUM.NUMBER,
SL(I).IR.QUAL.NUM.GENDER,
NUM_SORT) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif (PDL_PART.POFS = ADV) and then
((PDL_PART.ADV.CO <= SL(I).IR.QUAL.ADV.CO ) or
((SL(I).IR.QUAL.ADV.CO = X) or (PDL_PART.ADV.CO = X))) then
--PUT(" HIT ADV ");
-- Need to transfer the CO of the ADV dictionary item
if PDL_PART.ADV.CO in POS..SUPER then
-- If the dictionary entry has a unique CO, use it
COM := PDL_PART.ADV.CO;
else
-- The entry is X and we need to generate a COMP from the KEY
COM := ADV_COMP_FROM_KEY(PDL_KEY);
end if;
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => ADV,
ADV => (
CO => COM) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif (PDL_PART.POFS = V) then
--TEXT_IO.PUT_LINE("V found, now check CON");
if SL(I).IR.QUAL.POFS = V and then
(PDL_PART.V.CON <= SL(I).IR.QUAL.V.CON) then
--TEXT_IO.PUT(" HIT V ");
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => V,
V => (
PDL_PART.V.CON,
SL(I).IR.QUAL.V.TENSE_VOICE_MOOD,
SL(I).IR.QUAL.V.PERSON,
SL(I).IR.QUAL.V.NUMBER ) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif SL(I).IR.QUAL.POFS = VPAR and then
(PDL_PART.V.CON <= SL(I).IR.QUAL.VPAR.CON) then
--PUT(" HIT VPAR ");
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => VPAR,
VPAR => (
PDL_PART.V.CON,
SL(I).IR.QUAL.VPAR.CS,
SL(I).IR.QUAL.VPAR.NUMBER,
SL(I).IR.QUAL.VPAR.GENDER,
SL(I).IR.QUAL.VPAR.TENSE_VOICE_MOOD ) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
elsif SL(I).IR.QUAL.POFS = SUPINE and then
(PDL_PART.V.CON <= SL(I).IR.QUAL.SUPINE.CON) then
--PUT(" HIT SUPINE");
M := M + 1;
SXX(M) := (STEM => SUBTRACT_PREFIX(SL(I).STEM, PREFIX),
IR => (
QUAL => (
POFS => SUPINE,
SUPINE => (
PDL_PART.V.CON,
SL(I).IR.QUAL.SUPINE.CS,
SL(I).IR.QUAL.SUPINE.NUMBER,
SL(I).IR.QUAL.SUPINE.GENDER) ),
KEY => SL(I).IR.KEY,
ENDING => SL(I).IR.ENDING,
AGE => SL(I).IR.AGE,
FREQ => SL(I).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => MNPC_PART);
end if;
elsif PDL_PART.POFS = PREP and then
PDL_PART.PREP.OBJ = SL(I).IR.QUAL.PREP.OBJ then
--PUT(" HIT PREP ");
M := M + 1;
SXX(M) := (SUBTRACT_PREFIX(SL(I).STEM, PREFIX), SL(I).IR,
PDL(J).D_K, MNPC_PART);
elsif PDL_PART.POFS = CONJ then
--PUT(" HIT CONJ ");
M := M + 1;
SXX(M) := (SUBTRACT_PREFIX(SL(I).STEM, PREFIX), SL(I).IR,
PDL(J).D_K, MNPC_PART);
elsif PDL_PART.POFS = INTERJ then
--PUT(" HIT INTERJ ");
M := M + 1;
SXX(M) := (SUBTRACT_PREFIX(SL(I).STEM, PREFIX), SL(I).IR,
PDL(J).D_K, MNPC_PART);
end if;
--TEXT_IO.NEW_LINE; PUT(SL(I).IR.QUAL); TEXT_IO.PUT(" -- ");
--TEXT_IO.PUT(PDL(J).DS.STEM); PUT(PDL_PART); TEXT_IO.NEW_LINE;
end if;
end if;
<<END_OF_SL_LOOP>> null;
end loop ON_SL;
--TEXT_IO.PUT("In RED_ST_L after loop ON_SL M = ");
--TEXT_IO.PUT(INTEGER'IMAGE(M)); TEXT_IO.NEW_LINE;
<<END_OF_PDL_LOOP>> null;
end loop ON_PDL;
--for I in 1..M loop
--TEXT_IO.PUT(INTEGER'IMAGE(I)); TEXT_IO.PUT(" ");
--PARSE_RECORD_IO.PUT(SXX(I)); TEXT_IO.NEW_LINE;
--end loop;
end REDUCE_STEM_LIST;
procedure APPLY_PREFIX(SA : in STEM_ARRAY_TYPE; SUFFIX : in SUFFIX_ITEM;
SX : in SAL; SXX : in out SAL;
PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is
-- Worry about the stem changing re-cipio from capio
-- Correspondence of parts, need EFF for VPAR
-- The prefixes should be ordered with the longest/most likely first
SSA : STEM_ARRAY;
L : INTEGER := 0;
--use TEXT_IO;
--use INFLECTIONS_PACKAGE.INTEGER_IO;
begin
--PUT_LINE("Entering APPLY_PREFIX");
SXX := (others => NULL_PARSE_RECORD); -- !!!!!!!!!!!!!!!!!!!!!!!
if WORDS_MDEV(USE_PREFIXES) then
--PUT(NUMBER_OF_PREFIXES); PUT(INTEGER(SA'LENGTH)); PUT(SA'LAST); NEW_LINE;
for I in 1..NUMBER_OF_PREFIXES loop -- Loop through PREFIXES
L := 0;
for J in SA'RANGE loop -- Loop through stem array
--PUT("J = "); PUT(J); PUT(" SA(J) = "); PUT(SA(J)); NEW_LINE;
if (SA(J)(1) = PREFIXES(I).FIX(1)) then -- Cuts down a little -- do better
if SUBTRACT_PREFIX(SA(J), PREFIXES(I)) /=
HEAD(SA(J), MAX_STEM_SIZE) then
--PUT_LINE("Hit on prefix " & PREFIXES(I).FIX);
--PUT("I = "); PUT(I); PUT(" "); PUT(PREFIXES(I).FIX); PUT(" ");
--PUT("J = "); PUT(J); PUT(" "); PUT(SA(J)); NEW_LINE;
L := L + 1; -- We have a hit, make new stem array item
SSA(L) := HEAD(SUBTRACT_PREFIX(SA(J), PREFIXES(I)),
MAX_STEM_SIZE); -- And that has prefix subtracted to match dict
--PUT("L = "); PUT(L); PUT(" "); PUT_LINE(SUBTRACT_PREFIX(SA(J), PREFIXES(I)));
end if; -- with prefix subtracted stems
end if;
end loop;
if L > 0 then -- There has been a prefix hit
SEARCH_DICTIONARIES(SSA(1..L), -- So run new dictionary search
PREFIXES(I), SUFFIX);
if PDL_INDEX /= 0 then -- Dict search was successful
--PUT_LINE("IN APPLY_PREFIX - PDL_INDEX not 0 after prefix " & PREFIXES(I).FIX);
--PUT_LINE("REDUCE_STEM_LIST being called from APPLY_PREFIX ---- SUFFIX = "
--& SUFFIX.FIX);
REDUCE_STEM_LIST(SX, SXX, PREFIXES(I), SUFFIX);
if SXX(1) /= NULL_PARSE_RECORD then -- There is reduced stem result
PA_LAST := PA_LAST + 1; -- So add prefix line to parse array
PA(PA_LAST).IR :=
((PREFIX, NULL_PREFIX_RECORD), 0, NULL_ENDING_RECORD, X, X);
PA(PA_LAST).STEM := HEAD(PREFIXES(I).FIX, MAX_STEM_SIZE);
PA(PA_LAST).MNPC := DICT_IO.COUNT(PREFIXES(I).MNPC);
PA(PA_LAST).D_K := ADDONS;
exit; -- Because we accept only one prefix
end if;
end if;
end if;
end loop; -- Loop on I for PREFIXES
end if; -- On USE_PREFIXES
end APPLY_PREFIX;
procedure APPLY_SUFFIX(SA : in STEM_ARRAY_TYPE;
SX : in SAL; SXX : in out SAL;
PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is
SSA : STEM_ARRAY;
L : INTEGER := 0;
SUFFIX_HIT : INTEGER := 0;
-- use TEXT_IO;
-- use INFLECTIONS_PACKAGE.INTEGER_IO;
begin
--PUT_LINE("Entering APPLY_SUFFIX");
--PUT(NUMBER_OF_SUFFIXES); PUT(INTEGER(SA'LENGTH)); PUT(SA'LAST); NEW_LINE;
for I in 1..NUMBER_OF_SUFFIXES loop -- Loop through SUFFIXES
L := 0; -- Take as many as fit
for J in SA'RANGE loop -- Loop through stem array
if SUBTRACT_SUFFIX(SA(J), SUFFIXES(I)) /=
HEAD(SA(J), MAX_STEM_SIZE) then
--PUT("Hit on suffix " & SUFFIXES(I).FIX & " " & SUFFIXES(I).CONNECT & " ");
--PUT(SUFFIXES(I).ENTR); NEW_LINE;
--PUT("I = "); PUT(I); PUT(" "); PUT(SUFFIXES(I).FIX); PUT(" ");
--PUT("J = "); PUT(J); PUT(" "); PUT(SA(J)); NEW_LINE;
L := L + 1; -- We have a hit, make new stem array item
SSA(L) := HEAD(SUBTRACT_SUFFIX(SA(J), SUFFIXES(I)),
MAX_STEM_SIZE); -- And that has prefix subtracted to match dict
--PUT("L = "); PUT(L); PUT(" "); PUT_LINE(SUBTRACT_SUFFIX(SA(J), SUFFIXES(I)));
end if;
end loop; -- Loop on J through SA
if L > 0 then -- There has been a suffix hit
SEARCH_DICTIONARIES(SSA(1..L),
NULL_PREFIX_ITEM, SUFFIXES(I)); -- So run new dictionary search
-- For suffixes we allow as many as match
if PDL_INDEX /= 0 then -- Dict search was successful
--PUT_LINE("IN APPLY_SUFFIX - PDL_INDEX not 0 after suffix " & SUFFIXES(I).FIX);
--PUT_LINE("REDUCE_STEM_LIST called from APPLY_SUFFIX");
SUFFIX_HIT := I;
REDUCE_STEM_LIST(SX, SXX, NULL_PREFIX_ITEM, SUFFIXES(I));
if SXX(1) /= NULL_PARSE_RECORD then -- There is reduced stem result
PA_LAST := PA_LAST + 1; -- So add suffix line to parse array
--PUT_LINE("REDUCE_STEM_LIST is not null so add suffix to parse array");
PA(PA_LAST).IR :=
((SUFFIX, NULL_SUFFIX_RECORD), 0, NULL_ENDING_RECORD, X, X);
PA(PA_LAST).STEM := HEAD(
SUFFIXES(SUFFIX_HIT).FIX, MAX_STEM_SIZE);
-- Maybe it would better if suffix.fix was of stem size
PA(PA_LAST).MNPC := DICT_IO.COUNT(SUFFIXES(SUFFIX_HIT).MNPC);
--PUT("SUFFIX MNPC "); PUT(SUFFIXES(SUFFIX_HIT).MNPC); NEW_LINE;
PA(PA_LAST).D_K := ADDONS;
---
for I in SXX'RANGE loop
exit when SXX(I) = NULL_PARSE_RECORD;
PA_LAST := PA_LAST + 1;
PA(PA_LAST) := SXX(I);
end loop;
---
end if;
else -- there is suffix (L /= 0) but no dictionary hit
SUFFIX_HIT := I;
--PUT_LINE(" -- there is suffix (L /= 0) but no dictionary hit");
--PUT("L = "); PUT(L); PUT(" ");
--PUT("SUFFIX_HIT = "); PUT(SUFFIXES(I).FIX); NEW_LINE;
APPLY_PREFIX(SSA(1..L), SUFFIXES(I), SX, SXX, PA, PA_LAST);
--PUT_LINE("PREFIXES applied from APPLY_SUFFIXES");
if SXX(1) /= NULL_PARSE_RECORD then -- There is reduced stem result
PA_LAST := PA_LAST + 1; -- So add suffix line to parse array
--PUT_LINE("REDUCE_STEM_LIST is not null so add suffix to parse array");
PA(PA_LAST).IR :=
((SUFFIX, NULL_SUFFIX_RECORD), 0, NULL_ENDING_RECORD, X, X);
PA(PA_LAST).STEM := HEAD(
SUFFIXES(SUFFIX_HIT).FIX, MAX_STEM_SIZE);
PA(PA_LAST).MNPC := DICT_IO.COUNT(SUFFIXES(SUFFIX_HIT).MNPC);
--PUT("SUFFIX MNPC "); PUT(SUFFIXES(SUFFIX_HIT).MNPC); NEW_LINE;
PA(PA_LAST).D_K := ADDONS;
for I in SXX'RANGE loop -- Set this set of results
exit when SXX(I) = NULL_PARSE_RECORD;
PA_LAST := PA_LAST + 1;
PA(PA_LAST) := SXX(I);
end loop;
end if;
end if;
end if; -- with suffix subtracted stems
end loop; -- Loop on I for SUFFIXES
end APPLY_SUFFIX;
procedure PRUNE_STEMS(INPUT_WORD : STRING; SX : in SAL; SXX : in out SAL) is
J : INTEGER := 0;
--SXX : SAL;
begin
--TEXT_IO.PUT_LINE("Entering PRUNE_STEMS INPUT_WORD = " & INPUT_WORD );
--TEXT_IO.PUT_LINE("In PRUNE PA_LAST = " & INTEGER'IMAGE(PA_LAST));
if SX(1) = NULL_PARSE_RECORD then
return; end if;
-----------------------------------------------------------------
GENERATE_REDUCED_STEM_ARRAY:
begin
--PUT_LINE("List of stems by size");
--NEW_LINE;
J := 1;
for Z in 0..MIN(MAX_STEM_SIZE, LEN(INPUT_WORD)) loop
if SA(Z) /= NOT_A_STEM then
--PUT(Z); PUT(J); PUT(" "); PUT_LINE(SA(Z));
SSA(J) := SA(Z);
SSA_MAX := J;
J := J + 1;
end if;
end loop;
--PUT_LINE("SSA_MAX = " & INTEGER'IMAGE(SSA_MAX));
--NEW_LINE(2);
end GENERATE_REDUCED_STEM_ARRAY;
--TEXT_IO.PUT_LINE("PRUNE_STEMS checking (not) DO_ONLY_FIXES = " & BOOLEAN'IMAGE(WORDS_MDEV(DO_ONLY_FIXES)));
if not WORDS_MDEV(DO_ONLY_FIXES) then -- Just bypass main dictionary search
--TEXT_IO.PUT_LINE("Calling SEARCH_DICTIONARIES from PRUNE_STEMS --- General case");
SEARCH_DICTIONARIES(SSA(1..SSA_MAX), NULL_PREFIX_ITEM, NULL_SUFFIX_ITEM);
--TEXT_IO.PUT_LINE("Finished SEARCH_DICTIONARIES from PRUNE_STEMS --- General case");
end if;
--TEXT_IO.PUT_LINE("PRUNE_STEMS passing over because of NOT DO_ONLY_FIXES");
-- ---------------------------------------------------------------
--TEXT_IO.PUT_LINE("PRUNE_STEMS below NOT DO_ONLY_FIXES PA_LAST = "
--& INTEGER'IMAGE(PA_LAST));
if (((PA_LAST = 0) and -- No Uniques or Syncope
(PDL_INDEX = 0)) --) and then -- No dictionary match
or WORDS_MDEV(DO_FIXES_ANYWAY)) and then
WORDS_MODE(DO_FIXES) then
----So try prefixes and suffixes, Generate a new SAA array, search again
--TEXT_IO.PUT_LINE(" PDL_INDEX = 0 after straight search ------ So APPLY_SUFFIX PA_LAST = " & INTEGER'IMAGE(PA_LAST));
if SXX(1) = NULL_PARSE_RECORD then -- We could not find a match with suffix
APPLY_PREFIX(SSA(1..SSA_MAX), NULL_SUFFIX_ITEM, SX, SXX, PA, PA_LAST);
end if;
--------------
if SXX(1) = NULL_PARSE_RECORD then -- We could not find a match with suffix
APPLY_SUFFIX(SSA(1..SSA_MAX), SX, SXX, PA, PA_LAST);
if SXX(1) = NULL_PARSE_RECORD then -- We could not find a match with suffix
----So try prefixes, Generate a new SAA array, search again
--TEXT_IO.PUT_LINE(" PDL_INDEX = 0 after suffix search ----- So APPLY_PREFIX by itself PA_LAST = " & INTEGER'IMAGE(PA_LAST));
----Need to use the new SSA, modified to include suffixes
APPLY_PREFIX(SSA(1..SSA_MAX), NULL_SUFFIX_ITEM, SX, SXX, PA, PA_LAST);
--TEXT_IO.PUT_LINE("PREFIXES applied PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--------------
end if; -- Suffix failed
end if; -- Suffix failed
else
--TEXT_IO.PUT_LINE(" PDL_INDEX not 0 after straight search ------ So REDUCE_STEMS PA_LAST = " & INTEGER'IMAGE(PA_LAST));
REDUCE_STEM_LIST(SX, SXX, NULL_PREFIX_ITEM, NULL_SUFFIX_ITEM);
if PA_LAST = 0 and then SXX(1) = NULL_PARSE_RECORD then
--TEXT_IO.PUT_LINE("Although PDL_INDEX not 0 after straight search , SXX fails PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--------------
if WORDS_MODE(DO_FIXES) then
APPLY_SUFFIX(SSA(1..SSA_MAX), SX, SXX, PA, PA_LAST);
--TEXT_IO.PUT_LINE("SUFFIXES applied PA_LAST = " & INTEGER'IMAGE(PA_LAST));
if SXX(1) = NULL_PARSE_RECORD then -- We could not find a match with suffix
----So try prefixes, Generate a new SAA array, search again
--TEXT_IO.PUT_LINE(" PDL_INDEX = 0 after suffix search ----- So APPLY_PREFIX by itself PA_LAST = " & INTEGER'IMAGE(PA_LAST));
----Need to use the new SSA, modified to include suffixes
APPLY_PREFIX(SSA(1..SSA_MAX), NULL_SUFFIX_ITEM,
SX, SXX, PA, PA_LAST);
--TEXT_IO.PUT_LINE("PREFIXES applied PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--------------
end if; -- Suffix failed
end if; -- If DO_FIXES then do
end if; -- First search passed but SXX null
end if; -- First search failed
--TEXT_IO.PUT_LINE("End of PRUNE_STEMS PA_LAST = " & INTEGER'IMAGE(PA_LAST));
end PRUNE_STEMS;
procedure PROCESS_PACKONS(INPUT_WORD : STRING; KEY : STEM_KEY_TYPE := 0) is
STEM_LENGTH : INTEGER := 0;
PR : PARSE_RECORD;
M : INTEGER := 1;
DE : DICTIONARY_ENTRY;
MEAN : MEANING_TYPE;
PACKON_FIRST_HIT : BOOLEAN := FALSE;
SL, SL_NULLS : SAL := (others => NULL_PARSE_RECORD);
function "<=" (LEFT, RIGHT : PRONOUN_KIND_TYPE) return BOOLEAN is
begin
if (RIGHT = LEFT or else
RIGHT = X) then
return TRUE;
elsif
(RIGHT = ADJECT and -- Just for PACK
LEFT = INDEF) then
return TRUE;
else
return FALSE;
end if;
end "<=";
begin
OVER_PACKONS:
for K in PACKONS'RANGE loop -- Do whole set, more than one may apply
--TEXT_IO.PUT_LINE("OVER_PACKONS K = "& INTEGER'IMAGE(K) & " PACKON = " & PACKONS(K).TACK);
-- PACKON if the TACKON ENTRY is PRON
FOR_EACH_PACKON:
declare
XWORD : constant STRING := SUBTRACT_TACKON(INPUT_WORD, PACKONS(K));
WORD : STRING(1..XWORD'LENGTH) := XWORD;
PACKON_LENGTH : constant INTEGER := TRIM(PACKONS(K).TACK)'LENGTH;
LAST_OF_WORD : CHARACTER := WORD(WORD'LAST);
LENGTH_OF_WORD : constant INTEGER := WORD'LENGTH;
begin
--PUT_LINE("FOR_EACH_PACKON WORD = |"& WORD & "|");
--PUT_LINE("FOR_EACH_PACKON PACKON_LENGTH = "& INTEGER'IMAGE(PACKON_LENGTH));
--PUT_LINE("FOR_EACH_PACKON LENGTH_OF_WORD = "& INTEGER'IMAGE(LENGTH_OF_WORD));
SL := SL_NULLS; -- Initialize SL to nulls
if WORD /= INPUT_WORD then
--PUT_LINE("PROCESS_PACKONS Hit on PACKON " & PACKONS(K).TACK);
PACKON_FIRST_HIT := TRUE;
if PACKONS(K).TACK(1..3) = "dam" and LAST_OF_WORD = 'n' then
WORD(WORD'LAST) := 'm'; -- Takes care of the m - > n shift with dam
LAST_OF_WORD := 'm';
--PUT_LINE("PACKON = dam and LAST_OF_WORD = n => " & WORD);
end if;
-- No blank endings in these pronouns
LEL_SECTION_IO.READ(INFLECTIONS_SECTIONS_FILE, LEL, 4);
M := 0;
ON_INFLECTS:
for Z in reverse 1..MIN(6, LENGTH_OF_WORD) loop -- optimum for qu-pronouns
--PUT("ON_INFLECTS Z = "); PUT(Z); PUT(" "); PUT(WORD(1..Z)); NEW_LINE;
if PELL(Z, LAST_OF_WORD) > 0 then -- Any possible inflections at all
for I in PELF(Z, LAST_OF_WORD)..PELL(Z, LAST_OF_WORD) loop
--PUT("+");PUT(LEL(I)); PUT(WORD'LAST); PUT(WORD(WORD'LAST-Z+1..WORD'LAST));
--PUT(" "); PUT((LEL(I).ENDING.SUF(1..Z))); NEW_LINE;
if (Z <= LENGTH_OF_WORD) and then
((EQU(LEL(I).ENDING.SUF(1..Z),
WORD(WORD'LAST-Z+1..WORD'LAST))) and
(LEL(I).QUAL.PRON.DECL <= PACKONS(K).ENTR.BASE.PACK.DECL)) then
-- Have found an ending that is a possible match
-- And INFLECT agrees with PACKON.BASE
--PUT_LINE("INFLECTS HIT ------------------------------------------------------");
-- Add to list of possible ending records
STEM_LENGTH := WORD'LENGTH - Z;
PR := (HEAD(WORD(WORD'FIRST..STEM_LENGTH), MAX_STEM_SIZE),
LEL(I), DEFAULT_DICTIONARY_KIND, NULL_MNPC);
M := M + 1;
SL(M) := PR;
SSA(1) := HEAD(WORD(WORD'FIRST.. WORD'FIRST+STEM_LENGTH-1),
MAX_STEM_SIZE);
--PUT_LINE("STEM_LENGTH = " & INTEGER'IMAGE(STEM_LENGTH));
--PUT_LINE("SSA(1) in PACKONS from real INFLECTS ->" & SSA(1) & '|');
-- may get set several times
end if;
end loop;
end if;
end loop ON_INFLECTS;
-- Only one stem will emerge
PDL_INDEX := 0;
SEARCH_DICTIONARIES(SSA(1..1), NULL_PREFIX_ITEM, NULL_SUFFIX_ITEM,
PACK_ONLY);
-- Now have a PDL, scan for agreement
PDL_LOOP:
for J in 1..PDL_INDEX loop -- Go through all dictionary hits to see
--PUT_LINE("PACKON PDL_INDEX "); PUT(PDL(J).DS.STEM); PUT(PDL(J).DS.PART); NEW_LINE;
-- M used here wher I is used in REDUCE, maybe make consistent
M := 1;
SL_LOOP:
while SL(M) /= NULL_PARSE_RECORD loop -- Over all inflection hits
-- if this stem is possible
-- call up the meaning to check for "(w/-"
DICT_IO.SET_INDEX(DICT_FILE(PDL(J).D_K), PDL(J).DS.MNPC);
DICT_IO.READ(DICT_FILE(PDL(J).D_K), DE);
MEAN := DE.MEAN;
if (TRIM(MEAN)(1..4) = "(w/-" and then -- Does attached PACKON agree
TRIM(MEAN)(5..4+PACKON_LENGTH) = TRIM(PACKONS(K).TACK)) then
--PUT_LINE("Mean = PACK Hit Hit ");
--PUT("MEAN|" & MEAN(1..4) & '|');
--PUT_LINE("PACK|" & TRIM(PACKONS(K).TACK) & '|');
--PUT("DECL PDL_INDEX "); PUT(PDL(J).DS.PART.PACK.DECL);
--PUT(" <= ? SL ");
--PUT(SL(M).IR.QUAL.PRON.DECL);
--PUT(" <= ? PACKON ");
--PUT(PACKONS(K).ENTR.BASE.PACK.DECL); NEW_LINE;
if (PDL(J).DS.PART.PACK.DECL = SL(M).IR.QUAL.PRON.DECL) then -- or
--PUT_LINE("DECL Hit Hit Hit Hit Hit Hit Hit Hit ");
--PUT("KINDS PACKON ");
--PUT(PACKONS(K).ENTR.BASE.PACK.KIND);
--PUT(" <= ? PDL_KIND ");
--PUT(PDL(J).DS.PART.PACK.KIND);
--NEW_LINE;
--if (PACKONS(K).ENTR.BASE.PACK.KIND <=
-- PDL(J).DS.PART.PACK.KIND) then
-- Then we have a hit and make a PA
--PUT_LINE("KIND Hit Hit Hit Hit Hit Hit Hit Hit Hit Hit Hit Hit Hit Hit Hit ");
if PACKON_FIRST_HIT then
PA_LAST := PA_LAST + 1;
PA(PA_LAST) := (PACKONS(K).TACK,
((TACKON, NULL_TACKON_RECORD), 0,
NULL_ENDING_RECORD, X, X),
ADDONS,
DICT_IO.COUNT((PACKONS(K).MNPC)));
PACKON_FIRST_HIT := FALSE;
end if;
PA_LAST := PA_LAST + 1;
--PUT_LINE("PACKON PDL HIT PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--PUT(PDL(J).DS.STEM); PUT(PDL(J).DS.PART); NEW_LINE;
--PUT_LINE(MEAN);
--PUT(PA(PA_LAST)); NEW_LINE;
PA(PA_LAST) := (STEM => SL(M).STEM,
IR => (
QUAL => (
POFS => PRON,
PRON => (
PDL(J).DS.PART.PACK.DECL,
SL(M).IR.QUAL.PRON.CS,
SL(M).IR.QUAL.PRON.NUMBER,
SL(M).IR.QUAL.PRON.GENDER )),
KEY => SL(M).IR.KEY,
ENDING => SL(M).IR.ENDING,
AGE => SL(M).IR.AGE,
FREQ => SL(M).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => PDL(J).DS.MNPC);
--end if;
end if;
end if;
M := M + 1;
end loop SL_LOOP;
end loop PDL_LOOP;
end if;
end FOR_EACH_PACKON;
PACKON_FIRST_HIT := FALSE;
end loop OVER_PACKONS;
end PROCESS_PACKONS;
procedure PROCESS_QU_PRONOUNS(INPUT_WORD : STRING; QKEY : STEM_KEY_TYPE := 0) is
WORD : constant STRING := LOWER_CASE(TRIM(INPUT_WORD));
LAST_OF_WORD : constant CHARACTER := WORD(WORD'LAST);
LENGTH_OF_WORD : constant INTEGER := WORD'LENGTH;
STEM_LENGTH : INTEGER := 0;
M : INTEGER := 0;
PR : PARSE_RECORD;
SL : SAL := (others => NULL_PARSE_RECORD);
begin
--TEXT_IO.PUT_LINE("PROCESS_QU_PRONOUNS " & INPUT_WORD);
-- No blank endings in these pronouns
LEL_SECTION_IO.READ(INFLECTIONS_SECTIONS_FILE, LEL, 4);
-- M used here while I is used in REDUCE, maybe make consistent
M := 0;
ON_INFLECTS:
for Z in reverse 1..MIN(4, LENGTH_OF_WORD) loop -- optimized for qu-pronouns
--PUT("ON_INFLECTS "); PUT(Z); PUT(" "); PUT(LAST_OF_WORD); NEW_LINE;
if PELL(Z, LAST_OF_WORD) > 0 then -- Any possible inflections at all
for I in PELF(Z, LAST_OF_WORD)..PELL(Z, LAST_OF_WORD) loop
--PUT(LEL(I)); PUT(WORD'LAST); PUT(WORD'LAST-Z+1); NEW_LINE;
if (Z <= LENGTH_OF_WORD) and then
LEL(I).KEY = QKEY and then
EQU(LEL(I).ENDING.SUF(1..Z),
WORD(WORD'LAST-Z+1..WORD'LAST)) then
-- Have found an ending that is a possible match
--PUT_LINE("INFLECTS HIT --------------------------------------------");
-- Add to list of possible ending records
STEM_LENGTH := WORD'LENGTH - Z;
PR := (HEAD(WORD(WORD'FIRST..STEM_LENGTH), MAX_STEM_SIZE),
LEL(I), DEFAULT_DICTIONARY_KIND, NULL_MNPC);
M := M + 1;
SL(M) := PR;
--PUT("M = "); PUT(M); PUT(" "); PUT(SL(M)); NEW_LINE;
SSA(1) := HEAD(WORD(WORD'FIRST.. WORD'FIRST+STEM_LENGTH-1),
MAX_STEM_SIZE);
-- may get set several times
end if;
end loop;
end if;
end loop ON_INFLECTS;
-- Only one stem will emerge
PDL_INDEX := 0;
SEARCH_DICTIONARIES(SSA(1..1), NULL_PREFIX_ITEM, NULL_SUFFIX_ITEM,
QU_PRON_ONLY);
-- Now have a PDL, scan for agreement
PDL_LOOP:
for J in 1..PDL_INDEX loop -- Go through all dictionary hits to see
M := 1;
SL_LOOP:
while SL(M) /= NULL_PARSE_RECORD loop -- Over all inflection hits
--PUT("SL_LOOP M = "); PUT(M); PUT(" SL => "); PUT(SL(M)); NEW_LINE; NEW_LINE;
--PUT("DECL PDL "); PUT(PDL(J).DS.PART.PRON.DECL);
--PUT(" <= ? SL ");
--PUT(SL(M).IR.QUAL.PRON.DECL);
--NEW_LINE;
if (PDL(J).DS.PART.PRON.DECL = SL(M).IR.QUAL.PRON.DECL) then
--PUT_LINE("DECL Hit Hit Hit Hit Hit Hit Hit Hit ");
PA_LAST := PA_LAST + 1;
--PUT_LINE("QU_PRON PDL HIT PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--PUT(PDL(J).DS.STEM); PUT(PDL(J).DS.PART); NEW_LINE;
--PUT(PA(PA_LAST)); NEW_LINE;
PA(PA_LAST) := (STEM => SL(M).STEM,
IR => (
QUAL => (
POFS => PRON,
PRON => (
PDL(J).DS.PART.PRON.DECL,
SL(M).IR.QUAL.PRON.CS,
SL(M).IR.QUAL.PRON.NUMBER,
SL(M).IR.QUAL.PRON.GENDER )),
KEY => SL(M).IR.KEY,
ENDING => SL(M).IR.ENDING,
AGE => SL(M).IR.AGE,
FREQ => SL(M).IR.FREQ),
D_K => PDL(J).D_K,
MNPC => PDL(J).DS.MNPC);
end if;
M := M + 1;
end loop SL_LOOP;
-- PDL:= PDL.SUCC;
end loop PDL_LOOP;
end PROCESS_QU_PRONOUNS;
procedure TRY_TACKONS(INPUT_WORD : STRING) is
TACKON_HIT : BOOLEAN := FALSE;
TACKON_ON : BOOLEAN := FALSE;
TACKON_LENGTH : constant INTEGER := 0;
J : INTEGER := 0;
DE : DICTIONARY_ENTRY := NULL_DICTIONARY_ENTRY;
MEAN : MEANING_TYPE := NULL_MEANING_TYPE;
ENTERING_PA_LAST : INTEGER := PA_LAST;
START_OF_LOOP : INTEGER := 5; -- 4 enclitics -- Hard number !!!!!!!!!!!!!!!
END_OF_LOOP : INTEGER := NUMBER_OF_TACKONS;
begin
--TEXT_IO.PUT_LINE("TRYing TACKONS *************** INPUT_WORD = " & INPUT_WORD);
LOOP_OVER_TACKONS:
for I in START_OF_LOOP..END_OF_LOOP loop
--PUT_LINE("TACKON #" & INTEGER'IMAGE(I) & " " &
--SUBTRACT_TACKON(INPUT_WORD, TACKONS(I)) & " + " & TACKONS(I).TACK);
REMOVE_A_TACKON:
declare
LESS : constant STRING :=
SUBTRACT_TACKON(INPUT_WORD, TACKONS(I));
begin
--TEXT_IO.PUT_LINE("LESS = " & LESS);
if LESS /= INPUT_WORD then -- LESS is less
--==========================================================
--RUN_UNIQUES(INPUT_WORD, UNIQUE_FOUND, PA, PA_LAST);
--RUN_INFLECTIONS(LESS, SS);
--PRUNE_STEMS(LESS, SS, SSS);
--if SSS(1) /= NULL_PARSE_RECORD then
--ORDER_STEMS(SSS);
--ARRAY_STEMS(SSS, PA, PA_LAST);
--SSS(1) := NULL_PARSE_RECORD;
--end if;
--==========================================================
WORD(LESS, PA, PA_LAST);
-- TEXT_IO.PUT("In TRY_TACKONS Left WORD ");
-- TEXT_IO.PUT("PA_LAST = "); TEXT_IO.PUT(INTEGER'IMAGE(PA_LAST)); TEXT_IO.PUT(" ");
-- TEXT_IO.PUT(TACKONS(I).TACK);
-- TEXT_IO.NEW_LINE;
-----------------------------------------
if PA_LAST > ENTERING_PA_LAST then -- we have a possible word
--TEXT_IO.PUT("I = " & INTEGER'IMAGE(I) & " " & TACKONS(I).TACK & " TACKONS(I).ENTR.BASE.PART = ");
--PART_OF_SPEECH_TYPE_IO.PUT(TACKONS(I).ENTR.BASE.PART); TEXT_IO.NEW_LINE;
if TACKONS(I).ENTR.BASE.POFS = X then -- on PART (= X?)
--PUT("TACKON X found "); PUT( TACKONS(I).TACK); NEW_LINE;
--PUT("PA_LAST = "); PUT(PA_LAST); PUT(" ");
--PUT("TACKON MNPC "); PUT( TACKONS(I).MNPC); NEW_LINE;
TACKON_HIT := TRUE;
--PUT("TACKON_HIT = "); PUT(TACKON_HIT); NEW_LINE;
TACKON_ON := FALSE;
else
J := PA_LAST;
while J >= ENTERING_PA_LAST+1 loop -- Sweep backwards over PA
-- Sweeping up inapplicable fixes,
-- although we only have TACKONs for X or PRON or ADJ - so far
-- and there are no fixes for PRON - so far
--TEXT_IO.PUT("J = " & INTEGER'IMAGE(J) & " PA(J).IR.QUAL = ");
--QUALITY_RECORD_IO.PUT(PA(J).IR.QUAL);
--TEXT_IO.NEW_LINE;
if ((PA(J).IR.QUAL.POFS = PREFIX) and then (TACKON_ON)) then
null; -- check PART
TACKON_ON := FALSE;
elsif ((PA(J).IR.QUAL.POFS = SUFFIX) and then (TACKON_ON)) then
-- check PART
null;
TACKON_ON := FALSE;
elsif PA(J).IR.QUAL.POFS = TACKONS(I).ENTR.BASE.POFS then
DICT_IO.SET_INDEX(DICT_FILE(PA(J).D_K), PA(J).MNPC);
DICT_IO.READ(DICT_FILE(PA(J).D_K), DE);
MEAN := DE.MEAN;
--TEXT_IO.PUT("J = " & INTEGER'IMAGE(J) & " PA(J).IR.QUAL = ");
--QUALITY_RECORD_IO.PUT(PA(J).IR.QUAL);
--TEXT_IO.NEW_LINE;
-- check PART
case TACKONS(I).ENTR.BASE.POFS is
when N =>
if (PA(J).IR.QUAL.N.DECL <=
TACKONS(I).ENTR.BASE.N.DECL) then
-- Ignore GEN and KIND
TACKON_HIT := TRUE;
TACKON_ON := TRUE;
end if;
when PRON => -- Only one we have other than X
--PUT("TACK/PA DECL "); PUT(PA(J).IR.QUAL.PRON.DECL); PUT(" - ");
--PUT(TACKONS(I).ENTR.BASE.PRON.DECL); NEW_LINE;
--PUT("TACK/PA KIND "); PUT(PA(J).IR.QUAL.PRON.KIND); PUT(" - ");
--PUT(TACKONS(I).ENTR.BASE.PRON.KIND); NEW_LINE;
if PA(J).IR.QUAL.PRON.DECL <=
TACKONS(I).ENTR.BASE.PRON.DECL --and then
--PA(J).IR.QUAL.PRON.KIND <=
--TACKONS(I).ENTR.BASE.PRON.KIND
then
--PUT("TACKON PRON found HIT "); PUT( TACKONS(I).TACK); NEW_LINE;
TACKON_HIT := TRUE;
TACKON_ON := TRUE;
else
PA(J..PA_LAST-1) := PA(J+1..PA_LAST);
PA_LAST := PA_LAST - 1;
end if;
when ADJ =>
-- Forego all checks, even on DECL of ADJ
-- -cumque is the only one I have now
-- if .......
TACKON_HIT := TRUE;
TACKON_ON := TRUE;
-- else
-- PA(J..PA_LAST-1) := PA(J+1..PA_LAST);
-- PA_LAST := PA_LAST - 1;
-- end if;
--when ADV =>
--when V =>
when others =>
PA(J..PA_LAST-1) := PA(J+1..PA_LAST);
PA_LAST := PA_LAST - 1;
end case;
else -- check PART
PA(J..PA_LAST-1) := PA(J+1..PA_LAST);
PA_LAST := PA_LAST - 1;
--PUT("J failed J & PA_LAST = "); PUT(J); PUT(" "); PUT(PA_LAST); NEW_LINE;
end if; -- check PART
J := J - 1;
end loop; -- loop sweep over PA
end if; -- on PART (= X?)
--PUT_LINE("End if on PART = X ?");
-----------------------------------------
if TACKON_HIT then
--PUT("Where it counts TACKON_HIT = "); PUT(TACKON_HIT); NEW_LINE;
-- Put on TACKON
PA_LAST := PA_LAST + 1;
PA(ENTERING_PA_LAST+2..PA_LAST) :=
PA(ENTERING_PA_LAST+1..PA_LAST-1);
PA(ENTERING_PA_LAST+1) := (TACKONS(I).TACK,
((TACKON, NULL_TACKON_RECORD), 0,
NULL_ENDING_RECORD, X, X),
ADDONS,
DICT_IO.COUNT((TACKONS(I).MNPC)));
--PUT("PA_LAST = "); PUT(PA_LAST); PUT(" ");
--PUT("I = "); PUT(I); PUT(" TACKONS(I).TACK = "); PUT(TACKONS(I).TACK);
--PUT_LINE("TACKON added");
--PUT_LINE("Now list the PA array after adding the found TACKON");
--for K in 1..PA_LAST loop
--PUT("K = "); PUT(K); PUT(" PA(K) "); PUT(PA(K).D_K); PUT(PA(K).IR); NEW_LINE;
--end loop;
return; -- Be happy with one ???????
else
null;
--PUT("No TACKON_HIT, so no punitive TACKON PA_LAST is ");
--PUT(PA_LAST); NEW_LINE;
end if; -- TACKON_HIT
end if; -- we have a possible word
-----------------------------------------
end if; -- LESS is less
end REMOVE_A_TACKON;
end loop LOOP_OVER_TACKONS;
--PUT_LINE("LEAVING TACKONS ******************************************* ");
end TRY_TACKONS;
begin -- WORD
--TEXT_IO.PUT_LINE("Starting WORD INPUT = " & INPUT_WORD & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
if TRIM(INPUT_WORD) = "" then
return;
end if;
RUN_UNIQUES(INPUT_WORD, UNIQUE_FOUND, PA, PA_LAST);
--if INPUT_WORD(INPUT_WORD'FIRST) in 'a'..'z' then
-- CONSTRUCT_STEMS(INPUT_WORD,
-- SEARCH_DICTIONARIES();
-- TRY_STEMS_AGAINST_INFLECTIONS;
-- end if;
--if INPUT_WORD(INPUT_WORD'FIRST) in 'a'..'z' then
--TEXT_IO.PUT_LINE("After UNIQUES INPUT = " & INPUT_WORD & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
QU:
declare
PA_QSTART : INTEGER := PA_LAST;
PA_START : INTEGER := PA_LAST;
SAVED_MODE_ARRAY : MODE_ARRAY := WORDS_MODE;
QKEY : STEM_KEY_TYPE := 0;
begin -- QU
TICKONS(NUMBER_OF_TICKONS+1) := NULL_PREFIX_ITEM;
WORDS_MODE := (others => FALSE);
for I in 1..NUMBER_OF_TICKONS+1 loop
declare
Q_WORD : constant STRING := TRIM(SUBTRACT_TICKON(INPUT_WORD, TICKONS(I)));
begin
PA_LAST := PA_QSTART;
PA(PA_LAST+1) := NULL_PARSE_RECORD;
if (I = NUMBER_OF_TICKONS + 1) or else -- The prefix is a TICKON
(Q_WORD /= INPUT_WORD) then -- and it matches the start of INPUT_WORD
if I <= NUMBER_OF_TICKONS then -- Add to PA if
--TEXT_IO.PUT_LINE("ADDING TICKON PA " & TICKONS(I).FIX);
PA_LAST := PA_LAST + 1; -- So add prefix line to parse array
PA(PA_LAST).STEM := HEAD(TICKONS(I).FIX, MAX_STEM_SIZE);
PA(PA_LAST).IR := ((PREFIX, NULL_PREFIX_RECORD), 0, NULL_ENDING_RECORD, X, X);
PA(PA_LAST).D_K := ADDONS;
PA(PA_LAST).MNPC := DICT_IO.COUNT(TICKONS(I).MNPC);
end if;
if Q_WORD'LENGTH >= 3 and then -- qui is shortest QU_PRON
((Q_WORD(Q_WORD'FIRST..Q_WORD'FIRST+1) = "qu") or
(Q_WORD(Q_WORD'FIRST..Q_WORD'FIRST+1) = "cu")) then
if Q_WORD(Q_WORD'FIRST..Q_WORD'FIRST+1) = "qu" then
QKEY := 1;
PROCESS_QU_PRONOUNS(Q_WORD, QKEY);
elsif Q_WORD(Q_WORD'FIRST..Q_WORD'FIRST+1) = "cu" then
QKEY := 2;
PROCESS_QU_PRONOUNS(Q_WORD, QKEY);
end if;
if PA_LAST <= PA_QSTART + 1 and then
QKEY > 0 then -- If did not find a PACKON
if Q_WORD(Q_WORD'FIRST..Q_WORD'FIRST+1) = "qu" then
PROCESS_PACKONS(Q_WORD, QKEY);
elsif Q_WORD(Q_WORD'FIRST..Q_WORD'FIRST+1) = "cu" then
PROCESS_PACKONS(Q_WORD, QKEY);
end if;
else
exit;
end if;
if PA_LAST > PA_QSTART + 1 then
exit;
end if;
elsif INPUT_WORD'LENGTH >= 6 then -- aliqui as aliQU_PRON
if INPUT_WORD(INPUT_WORD'FIRST..INPUT_WORD'FIRST+4) = "aliqu" then
PROCESS_QU_PRONOUNS(INPUT_WORD, 1);
elsif INPUT_WORD(INPUT_WORD'FIRST..INPUT_WORD'FIRST+4) = "alicu" then
PROCESS_QU_PRONOUNS(INPUT_WORD, 2);
end if;
end if;
if PA_LAST = PA_START + 1 then -- Nothing found
PA_LAST := PA_START; -- Reset PA_LAST
else
exit;
end if;
end if;
end;
end loop;
WORDS_MODE := SAVED_MODE_ARRAY;
exception
when others =>
WORDS_MODE := SAVED_MODE_ARRAY;
end QU;
--==========================================================
RUN_INFLECTIONS(INPUT_WORD, SS);
PRUNE_STEMS(INPUT_WORD, SS, SSS);
--TEXT_IO.PUT_LINE("After PRUNE INPUT = " & INPUT_WORD & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
if SSS(1) /= NULL_PARSE_RECORD then
ORDER_STEMS(SSS);
ARRAY_STEMS(SSS, PA, PA_LAST);
SSS(1) := NULL_PARSE_RECORD;
end if;
--TEXT_IO.PUT_LINE("After ARRAY INPUT = " & INPUT_WORD & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--==========================================================
if PA_LAST = PA_SAVE then
TRY_TACKONS(INPUT_WORD);
end if;
--TEXT_IO.PUT_LINE("Out WORD INPUT = " & INPUT_WORD & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
--TEXT_IO.SET_OUTPUT(TEXT_IO.STANDARD_OUTPUT);
exception
when STORAGE_ERROR =>
TEXT_IO.PUT_LINE(TEXT_IO.STANDARD_OUTPUT,
"STORAGE_ERROR exception in WORD while processing =>"
& RAW_WORD);
PA_LAST := PA_SAVE;
if WORDS_MODE(WRITE_UNKNOWNS_TO_FILE) then
TEXT_IO.PUT(UNKNOWNS, RAW_WORD);
TEXT_IO.SET_COL(UNKNOWNS, 21);
TEXT_IO.PUT_LINE(UNKNOWNS, "======== STORAGE_ERROR ");
end if;
when others =>
if WORDS_MODE(WRITE_UNKNOWNS_TO_FILE) then
TEXT_IO.PUT(UNKNOWNS, RAW_WORD);
TEXT_IO.SET_COL(UNKNOWNS, 21);
TEXT_IO.PUT_LINE(UNKNOWNS, "======== ERROR ");
end if;
PA_LAST := PA_SAVE;
end WORD;
procedure INITIALIZE_WORD_PACKAGE is
begin -- Initializing WORD_PACKAGE
ESTABLISH_INFLECTIONS_SECTION;
LEL_SECTION_IO.OPEN(INFLECTIONS_SECTIONS_FILE, LEL_SECTION_IO.IN_FILE,
INFLECTIONS_SECTIONS_NAME);
TRY_TO_LOAD_DICTIONARY(GENERAL);
TRY_TO_LOAD_DICTIONARY(SPECIAL);
LOAD_LOCAL:
begin
-- First check if there is a LOC dictionary
CHECK_FOR_LOCAL_DICTIONARY:
declare
DUMMY : TEXT_IO.FILE_TYPE;
begin
TEXT_IO.OPEN(DUMMY, TEXT_IO.IN_FILE,
ADD_FILE_NAME_EXTENSION(DICTIONARY_FILE_NAME,
"LOCAL"));
-- Failure to OPEN will raise an exception, to be handled below
TEXT_IO.CLOSE(DUMMY);
end CHECK_FOR_LOCAL_DICTIONARY;
-- If the above does not exception out, we can load LOC
PREFACE.PUT("LOCAL ");
DICT_LOC := NULL_DICTIONARY;
LOAD_DICTIONARY(DICT_LOC,
ADD_FILE_NAME_EXTENSION(DICTIONARY_FILE_NAME, "LOCAL"));
-- Need to carry LOC through consistently on LOAD_D and LOAD_D_FILE
LOAD_STEM_FILE(LOCAL);
DICTIONARY_AVAILABLE(LOCAL) := TRUE;
exception
when others =>
DICTIONARY_AVAILABLE(LOCAL) := FALSE;
end LOAD_LOCAL;
LOAD_UNIQUES(UNQ, UNIQUES_FULL_NAME);
LOAD_ADDONS(ADDONS_FULL_NAME);
--TEXT_IO.PUT_LINE("Loaded ADDONS");
LOAD_BDL_FROM_DISK;
--TEXT_IO.PUT_LINE("BDL loaded");
if not (DICTIONARY_AVAILABLE(GENERAL) or
DICTIONARY_AVAILABLE(SPECIAL) or
DICTIONARY_AVAILABLE(LOCAL)) then
PREFACE.PUT_LINE("There are no main dictionaries - program will not do much");
PREFACE.PUT_LINE("Check that there are dictionary files in this subdirectory");
PREFACE.PUT_LINE("Except DICT.LOC that means DICTFILE, INDXFILE, STEMFILE");
end if;
--TEXT_IO.PUT_LINE("Ready to load English");
TRY_TO_LOAD_ENGLISH_WORDS:
begin
ENGLISH_DICTIONARY_AVAILABLE(GENERAL) := FALSE;
EWDS_DIRECT_IO.OPEN(EWDS_FILE, EWDS_DIRECT_IO.IN_FILE, "EWDSFILE.GEN");
ENGLISH_DICTIONARY_AVAILABLE(GENERAL) := TRUE;
exception
when others =>
PREFACE.PUT_LINE("No English available");
ENGLISH_DICTIONARY_AVAILABLE(GENERAL) := FALSE;
end TRY_TO_LOAD_ENGLISH_WORDS;
--put_line("WORD_PACKAGE INITIALIZED");
end INITIALIZE_WORD_PACKAGE;
end WORD_PACKAGE;
Reference in New Issue View Git Blame Copy Permalink