with TEXT_IO;

with STRINGS_PACKAGE; use STRINGS_PACKAGE;

with WORD_PARAMETERS; use WORD_PARAMETERS;

with DEVELOPER_PARAMETERS; use DEVELOPER_PARAMETERS;

with INFLECTIONS_PACKAGE; use INFLECTIONS_PACKAGE;

with DICTIONARY_PACKAGE; use DICTIONARY_PACKAGE;

with WORD_SUPPORT_PACKAGE; use WORD_SUPPORT_PACKAGE;

with WORD_PACKAGE; use WORD_PACKAGE;

with PUT_STAT;

package body TRICKS_PACKAGE is

function IS_A_VOWEL(C : CHARACTER) return BOOLEAN is

begin

if LOWER_CASE(C) = 'a' or

LOWER_CASE(C) = 'e' or

LOWER_CASE(C) = 'i' or

LOWER_CASE(C) = 'o' or

LOWER_CASE(C) = 'u' or

LOWER_CASE(C) = 'y' then

return TRUE;

else

return FALSE;

end if;

end IS_A_VOWEL;

function A_ROMAN_DIGIT(CHAR : CHARACTER) return BOOLEAN is

begin

case CHAR is

when 'M' | 'm' =>

return TRUE;

when 'D' | 'd' =>

return TRUE;

when 'C' | 'c' =>

return TRUE;

when 'L' | 'l' =>

return TRUE;

when 'X' | 'x' =>

return TRUE;

--when 'U' | 'u' => return TRUE; -- possible but unlikely

when 'V' | 'v' =>

return TRUE;

when 'I' | 'i' =>

return TRUE;

when others =>

return FALSE;

end case;

end A_ROMAN_DIGIT;

function VALUE(CHAR : CHARACTER) return NATURAL is

begin

case CHAR is

when 'M' | 'm' =>

return 1000;

when 'D' | 'd' =>

return 500;

when 'C' | 'c' =>

return 100;

when 'L' | 'l' =>

return 50;

when 'X' | 'x' =>

return 10;

--when 'U' | 'u' => return 5; -- possible but unlikely

when 'V' | 'v' =>

return 5;

when 'I' | 'i' =>

return 1;

when others =>

return 0;

end case;

end VALUE;

function ONLY_ROMAN_DIGITS(S : STRING) return BOOLEAN is

begin

for I in S'range loop

if not A_ROMAN_DIGIT(S(I)) then

return FALSE;

end if;

end loop;

return TRUE;

end ONLY_ROMAN_DIGITS;

function ROMAN_NUMBER(ST : STRING) return NATURAL is

-- Determines and returns the value of a Roman numeral, or 0 if invalid

use TEXT_IO;

TOTAL : NATURAL := 0;

INVALID : exception;

DECREMENTED : BOOLEAN := FALSE;

J : INTEGER := 0;

S : constant STRING := UPPER_CASE(ST);

begin

if ONLY_ROMAN_DIGITS(S) then

J := S'LAST;

EVALUATE:

while J >= S'FIRST loop

-- Ones

if S(J) = 'I' then

TOTAL := TOTAL + 1;

J := J - 1;

exit EVALUATE when J < S'FIRST;

whiLe S(J) = 'I' loop

TOTAL := TOTAL + 1;

if TOTAL >= 5 then raise INVALID; end if;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end loop;

end if;

if S(J) = 'V' then

TOTAL := TOTAL + 5;

J := J - 1;

exit EVALUATE when J < S'FIRST;

if S(J) = 'I' and TOTAL = 5 then

TOTAL := TOTAL - 1;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'I' or S(J) = 'V' then raise INVALID; end if;

end if;

-- Tens

if S(J) = 'X' then

TOTAL := TOTAL + 10;

J := J - 1;

exit EVALUATE when J < S'FIRST;

whiLe S(J) = 'X' loop

TOTAL := TOTAL + 10;

if TOTAL >= 50 then raise INVALID; end if;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end loop;

if S(J) = 'I' and TOTAL = 10 then

TOTAL := TOTAL - 1;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'I' or S(J) = 'V' then

raise INVALID;

end if;

end if;

if S(J) = 'L' then

TOTAL := TOTAL + 50;

J := J - 1;

exit EVALUATE when J < S'FIRST;

if S(J) = 'X' and TOTAL <= 59 then

TOTAL := TOTAL - 10;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' then raise INVALID; end if;

if S(J) = 'C' then

TOTAL := TOTAL + 100;

J := J - 1;

exit EVALUATE when J < S'FIRST;

if S(J) = 'X' and TOTAL = 100 then

TOTAL := TOTAL - 10;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

end if;

if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' then raise INVALID; end if;

end if;

if S(J) = 'C' then

TOTAL := TOTAL + 100;

J := J - 1;

exit EVALUATE when J < S'FIRST;

whiLe S(J) = 'C' loop

TOTAL := TOTAL + 100;

if TOTAL >= 500 then raise INVALID; end if;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end loop;

if S(J) = 'X' and TOTAL <= 109 then

TOTAL := TOTAL - 10;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' then raise INVALID; end if;

end if;

if S(J) = 'D' then

TOTAL := TOTAL + 500;

J := J - 1;

exit EVALUATE when J < S'FIRST;

if S(J) = 'C' and TOTAL <= 599 then

TOTAL := TOTAL - 100;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'M' then

TOTAL := TOTAL + 1000;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'C' and TOTAL <= 1099 then

TOTAL := TOTAL - 100;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' or S(J) = 'C' or S(J) = 'D' then raise INVALID; end if;

end if;

if S(J) = 'M' then

TOTAL := TOTAL + 1000;

J := J - 1;

exit EVALUATE when J < S'FIRST;

whiLe S(J) = 'M' loop

TOTAL := TOTAL + 1000;

if TOTAL >= 5000 then raise INVALID; end if;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end loop;

if S(J) = 'C' and TOTAL <= 1099 then

TOTAL := TOTAL - 100;

J := J - 1;

exit EVALUATE when J < S'FIRST;

end if;

if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' or S(J) = 'C' or S(J) = 'D' then raise INVALID; end if;

end if;

end loop EVALUATE;

end if; -- On Only Roman digits

return TOTAL;

exception

when INVALID =>

return 0;

when CONSTRAINT_ERROR =>

return 0;

end ROMAN_NUMBER;

procedure ROMAN_NUMERALS(INPUT_WORD : STRING;

PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is

W : constant STRING := TRIM(INPUT_WORD);

ROMAN_NUMBER_W : INTEGER := ROMAN_NUMBER(W);

begin

if ONLY_ROMAN_DIGITS(W) and then (ROMAN_NUMBER_W /= 0) then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := ( STEM => HEAD(W, MAX_STEM_SIZE),

IR => (

QUAL => (

POFS => NUM,

NUM => (

DECL => (2, 0),

CS => X,

NUMBER => X,

GENDER => X,

SORT => CARD) ),

KEY => 0,

ENDING => NULL_ENDING_RECORD,

AGE => X,

FREQ => A),

D_K => RRR,

MNPC => NULL_MNPC);

RRR_MEANING := HEAD(INTEGER'IMAGE(ROMAN_NUMBER_W) & " as a ROMAN NUMERAL;",

MAX_MEANING_SIZE);

else

null; -- Is not ROMAN NUMERAL, so go on and try something else

end if;

end ROMAN_NUMERALS;

function BAD_ROMAN_NUMBER(S : STRING) return NATURAL is

-- Determines and returns the value of a Roman numeral, or 0 if invalid

-- This seems to allow all of Caesar's. Actually there are no rules

-- if you look at some of the 12-15 century stuff

use TEXT_IO;

TOTAL : INTEGER := 0;

DECREMENTED_FROM : INTEGER := 0;

begin

-- Already known that all the characters may be valid numerals

-- Loop over the string to check validity, start with second place

--PUT_LINE(" In function BAD_ROMAN_NUMBER ");

--PUT_LINE(" BEFORE LOOP S = " & S);

TOTAL := VALUE(S(S'LAST));

DECREMENTED_FROM := VALUE(S(S'LAST));

for I in reverse S'FIRST..S'LAST-1 loop

if VALUE(S(I)) < VALUE(S(I+1)) then

-- Decrement

TOTAL := TOTAL - VALUE(S(I));

DECREMENTED_FROM := VALUE(S(I+1));

elsif VALUE(S(I)) = VALUE(S(I+1)) then

if VALUE(S(I)) < DECREMENTED_FROM then

TOTAL := TOTAL - VALUE(S(I)); -- IIX = 8 !

else

TOTAL := TOTAL + VALUE(S(I));

end if;

elsif VALUE(S(I)) > VALUE(S(I+1)) then

TOTAL := TOTAL + VALUE(S(I));

DECREMENTED_FROM := VALUE(S(I+1));

end if;

end loop;

if TOTAL > 0 then

return TOTAL;

else

return 0;

end if;

exception

when others =>

return 0;

end BAD_ROMAN_NUMBER;

procedure SYNCOPE(W : STRING;

PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is

S : constant STRING(1..W'LENGTH) := LOWER_CASE(W);

PA_SAVE : INTEGER := PA_LAST;

SYNCOPE_INFLECTION_RECORD : INFLECTION_RECORD := NULL_INFLECTION_RECORD;

-- ((V, ((0, 0), (X, X, X), 0, X, X)), 0, NULL_ENDING_RECORD, X, A);

begin

-- Syncopated forms (see Gildersleeve and Lodge, 131)

YYY_MEANING := NULL_MEANING_TYPE;

-- This one has to go first -- special for 3 4

-- ivi => ii , in perfect (esp. for V 3 4)

-- This is handled in WORDS as syncope

-- It seems to appear in texts as alternative stems ii and ivi

for I in reverse S'FIRST..S'LAST-1 loop

if (S(I..I+1) = "ii") then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := ("Syncope ii => ivi", SYNCOPE_INFLECTION_RECORD,

YYY, NULL_MNPC);

WORD(S(S'FIRST..I) & "v" & S(I+1..S'LAST), PA, PA_LAST);

if PA_LAST > PA_SAVE + 1 then

exit;

end if;

end if;

PA_LAST := PA_SAVE; -- No luck, or it would have exited above

end loop;

if PA_LAST > PA_SAVE + 1 and then

PA(PA_LAST).IR.QUAL.POFS = V and then

--PA(PA_LAST).IR.QUAL.V.CON = (3, 4)/(6, 1) and then

PA(PA_LAST).IR.KEY = 3 then -- Perfect system

YYY_MEANING := HEAD(

"Syncopated perfect ivi can drop 'v' without contracting vowel "

, MAX_MEANING_SIZE);

PUT_STAT("SYNCOPE ivi at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

-- avis => as, evis => es, ivis => is, ovis => os in perfect

for I in reverse S'FIRST..S'LAST-2 loop -- Need isse

if ((S(I..I+1) = "as") or

(S(I..I+1) = "es") or

(S(I..I+1) = "is") or

(S(I..I+1) = "os")) then

--TEXT_IO.PUT_LINE("SYNCOPE vis S = " & S & " PA_SAVE = " & INTEGER'IMAGE(PA_SAVE));

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := ("Syncope s => vis", SYNCOPE_INFLECTION_RECORD,

YYY, NULL_MNPC);

--TEXT_IO.PUT_LINE("SYNCOPE vis S+ = " & S(S'FIRST..I) & "vi" & S(I+1..S'LAST) & " " & INTEGER'IMAGE(PA_LAST));

WORD(S(S'FIRST..I) & "vi" & S(I+1..S'LAST), PA, PA_LAST);

--TEXT_IO.PUT_LINE("SYNCOPE vis DONE " & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));

if PA_LAST > PA_SAVE + 1 then

exit; -- Exit loop here if SYNCOPE found hit

end if;

end if;

PA_LAST := PA_SAVE; -- No luck, or it would have exited above

end loop;

-- Loop over the resulting solutions

if PA_LAST > PA_SAVE + 1 and then

PA(PA_LAST).IR.QUAL.POFS = V and then

PA(PA_LAST).IR.KEY = 3 then -- Perfect system

YYY_MEANING := HEAD(

"Syncopated perfect often drops the 'v' and contracts vowel "

, MAX_MEANING_SIZE);

PUT_STAT("SYNCOPE vis at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

end if;

-- end loop; -- over resulting solutions

if PA_LAST > PA_SAVE + 1 then

return;

else

PA_LAST := PA_SAVE;

end if;

-- aver => ar, ever => er, in perfect

for I in reverse S'FIRST+1..S'LAST-2 loop

if ((S(I..I+1) = "ar") or

(S(I..I+1) = "er") or

(S(I..I+1) = "or")) then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := ("Syncope r => v.r", SYNCOPE_INFLECTION_RECORD,

YYY, NULL_MNPC);

WORD(S(S'FIRST..I) & "ve" & S(I+1..S'LAST), PA, PA_LAST);

if PA_LAST > PA_SAVE + 1 then

exit;

end if;

end if;

PA_LAST := PA_SAVE; -- No luck, or it would have exited above

end loop;

if PA_LAST > PA_SAVE + 1 and then

PA(PA_LAST).IR.QUAL.POFS = V and then

PA(PA_LAST).IR.KEY = 3 then -- Perfect system

YYY_MEANING := HEAD(

"Syncopated perfect often drops the 'v' and contracts vowel "

, MAX_MEANING_SIZE);

PUT_STAT("SYNCOPE ver at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

-- iver => ier, in perfect

for I in reverse S'FIRST..S'LAST-3 loop

if (S(I..I+2) = "ier") then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := ("Syncope ier=>iver", SYNCOPE_INFLECTION_RECORD,

YYY, NULL_MNPC);

WORD(S(S'FIRST..I) & "v" & S(I+1..S'LAST), PA, PA_LAST);

if PA_LAST > PA_SAVE + 1 then

exit;

end if;

end if;

PA_LAST := PA_SAVE; -- No luck, or it would have exited above

end loop;

if PA_LAST > PA_SAVE + 1 and then

PA(PA_LAST).IR.QUAL.POFS = V and then

PA(PA_LAST).IR.KEY = 3 then -- Perfect system

YYY_MEANING := HEAD(

"Syncopated perfect often drops the 'v' and contracts vowel "

, MAX_MEANING_SIZE);

PUT_STAT("SYNCOPE ier at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

for I in reverse S'FIRST..S'LAST-2 loop

if ((S(I) = 's') or

(S(I) = 'x')) then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := ("Syncope s/x => +is", SYNCOPE_INFLECTION_RECORD,

YYY, NULL_MNPC);

WORD(S(S'FIRST..I) & "is" & S(I+1..S'LAST), PA, PA_LAST);

if PA_LAST > PA_SAVE + 1 then

exit; -- Exit loop here if SYNCOPE found hit

end if;

end if;

PA_LAST := PA_SAVE; -- No luck, or it would have exited above

end loop;

-- Loop over the resulting solutions

if PA_LAST > PA_SAVE + 1 and then

PA(PA_LAST).IR.QUAL.POFS = V and then

PA(PA_LAST).IR.KEY = 3 then -- Perfect system

YYY_MEANING := HEAD(

"Syncopated perfect sometimes drops the 'is' after 's' or 'x' "

, MAX_MEANING_SIZE);

PUT_STAT("SYNCOPEx/sis at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

-- end loop; -- over resulting solutions

if PA_LAST > PA_SAVE + 1 then

return;

else

PA_LAST := PA_SAVE;

end if;

PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys

exception

when others =>

PA_LAST := PA_SAVE;

PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys

end SYNCOPE;

procedure TRY_TRICKS(W : STRING;

PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER;

LINE_NUMBER : INTEGER; WORD_NUMBER : INTEGER) is

-- Since the chances are 1/1000 that we have one,

-- Ignore the possibility of two in the same word

-- That is called lying with statistics

use INFLECTIONS_PACKAGE.INTEGER_IO;

S : constant STRING(1..W'LENGTH) := W;

PA_SAVE : INTEGER := PA_LAST;

procedure TWORD(W : STRING;

PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is

begin

WORD_PACKAGE.WORD(W, PA, PA_LAST);

SYNCOPE(W, PA, PA_LAST);

end TWORD;

procedure FLIP(X1, X2 : STRING; EXPLANATION : STRING := "") is

-- At the begining of input word, replaces X1 by X2

PA_SAVE : INTEGER := PA_LAST;

begin

if S'LENGTH >= X1'LENGTH+2 and then

S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

TWORD(X2 & S(S'FIRST+X1'LENGTH..S'LAST), PA, PA_LAST);

if (PA_LAST > PA_SAVE + 1) and then

(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

if EXPLANATION = "" then

XXX_MEANING := HEAD(

"An initial '" & X1 & "' may have replaced usual '" & X2 & "'"

, MAX_MEANING_SIZE);

else

XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

end if;

PUT_STAT("TRICK FLIP at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

end if;

PA_LAST := PA_SAVE;

end FLIP;

procedure FLIP_FLOP(X1, X2 : STRING; EXPLANATION : STRING := "") is

-- At the begining of input word, replaces X1 by X2 - then X2 by X1

-- To be uesd only when X1 and X2 start with the same letter because it

-- will be called from a point where the first letter is established

PA_SAVE : INTEGER := PA_LAST;

begin

if S'LENGTH >= X1'LENGTH+2 and then

S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

--TEXT_IO.PUT_LINE("Trying " & X2 & S(S'FIRST+X1'LENGTH..S'LAST));

TWORD(X2 & S(S'FIRST+X1'LENGTH..S'LAST), PA, PA_LAST);

if (PA_LAST > PA_SAVE + 1) and then

(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

--TEXT_IO.PUT_LINE("FLIPF worked");

if EXPLANATION = "" then

XXX_MEANING := HEAD(

"An initial '" & X1 & "' may be rendered by '" & X2 & "'"

, MAX_MEANING_SIZE);

else

XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

end if;

PUT_STAT("TRICK FLIPF at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

end if;

--TEXT_IO.PUT_LINE("FLIPF failed");

--TEXT_IO.PUT_LINE("Try FFLOP");

if S'LENGTH >= X2'LENGTH+2 and then

S(S'FIRST..S'FIRST+X2'LENGTH-1) = X2 then

--TEXT_IO.PUT_LINE("Trying FFLOP");

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := (HEAD("Word mod " & X2 & "/" & X1, MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

--TEXT_IO.PUT_LINE("Trying " & X1 & S(S'FIRST+X2'LENGTH..S'LAST));

TWORD(X1 & S(S'FIRST+X2'LENGTH..S'LAST), PA, PA_LAST);

if (PA_LAST > PA_SAVE + 1) and then

(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

--TEXT_IO.PUT_LINE("FFLOP worked");

if EXPLANATION = "" then

XXX_MEANING := HEAD(

"An initial '" & X2 & "' may be rendered by '" & X1 & "'"

, MAX_MEANING_SIZE);

else

XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

end if;

PUT_STAT("TRICK FFLOP at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

end if;

--TEXT_IO.PUT_LINE("FFLIP failed");

PA_LAST := PA_SAVE;

end FLIP_FLOP;

procedure INTERNAL(X1, X2 : STRING; EXPLANATION : STRING := "") is

-- Replaces X1 with X2 anywhere in word and tries it for validity

PA_SAVE : INTEGER := PA_LAST;

begin

for I in S'FIRST..S'LAST-X1'LENGTH+1 loop

if S(I..I+X1'LENGTH-1) = X1 then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

TWORD(S(S'FIRST..I-1) & X2 & S(I+X1'LENGTH..S'LAST), PA, PA_LAST);

if (PA_LAST > PA_SAVE + 1) and then

(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

if EXPLANATION = "" then

XXX_MEANING := HEAD(

"An internal '" & X1 & "' might be rendered by '" & X2 & "'"

, MAX_MEANING_SIZE);

else

XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

end if;

PUT_STAT("TRICK INTR at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

end if;

end loop;

PA_LAST := PA_SAVE;

end INTERNAL;

procedure ADJ_TERMINAL_IIS(EXPLANATION : STRING := "") is

PA_SAVE : INTEGER := PA_LAST;

I : INTEGER := 0;

TRICK_TRANSLATION_RECORD : TRANSLATION_RECORD := NULL_TRANSLATION_RECORD;

begin

if S'LENGTH > 3 and then

S(S'LAST-1..S'LAST) = "is" then -- Terminal 'is'

PA_LAST := PA_LAST + 1;

TRICK_TRANSLATION_RECORD.FREQ := C;

PA(PA_LAST) := (HEAD("Word mod iis -> is", MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

WORD(S(S'FIRST..S'LAST-2) & "iis", PA, PA_LAST);

if (PA_LAST > PA_SAVE + 1) then

I := PA_LAST;

while I > PA_SAVE + 1 loop

if PA(I).IR.QUAL.POFS = ADJ and then

PA(I).IR.QUAL.ADJ.DECL = (1, 1) and then

((PA(I).IR.QUAL.ADJ.CS = DAT) or

(PA(I).IR.QUAL.ADJ.CS = ABL)) and then

PA(I).IR.QUAL.ADJ.NUMBER = P then

null; -- Only for ADJ 1 1 DAT/ABL P

else

PA(I..PA_LAST-1) := PA(I+1..PA_LAST);

PA_LAST := PA_LAST - 1;

end if;

I := I - 1;

end loop;

end if;

if (PA_LAST > PA_SAVE + 1) then

if EXPLANATION = "" then

XXX_MEANING := HEAD("A Terminal 'iis' on ADJ 1 1 DAT/ABL P might drop 'i'",

MAX_MEANING_SIZE);

else

XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

end if;

PUT_STAT("TRICK ADJIS at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

end if;

PA_LAST := PA_SAVE;

end ADJ_TERMINAL_IIS;

-- Now SLUR is handled in TRY_SLURY

--

-- procedure SLUR(X1 : STRING; EXPLANATION : STRING := "") is

-- PA_SAVE : INTEGER := PA_LAST;

-- SL : INTEGER := X1'LENGTH;

-- begin

-- if S'LENGTH >= X1'LENGTH+2 then

-- if S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 and then -- Initial X1

-- not IS_A_VOWEL(S(S'FIRST+SL)) then

-- PA_LAST := PA_LAST + 1;

-- PA(PA_LAST) := (HEAD("Slur " & X1 & "/" & X1(1..SL-1) & "~", MAX_STEM_SIZE),

-- NULL_INFLECTION_RECORD,

-- XXX, NULL_MNPC);

-- TWORD(X1(1..SL-1) & S(S'FIRST+SL) & S(S'FIRST+SL..S'LAST), PA, PA_LAST);

-- if (PA_LAST > PA_SAVE + 1) and then

-- (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

-- if EXPLANATION = "" then

-- XXX_MEANING := HEAD(

-- "An initial '" & X1 & "' may be rendered by " & X1(1) & "~"

-- , MAX_MEANING_SIZE);

-- else

-- XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

-- end if;

--PUT_STAT("TRICK SLUR at "

-- & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

-- & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

-- return;

-- else

-- PA_LAST := PA_SAVE;

-- end if;

--

-- elsif (S(S'FIRST..S'FIRST+SL-1) = X1(1..SL-1)) and then

-- (S(S'FIRST+SL-1) = S(S'FIRST+SL)) and then -- Double letter

-- not IS_A_VOWEL(S(S'FIRST+SL)) then

-- PA_LAST := PA_LAST + 1;

-- PA(PA_LAST) := (HEAD("Slur " & X1(1..SL-1) & "~" & "/" & X1, MAX_STEM_SIZE),

-- NULL_INFLECTION_RECORD,

-- XXX, NULL_MNPC);

-- TWORD(X1 & S(S'FIRST+SL..S'LAST), PA, PA_LAST);

-- if (PA_LAST > PA_SAVE + 1) and then

-- (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

-- if EXPLANATION = "" then

-- XXX_MEANING := HEAD(

-- "An initial '" & X1(1..SL-1) & "~" & "' may be rendered by " & X1

-- , MAX_MEANING_SIZE);

-- else

-- XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

-- end if;

--PUT_STAT("TRICK SLUR at "

-- & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

-- & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

-- return;

-- else

-- PA_LAST := PA_SAVE;

-- end if;

--

-- end if;

-- end if;

-- PA_LAST := PA_SAVE;

-- end SLUR;

--

--

procedure DOUBLE_CONSONANTS(EXPLANATION : STRING := "") is

PA_SAVE : INTEGER := PA_LAST;

begin

-- Medieval often replaced a classical doubled consonant with single

-- The problem is to take possible medieval words

-- and double (all) (isolated) consonants

for I in S'FIRST+1..S'LAST-1 loop -- probably dont need to go to end

if (not IS_A_VOWEL(S(I))) and then

(IS_A_VOWEL(S(I-1)) and IS_A_VOWEL(S(I+1))) then

PA_LAST := PA_LAST + 1;

PA(PA_LAST) := (HEAD("Word mod " & S(I) &

" -> " & S(I) & S(I), MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

TWORD(S(S'FIRST..I) & S(I) & S(I+1..S'LAST), PA, PA_LAST);

--TEXT_IO.PUT_LINE(S(S'FIRST..I) & S(I) & S(I+1..S'LAST));

if (PA_LAST > PA_SAVE + 1) and then

(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then

if EXPLANATION = "" then

XXX_MEANING := HEAD(

"A doubled consonant may be rendered by just the single"

& " MEDIEVAL", MAX_MEANING_SIZE);

else

XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);

end if;

PUT_STAT("TRICK 2CON at "

& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)

& " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM);

return;

else

PA_LAST := PA_SAVE;

end if;

end if;

end loop;

PA_LAST := PA_SAVE;

end DOUBLE_CONSONANTS;

procedure TWO_WORDS(EXPLANATION : STRING := "") is

-- This procedure examines the word to determine if it is made up

-- of two separate inflectted words

-- They are usually an adjective and a noun or two nouns

PA_SAVE, PA_SECOND : INTEGER := PA_LAST;

NUM_HIT_ONE, NUM_HIT_TWO : BOOLEAN := FALSE;

--MID : INTEGER := S'LENGTH/2;

I, I_MID : INTEGER := 0;

REMEMBER_SYNCOPE : BOOLEAN := FALSE;

procedure WORDS_NO_SYNCOPE (W : STRING;

PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is

begin

if WORDS_MDEV(DO_SYNCOPE) then

REMEMBER_SYNCOPE := TRUE;

WORDS_MDEV(DO_SYNCOPE) := FALSE;

end if;

WORD_PACKAGE.WORD(W, PA, PA_LAST);

if REMEMBER_SYNCOPE then

WORDS_MDEV(DO_SYNCOPE) := TRUE;

end if;

end WORDS_NO_SYNCOPE;

function COMMON_PREFIX(S : STRING) return BOOLEAN is

-- Common prefixes that have corresponding words (prepositions usually)

-- which could confuse TWO_WORDS. We wish to reject these.

begin

if S = "dis" or

S = "ex" or

S = "in" or

S = "per" or

S = "prae" or

S = "pro" or

S = "re" or

S = "si" or

S = "sub" or

S = "super" or

S = "trans" then

return TRUE;

else

return FALSE;

end if;

end COMMON_PREFIX;

begin

--TEXT_IO.PUT_LINE("Entering TWO_WORDS PA_LAST = " & INTEGER'IMAGE(PA_LAST));

--if S(S'FIRST) /= 'q' then -- qu words more complicated

if S'LENGTH < 5 then -- Dont try on too short words

return;

end if;

I := 2; -- Smallest is re-publica, but that killed by PREFIX, meipsum

OUTER_LOOP:

while I < S'LENGTH - 2 loop

PA_LAST := PA_LAST + 1;

PA(PA_LAST):= (HEAD("Two words", MAX_STEM_SIZE),

NULL_INFLECTION_RECORD,

XXX, NULL_MNPC);

--TEXT_IO.PUT_LINE("Setting PA TWO_WORDS PA_LAST = " & INTEGER'IMAGE(PA_LAST));

while I < S'LENGTH - 2 loop

--TEXT_IO.PUT_LINE("Trying " & S(S'FIRST..S'FIRST+I-1));

if not COMMON_PREFIX(S(S'FIRST..S'FIRST+I-1)) then

WORDS_NO_SYNCOPE(S(S'FIRST..S'FIRST+I-1), PA, PA_LAST);

if (PA_LAST > PA_SAVE + 1) then

I_MID := I;

for J in PA_SAVE+1..PA_LAST loop

if PA(J).IR.QUAL.POFS = NUM then

NUM_HIT_ONE := TRUE;

exit;

end if;

end loop;

--TEXT_IO.PUT_LINE("HIT first " & S(S'FIRST..I_MID-1) & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));

--PARSE_RECORD_IO.PUT(PA(PA_LAST)); TEXT_IO.NEW_LINE;

exit;

end if;

end if;

I := I + 1;

end loop;

if (PA_LAST > PA_SAVE + 1) then

null;

--TEXT_IO.PUT_LINE("Confirm first " & S(S'FIRST..I_MID) & " PA_LAST =" & INTEGER'IMAGE(PA_LAST));

else

--TEXT_IO.PUT_LINE("No possible first " & S(S'FIRST..I_MID));

PA_LAST := PA_SAVE;

return;

end if;

-- Now for second word

--TEXT_IO.PUT_LINE("Looking for second >" & S(I_MID+1..S'LAST));

PA_LAST := PA_LAST + 1;