2222 lines
83 KiB
Ada
2222 lines
83 KiB
Ada
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
|
|
|
|
--
|
|
--NUMERALS IN A STRING ARE ADDED: CC = 200 ; CCX = 210.
|
|
--ONE NUMERAL TO THE LEFT of A LARGER NUMERAL IS SUBTRACTED FROM THAT NUMBER: IX = 9
|
|
--
|
|
--SUBTRACT ONLY A SINGLE LETTER FROM A SINGLE NUMERAL.
|
|
--VIII FOR 8, NOT IIX; 19 IS XIX, NOT IXX.
|
|
--
|
|
--SUBTRACT ONLY POWERS of TEN, SUCH AS I, X, or C.
|
|
--NOT VL FOR 45, BUT XLV.
|
|
--
|
|
--DON'T SUBTRACT A LETTER FROM ANOTHER LETTER MORE THAN TEN TIMES GREATER.
|
|
--ONLY SUBTRACT I FROM V or X, and X FROM L or C.
|
|
--NOT IL FOR 49, BUT XLIX. MIM is ILLEGAL.
|
|
--
|
|
--ONLY IF ANY NUMERAL PRECEEDING IS AT LEAST TEN TIMES LARGER.
|
|
--NOT VIX FOR 14, BUT XIV.
|
|
--NOT IIX, BUT VIII.
|
|
--ONLY IF ANY NUMERAL FOLLOWING IS SMALLER.
|
|
--NOT XCL FOR 140, BUT CXL.
|
|
--
|
|
J := S'LAST;
|
|
|
|
EVALUATE:
|
|
while J >= S'FIRST loop
|
|
--
|
|
--Legal in the Ones position
|
|
-- I
|
|
-- II
|
|
-- III
|
|
-- IIII IV
|
|
-- V
|
|
-- VI
|
|
-- VII
|
|
-- VIII
|
|
-- VIIII IX
|
|
--
|
|
--
|
|
-- 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;
|
|
|
|
--
|
|
--Legal in the tens position
|
|
-- X
|
|
-- XX
|
|
-- XXX
|
|
-- XXXX XL
|
|
-- L
|
|
-- LX
|
|
-- LXX
|
|
-- LXXX
|
|
-- LXXXX XC
|
|
--
|
|
|
|
-- 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;
|
|
|
|
|
|
|
|
|
|
|
|
-- -- sis => s, xis => x, in perfect
|
|
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
|
|
--TEXT_IO.PUT_LINE("FLIP_FLOP called " & X1 & " " & X2);
|
|
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;
|
|
PA(PA_LAST) := NULL_PARSE_RECORD; -- Separator
|
|
PA_SECOND := PA_LAST;
|
|
WORDS_NO_SYNCOPE(S(I_MID+1..S'LAST), PA, PA_LAST);
|
|
if (PA_LAST > PA_SECOND) and then -- No + 1 since XXX taken care of above
|
|
(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then
|
|
for J in PA_SECOND..PA_LAST loop
|
|
if PA(J).IR.QUAL.POFS = NUM then
|
|
NUM_HIT_TWO := TRUE;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
--TEXT_IO.PUT_LINE("Found second " & S(I_MID+1..S'LAST) & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
|
|
|
|
if EXPLANATION = "" then
|
|
|
|
if WORDS_MODE(TRIM_OUTPUT) and then
|
|
-- Should check that cases correspond
|
|
(NUM_HIT_ONE and NUM_HIT_TWO) then
|
|
-- Clear out any non-NUM if we are in TRIM
|
|
for J in PA_SAVE+1..PA_LAST loop
|
|
if PA(J).D_K in GENERAL..UNIQUE and then
|
|
PA(J).IR.QUAL.POFS /= NUM then
|
|
PA(J..PA_LAST-1) := PA(J+1..PA_LAST);
|
|
PA_LAST := PA_LAST - 1;
|
|
end if;
|
|
end loop;
|
|
|
|
|
|
XXX_MEANING := HEAD(
|
|
"It is very likely a compound number " &
|
|
S(S'FIRST..S'FIRST+I-1) & " + " &
|
|
S(S'FIRST+I..S'LAST), MAX_MEANING_SIZE);
|
|
PUT_STAT("TRICK 2NUM at "
|
|
& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)
|
|
& " " & HEAD(W, 20) & " " & S(1..I_MID) & '+' & S(I_MID+1..S'LAST));
|
|
else
|
|
XXX_MEANING := HEAD(
|
|
"May be 2 words combined (" &
|
|
S(S'FIRST..S'FIRST+I-1) & "+" &
|
|
S(S'FIRST+I..S'LAST) &
|
|
") If not obvious, probably incorrect", MAX_MEANING_SIZE);
|
|
PUT_STAT("TRICK 2WDS at "
|
|
& HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4)
|
|
& " " & HEAD(W, 20) & " " & S(1..I_MID) & '+' & S(I_MID+1..S'LAST));
|
|
end if;
|
|
else
|
|
XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);
|
|
end if;
|
|
|
|
--TEXT_IO.PUT_LINE("Returing from 2WDS PA_SAVE+1 = " & INTEGER'IMAGE(PA_SAVE+1) & " " & PA(PA_SAVE+1).STEM);
|
|
|
|
|
|
return;
|
|
else
|
|
PA_LAST := PA_SAVE;
|
|
end if;
|
|
|
|
I := I + 1;
|
|
end loop OUTER_LOOP;
|
|
|
|
PA_LAST := PA_SAVE; -- No success, so reset to clear the TRICK PA
|
|
|
|
|
|
|
|
|
|
-- I could try to check cases/gender/number for matches
|
|
-- Discard all that do not have a match
|
|
-- ADJ, N, NUM
|
|
-- But that is probably being too pedantic for a case which may be sloppy
|
|
end TWO_WORDS;
|
|
|
|
|
|
--------------------------------------------------------------------------
|
|
--------------------------------------------------------------------------
|
|
--------------------------------------------------------------------------
|
|
--------------------------------------------------------------------------
|
|
|
|
begin
|
|
-- These things might be genericized, at least the PA(1) assignments
|
|
--TEXT_IO.PUT_LINE("TRICKS called");
|
|
|
|
XXX_MEANING := NULL_MEANING_TYPE;
|
|
|
|
|
|
|
|
|
|
-- If there is no satisfaction from above, we will try further
|
|
|
|
case S(S'FIRST) is
|
|
|
|
when 'a' =>
|
|
|
|
|
|
--FLIP_FLOP("abs", "aps"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("acq", "adq"); if PA_LAST > 0 then return; end if;
|
|
FLIP_FLOP("adgn", "agn");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("adsc", "asc");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("adsp", "asp");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
--FLIP_FLOP("ante", "anti"); if PA_LAST > 0 then return; end if;
|
|
FLIP_FLOP("arqui", "arci");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("arqu", "arcu");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
--FLIP_FLOP("auri", "aure"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("auri", "auru"); if PA_LAST > 0 then return; end if;
|
|
--SLUR("ad"); if PA_LAST > 0 then return; end if;
|
|
FLIP("ae", "e");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("al", "hal");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("am", "ham");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("ar", "har");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("aur", "or");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
|
|
|
|
-- when 'c' =>
|
|
|
|
--FLIP("circum" , "circun"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("con", "com"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("co" , "com"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("co" , "con"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("conl" , "coll"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
when 'd' =>
|
|
|
|
FLIP("dampn" , "damn");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("dij" , "disj"); -- OLD p.543
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("dir" , "disr"); -- OLD p.556
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("dir" , "der"); -- OLD p.547
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("del" , "dil"); -- OLD p.507/543
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
when 'e' =>
|
|
|
|
FLIP_FLOP("ecf" , "eff");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("ecs" , "exs");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("es" , "ess");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("ex" , "exs");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP("eid", "id");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("el", "hel");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("e", "ae");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
when 'f' =>
|
|
|
|
FLIP_FLOP("faen" , "fen");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("faen" , "foen");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("fed" , "foed");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("fet" , "foet");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP("f", "ph");
|
|
if PA_LAST > 0 then
|
|
return; end if; -- Try lead then all
|
|
|
|
when 'g' =>
|
|
|
|
FLIP("gna", "na");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
when 'h' =>
|
|
|
|
FLIP("har", "ar");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("hal", "al");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("ham", "am");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("hel", "el");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("hol", "ol");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("hum", "um");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
when 'i' =>
|
|
|
|
|
|
--SLUR("in"); if PA_LAST > 1 then return; end if;
|
|
|
|
--FLIP_FLOP("inb", "imb"); if PA_LAST > 1 then return; end if;
|
|
--FLIP_FLOP("inp", "imp"); if PA_LAST > 1 then return; end if;
|
|
|
|
|
|
|
|
-- for some forms of eo the stem "i" grates with an "is..." ending
|
|
if S'LENGTH > 1 and then
|
|
S(S'FIRST..S'FIRST+1) = "is" then
|
|
PA(1) := ("Word mod is => iis", NULL_INFLECTION_RECORD,
|
|
XXX, NULL_MNPC);
|
|
PA_LAST := 1;
|
|
TWORD("i" & S(S'FIRST..S'LAST), PA, PA_LAST);
|
|
end if;
|
|
if (PA_LAST > PA_SAVE + 1) and then
|
|
(PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) and then
|
|
PA(PA_LAST).IR.QUAL.POFS = V and then
|
|
PA(PA_LAST).IR.QUAL.V.CON = (6, 1) then -- Check it is V 6 1 eo
|
|
XXX_MEANING := HEAD(
|
|
"Some forms of eo stem 'i' grates with an 'is...' ending, so 'is' -> 'iis' "
|
|
, MAX_MEANING_SIZE);
|
|
return;
|
|
else
|
|
PA_LAST := 0;
|
|
end if;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
when 'k' =>
|
|
|
|
FLIP("k", "c");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("c", "k");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
when 'l' =>
|
|
|
|
|
|
FLIP_FLOP("lub", "lib");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
|
|
|
|
when 'm' =>
|
|
|
|
|
|
FLIP_FLOP("mani", "manu");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
|
|
|
|
|
|
when 'n' =>
|
|
|
|
|
|
FLIP("na", "gna");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("nihil", "nil");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
--FLIP("nun", "non"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
|
|
when 'o' =>
|
|
|
|
--SLUR("ob"); if PA_LAST > 0 then return; end if;
|
|
FLIP_FLOP("obt", "opt");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
FLIP_FLOP("obs", "ops");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
FLIP("ol", "hol");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("opp", "op");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
FLIP("or", "aur");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
|
|
when 'p' =>
|
|
|
|
|
|
FLIP("ph", "f");
|
|
if PA_LAST > 0 then
|
|
return; end if; -- Try lead then all
|
|
FLIP_FLOP("pre", "prae");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
|
|
|
|
-- when 'q' =>
|
|
|
|
|
|
--FLIP_FLOP("quadri", "quadru"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
when 's' =>
|
|
|
|
|
|
-- From Oxford Latin Dictionary p.1835 "sub-"
|
|
|
|
--SLUR("sub");
|
|
|
|
FLIP_FLOP("subsc", "susc");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("subsp", "susp");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("subc", "susc");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("succ", "susc");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("subt", "supt");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("subt", "sust");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
when 't' =>
|
|
|
|
|
|
FLIP_FLOP("transv", "trav");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
-- FLIP("trig", "tric");
|
|
-- if PA_LAST > 0 then
|
|
-- return; end if;
|
|
|
|
|
|
|
|
|
|
when 'u' =>
|
|
|
|
FLIP("ul", "hul");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("uol", "vul");
|
|
if PA_LAST > 0 then
|
|
return; end if; -- u is not v for this purpose
|
|
|
|
|
|
|
|
when 'y' =>
|
|
|
|
FLIP("y", "i");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
when 'z' =>
|
|
|
|
FLIP("z", "di");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
when others => null;
|
|
|
|
end case; -- case on first letter
|
|
|
|
|
|
|
|
INTERNAL("ae", "e");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("bul", "bol");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
INTERNAL("bol", "bul");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("cl", "cul");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("cu", "quu");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("f", "ph");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
INTERNAL("ph", "f");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("h", "");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
INTERNAL("oe", "e");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("vul", "vol");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
INTERNAL("vol", "vul");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
INTERNAL("uol", "vul");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
ADJ_TERMINAL_IIS;
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
|
|
---------------------------------------------------------------
|
|
|
|
|
|
if WORDS_MDEV(DO_MEDIEVAL_TRICKS) then
|
|
-- Medieval -> Classic
|
|
|
|
-- Harrington/Elliott 1.1.1
|
|
|
|
INTERNAL("col", "caul");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
--TEXT_IO.PUT_LINE("Trying com -> con");
|
|
--INTERNAL("com", "con"); if PA_LAST > 0 then return; end if; -- My own
|
|
|
|
--INTERNAL("cl", "cul"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
-- Harrington/Elliott 1.3
|
|
|
|
INTERNAL("e", "ae");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("o", "u");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("i", "y");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
-- Harrington/Elliott 1.3.1
|
|
|
|
INTERNAL("ism", "sm");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("isp", "sp");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("ist", "st");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("iz", "z");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("esm", "sm");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("esp", "sp");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("est", "st");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("ez", "z");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
-- Harrington/Elliott 1.4
|
|
|
|
INTERNAL("di", "z");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("f", "ph");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("is", "ix");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
INTERNAL("b", "p");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("d", "t");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("v", "b");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("v", "f");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("v", "f");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("s", "x");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
|
|
-- Harrington/Elliott 1.4.1
|
|
|
|
INTERNAL("ci", "ti");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
-- Harrington/Elliott 1.4.2
|
|
|
|
INTERNAL("nt", "nct");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("s", "ns");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
-- Others
|
|
|
|
INTERNAL("ch", "c");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("c", "ch");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("th", "t");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
INTERNAL("t", "th");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
|
|
|
|
DOUBLE_CONSONANTS;
|
|
|
|
|
|
end if; -- Medieval Tricks
|
|
---------------------------------------------------------------
|
|
|
|
if not (WORDS_MODE(IGNORE_UNKNOWN_NAMES) and CAPITALIZED) then -- Don't try on Names
|
|
if WORDS_MDEV(DO_TWO_WORDS) then
|
|
TWO_WORDS;
|
|
end if;
|
|
end if;
|
|
|
|
|
|
|
|
-- It could be an improperly formed Roman Numeral
|
|
if ONLY_ROMAN_DIGITS(W) then
|
|
|
|
|
|
PA_LAST := 1;
|
|
PA(1) := ("Bad Roman Numeral?", NULL_INFLECTION_RECORD,
|
|
XXX, NULL_MNPC);
|
|
XXX_MEANING := NULL_MEANING_TYPE;
|
|
|
|
RRR_MEANING := HEAD(INTEGER'IMAGE(BAD_ROMAN_NUMBER(W)) & " as ill-formed ROMAN NUMERAL?;",
|
|
MAX_MEANING_SIZE);
|
|
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 => D),
|
|
D_K => RRR,
|
|
MNPC => NULL_MNPC );
|
|
|
|
return;
|
|
end if;
|
|
|
|
|
|
|
|
|
|
exception
|
|
when others => -- I want to ignore anything that happens in TRICKS
|
|
PA_LAST := PA_SAVE;
|
|
PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys
|
|
|
|
TEXT_IO.PUT_LINE( -- ERROR_FILE,
|
|
"Exception in TRY_TRICKS processing " & W);
|
|
end TRY_TRICKS;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
procedure TRY_SLURY(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
|
|
SAVE_USE_PREFIXES : BOOLEAN := WORDS_MDEV(USE_PREFIXES);
|
|
begin
|
|
WORDS_MDEV(USE_PREFIXES) := FALSE;
|
|
WORD_PACKAGE.WORD(W, PA, PA_LAST);
|
|
SYNCOPE(W, PA, PA_LAST);
|
|
WORDS_MDEV(USE_PREFIXES) := SAVE_USE_PREFIXES;
|
|
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 be rendered by '" & X2 & "'"
|
|
, MAX_MEANING_SIZE);
|
|
else
|
|
XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);
|
|
end if;
|
|
PUT_STAT("SLURY 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);
|
|
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 be rendered by '" & X2 & "'"
|
|
, MAX_MEANING_SIZE);
|
|
else
|
|
XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);
|
|
end if;
|
|
PUT_STAT("SLURY FLOP 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'LENGTH >= X2'LENGTH+2 and then
|
|
S(S'FIRST..S'FIRST+X2'LENGTH-1) = X2 then
|
|
PA_LAST := PA_LAST + 1;
|
|
PA(PA_LAST) := (HEAD("Word mod " & X2 & "/" & X1, MAX_STEM_SIZE),
|
|
NULL_INFLECTION_RECORD,
|
|
XXX, NULL_MNPC);
|
|
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
|
|
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("SLURY FLOP 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_FLOP;
|
|
|
|
|
|
|
|
|
|
|
|
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..X1'LAST-1) & "~",
|
|
MAX_MEANING_SIZE);
|
|
else
|
|
XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE);
|
|
end if;
|
|
PUT_STAT("SLURY 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("SLURY 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;
|
|
|
|
begin
|
|
|
|
--XXX_MEANING := NULL_MEANING_TYPE;
|
|
|
|
|
|
-- If there is no satisfaction from above, we will try further
|
|
|
|
if S(S'FIRST) = 'a' then
|
|
|
|
|
|
FLIP_FLOP("abs", "aps");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("acq", "adq");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
--FLIP_FLOP("adgn", "agn"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("adsc", "asc"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("adsp", "asp"); if PA_LAST > 0 then return; end if;
|
|
FLIP_FLOP("ante", "anti");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
--FLIP_FLOP("arqui", "arci"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("arqu", "arcu"); if PA_LAST > 0 then return; end if;
|
|
FLIP_FLOP("auri", "aure");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("auri", "auru");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
SLUR("ad");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
--FLIP("ae", "e"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("al", "hal"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("am", "ham"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("ar", "har"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("aur", "or"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
|
|
|
|
elsif S(S'FIRST) = 'c' then
|
|
|
|
FLIP("circum" , "circun");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("con", "com");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("co" , "com");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP("co" , "con");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
FLIP_FLOP("conl" , "coll");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
--elsif S(S'FIRST) = 'e' then
|
|
|
|
--FLIP_FLOP("ecf" , "eff"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("ecs" , "exs"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("es" , "ess"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("ex" , "exs"); if PA_LAST > 0 then return; end if;
|
|
|
|
--FLIP("el", "hel"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("e", "ae"); if PA_LAST > 0 then return; end if;
|
|
|
|
--elsif S(S'FIRST) = 'f' then
|
|
|
|
--FLIP_FLOP("faen" , "foen"); if PA_LAST > 0 then return; end if;
|
|
|
|
--FLIP("f", "ph"); if PA_LAST > 0 then return; end if; -- Try lead then all
|
|
|
|
--elsif S(S'FIRST) = 'g' then
|
|
|
|
--FLIP("gna", "na"); if PA_LAST > 0 then return; end if;
|
|
|
|
--elsif S(S'FIRST) = 'h' then
|
|
|
|
--FLIP("har", "ar"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("hal", "al"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("ham", "am"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("hel", "el"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("hol", "ol"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("hum", "um"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
elsif S(S'FIRST) = 'i' then
|
|
|
|
|
|
SLUR("in");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
|
|
FLIP_FLOP("inb", "imb");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
FLIP_FLOP("inp", "imp");
|
|
if PA_LAST > 1 then
|
|
return; end if;
|
|
|
|
|
|
|
|
-- -- for some forms of eo the stem "i" grates with an "is..." ending
|
|
-- if S'LENGTH > 1 and then
|
|
-- S(S'FIRST..S'FIRST+1) = "is" then
|
|
-- PA(1) := ("Word mod is => iis", NULL_INFLECTION_RECORD,
|
|
-- XXX, NULL_MNPC);
|
|
-- PA_LAST := 1;
|
|
-- TWORD("i" & S(S'FIRST..S'LAST), PA, PA_LAST);
|
|
-- end if;
|
|
-- if (PA_LAST > PA_SAVE + 1) and then
|
|
-- (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) and then
|
|
-- PA(PA_LAST).IR.QUAL.POFS = V and then
|
|
-- PA(PA_LAST).IR.QUAL.V.CON = (6, 1) then -- Check it is V 6 1 eo
|
|
-- XXX_MEANING := HEAD(
|
|
--"Some forms of eo stem 'i' grates with an 'is...' ending, so 'is' -> 'iis' "
|
|
-- , MAX_MEANING_SIZE);
|
|
-- return;
|
|
-- else
|
|
-- PA_LAST := 0;
|
|
-- end if;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
--elsif S(S'FIRST) = 'k' then
|
|
|
|
--FLIP("k", "c"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("c", "k"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
--elsif S(S'FIRST) = 'l' then
|
|
|
|
|
|
--FLIP_FLOP("lub", "lib"); if PA_LAST > 1 then return; end if;
|
|
|
|
|
|
--elsif S(S'FIRST) = 'm' then
|
|
|
|
|
|
--FLIP_FLOP("mani", "manu"); if PA_LAST > 1 then return; end if;
|
|
|
|
|
|
|
|
elsif S(S'FIRST) = 'n' then
|
|
|
|
|
|
--FLIP("na", "gna"); if PA_LAST > 0 then return; end if;
|
|
|
|
--FLIP_FLOP("nihil", "nil"); if PA_LAST > 0 then return; end if;
|
|
|
|
FLIP("nun", "non");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
|
|
elsif S(S'FIRST) = 'o' then
|
|
|
|
SLUR("ob");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
--FLIP_FLOP("obt", "opt"); if PA_LAST > 1 then return; end if;
|
|
--FLIP_FLOP("obs", "ops"); if PA_LAST > 1 then return; end if;
|
|
--FLIP("ol", "hol"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("opp", "op"); if PA_LAST > 1 then return; end if;
|
|
--FLIP("or", "aur"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
|
|
--elsif S(S'FIRST) = 'p' then
|
|
|
|
|
|
--FLIP("ph", "f"); if PA_LAST > 0 then return; end if; -- Try lead then all
|
|
--FLIP_FLOP("pre", "prae"); if PA_LAST > 1 then return; end if;
|
|
|
|
|
|
elsif S(S'FIRST) = 'q' then
|
|
|
|
|
|
FLIP_FLOP("quadri", "quadru");
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
|
|
elsif S(S'FIRST) = 's' then
|
|
|
|
FLIP("se", "ce"); -- Latham
|
|
if PA_LAST > 0 then
|
|
return; end if;
|
|
|
|
-- From Oxford Latin Dictionary p.1835 "sub-"
|
|
|
|
SLUR("sub");
|
|
|
|
--FLIP_FLOP("subsc", "susc"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("subsp", "susp"); if PA_LAST > 0 then return; end if;
|
|
|
|
--FLIP_FLOP("subc", "susc"); if PA_LAST > 0 then return; end if;
|
|
--FLIP_FLOP("succ", "susc"); if PA_LAST > 0 then return; end if;
|
|
|
|
--FLIP_FLOP("subt", "sust"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
--elsif S(S'FIRST) = 't' then
|
|
|
|
|
|
--FLIP_FLOP("transv", "trav"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
|
|
|
|
--elsif S(S'FIRST) = 'u' then
|
|
|
|
--FLIP("ul", "hul"); if PA_LAST > 0 then return; end if;
|
|
--FLIP("uol", "vul"); if PA_LAST > 0 then return; end if; -- u is not v for this purpose
|
|
|
|
|
|
|
|
--elsif S(S'FIRST) = 'y' then
|
|
|
|
--FLIP("y", "i"); if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
end if; -- if on first letter
|
|
|
|
|
|
-- All INTERNAL out
|
|
--INTERNAL("ae", "e"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
--INTERNAL("cl", "cul"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("cu", "quu"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("f", "ph"); if PA_LAST > 0 then return; end if;
|
|
--INTERNAL("ph", "f"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("h", ""); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
--INTERNAL("vul", "vol"); if PA_LAST > 0 then return; end if;
|
|
--INTERNAL("vol", "vul"); if PA_LAST > 0 then return; end if;
|
|
--INTERNAL("uol", "vul"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
--ADJ_TERMINAL_IIS; if PA_LAST > 0 then return; end if;
|
|
|
|
|
|
|
|
---------------------------------------------------------------
|
|
|
|
|
|
--if WORDS_MDEV(DO_MEDIEVAL_TRICKS) then
|
|
---- Medieval -> Classic
|
|
--
|
|
---- Harrington/Elliott 1.1.1
|
|
--
|
|
--INTERNAL("col", "caul"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
----TEXT_IO.PUT_LINE("Trying com -> con");
|
|
----INTERNAL("com", "con"); if PA_LAST > 0 then return; end if; -- My own
|
|
--
|
|
----INTERNAL("cl", "cul"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
---- Harrington/Elliott 1.3
|
|
--
|
|
--INTERNAL("e", "ae"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("o", "u"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("i", "y"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
---- Harrington/Elliott 1.3.1
|
|
--
|
|
--INTERNAL("ism", "sm"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("isp", "sp"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("ist", "st"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("iz", "z"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("esm", "sm"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("esp", "sp"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("est", "st"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("ez", "z"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
---- Harrington/Elliott 1.4
|
|
--
|
|
--INTERNAL("di", "z"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
----INTERNAL("f", "ph"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("is", "ix"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
--INTERNAL("b", "p"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("d", "t"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("v", "b"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("v", "f"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("v", "f"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("s", "x"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
--
|
|
---- Harrington/Elliott 1.4.1
|
|
--
|
|
--INTERNAL("ci", "ti"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
---- Harrington/Elliott 1.4.2
|
|
--
|
|
--INTERNAL("nt", "nct"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--INTERNAL("nt", "nct"); if PA_LAST > 0 then return; end if;
|
|
--
|
|
--
|
|
--DOUBLE_CONSONANTS;
|
|
--
|
|
--
|
|
--end if; -- Medieval Tricks
|
|
---------------------------------------------
|
|
|
|
exception
|
|
when others => -- I want to ignore anything that happens in SLURY
|
|
PA_LAST := PA_SAVE;
|
|
PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys
|
|
|
|
TEXT_IO.PUT_LINE( -- ERROR_FILE,
|
|
"Exception in TRY_SLURY processing " & W);
|
|
end TRY_SLURY;
|
|
|
|
|
|
end TRICKS_PACKAGE;
|