1 with TEXT_IO; 2 with STRINGS_PACKAGE; use STRINGS_PACKAGE; 3 with WORD_PARAMETERS; use WORD_PARAMETERS; 4 with DEVELOPER_PARAMETERS; use DEVELOPER_PARAMETERS; 5 with INFLECTIONS_PACKAGE; use INFLECTIONS_PACKAGE; 6 with DICTIONARY_PACKAGE; use DICTIONARY_PACKAGE; 7 with WORD_SUPPORT_PACKAGE; use WORD_SUPPORT_PACKAGE; 8 with WORD_PACKAGE; use WORD_PACKAGE; 9 with PUT_STAT; 10 package body TRICKS_PACKAGE is 11 12 function IS_A_VOWEL(C : CHARACTER) return BOOLEAN is 13 begin 14 if LOWER_CASE(C) = 'a' or 15 LOWER_CASE(C) = 'e' or 16 LOWER_CASE(C) = 'i' or 17 LOWER_CASE(C) = 'o' or 18 LOWER_CASE(C) = 'u' or 19 LOWER_CASE(C) = 'y' then 20 return TRUE; 21 else 22 return FALSE; 23 end if; 24 end IS_A_VOWEL; 25 26 27 28 29 function A_ROMAN_DIGIT(CHAR : CHARACTER) return BOOLEAN is 30 begin 31 case CHAR is 32 when 'M' | 'm' => 33 return TRUE; 34 when 'D' | 'd' => 35 return TRUE; 36 when 'C' | 'c' => 37 return TRUE; 38 when 'L' | 'l' => 39 return TRUE; 40 when 'X' | 'x' => 41 return TRUE; 42 --when 'U' | 'u' => return TRUE; -- possible but unlikely 43 when 'V' | 'v' => 44 return TRUE; 45 when 'I' | 'i' => 46 return TRUE; 47 when others => 48 return FALSE; 49 end case; 50 end A_ROMAN_DIGIT; 51 52 function VALUE(CHAR : CHARACTER) return NATURAL is 53 begin 54 case CHAR is 55 when 'M' | 'm' => 56 return 1000; 57 when 'D' | 'd' => 58 return 500; 59 when 'C' | 'c' => 60 return 100; 61 when 'L' | 'l' => 62 return 50; 63 when 'X' | 'x' => 64 return 10; 65 --when 'U' | 'u' => return 5; -- possible but unlikely 66 when 'V' | 'v' => 67 return 5; 68 when 'I' | 'i' => 69 return 1; 70 when others => 71 return 0; 72 end case; 73 end VALUE; 74 75 function ONLY_ROMAN_DIGITS(S : STRING) return BOOLEAN is 76 begin 77 78 79 for I in S'range loop 80 if not A_ROMAN_DIGIT(S(I)) then 81 return FALSE; 82 end if; 83 end loop; 84 return TRUE; 85 end ONLY_ROMAN_DIGITS; 86 87 function ROMAN_NUMBER(ST : STRING) return NATURAL is 88 -- Determines and returns the value of a Roman numeral, or 0 if invalid 89 90 use TEXT_IO; 91 TOTAL : NATURAL := 0; 92 INVALID : exception; 93 DECREMENTED : BOOLEAN := FALSE; 94 J : INTEGER := 0; 95 S : constant STRING := UPPER_CASE(ST); 96 97 98 begin 99 if ONLY_ROMAN_DIGITS(S) then 100 101-- 102--NUMERALS IN A STRING ARE ADDED: CC = 200 ; CCX = 210. 103--ONE NUMERAL TO THE LEFT of A LARGER NUMERAL IS SUBTRACTED FROM THAT NUMBER: IX = 9 104-- 105--SUBTRACT ONLY A SINGLE LETTER FROM A SINGLE NUMERAL. 106--VIII FOR 8, NOT IIX; 19 IS XIX, NOT IXX. 107-- 108--SUBTRACT ONLY POWERS of TEN, SUCH AS I, X, or C. 109--NOT VL FOR 45, BUT XLV. 110-- 111--DON'T SUBTRACT A LETTER FROM ANOTHER LETTER MORE THAN TEN TIMES GREATER. 112--ONLY SUBTRACT I FROM V or X, and X FROM L or C. 113--NOT IL FOR 49, BUT XLIX. MIM is ILLEGAL. 114-- 115--ONLY IF ANY NUMERAL PRECEEDING IS AT LEAST TEN TIMES LARGER. 116--NOT VIX FOR 14, BUT XIV. 117--NOT IIX, BUT VIII. 118--ONLY IF ANY NUMERAL FOLLOWING IS SMALLER. 119--NOT XCL FOR 140, BUT CXL. 120-- 121 J := S'LAST; 122 123 EVALUATE: 124 while J >= S'FIRST loop 125-- 126--Legal in the Ones position 127-- I 128-- II 129-- III 130-- IIII IV 131-- V 132-- VI 133-- VII 134-- VIII 135-- VIIII IX 136-- 137-- 138 -- Ones 139 if S(J) = 'I' then 140 TOTAL := TOTAL + 1; 141 J := J - 1; 142 exit EVALUATE when J < S'FIRST; 143 whiLe S(J) = 'I' loop 144 TOTAL := TOTAL + 1; 145 if TOTAL >= 5 then raise INVALID; end if; 146 J := J - 1; 147 exit EVALUATE when J < S'FIRST; 148 end loop; 149 end if; 150 151 if S(J) = 'V' then 152 TOTAL := TOTAL + 5; 153 J := J - 1; 154 exit EVALUATE when J < S'FIRST; 155 if S(J) = 'I' and TOTAL = 5 then 156 TOTAL := TOTAL - 1; 157 J := J - 1; 158 exit EVALUATE when J < S'FIRST; 159 end if; 160 161 if S(J) = 'I' or S(J) = 'V' then raise INVALID; end if; 162 end if; 163 164-- 165--Legal in the tens position 166-- X 167-- XX 168-- XXX 169-- XXXX XL 170-- L 171-- LX 172-- LXX 173-- LXXX 174-- LXXXX XC 175-- 176 177 -- Tens 178 if S(J) = 'X' then 179 TOTAL := TOTAL + 10; 180 J := J - 1; 181 exit EVALUATE when J < S'FIRST; 182 whiLe S(J) = 'X' loop 183 TOTAL := TOTAL + 10; 184 if TOTAL >= 50 then raise INVALID; end if; 185 J := J - 1; 186 exit EVALUATE when J < S'FIRST; 187 end loop; 188 if S(J) = 'I' and TOTAL = 10 then 189 TOTAL := TOTAL - 1; 190 J := J - 1; 191 exit EVALUATE when J < S'FIRST; 192 end if; 193 if S(J) = 'I' or S(J) = 'V' then 194 raise INVALID; 195 end if; 196 end if; 197 198 if S(J) = 'L' then 199 TOTAL := TOTAL + 50; 200 J := J - 1; 201 exit EVALUATE when J < S'FIRST; 202 203 if S(J) = 'X' and TOTAL <= 59 then 204 TOTAL := TOTAL - 10; 205 J := J - 1; 206 exit EVALUATE when J < S'FIRST; 207 end if; 208 if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' then raise INVALID; end if; 209 210 if S(J) = 'C' then 211 TOTAL := TOTAL + 100; 212 J := J - 1; 213 exit EVALUATE when J < S'FIRST; 214 if S(J) = 'X' and TOTAL = 100 then 215 TOTAL := TOTAL - 10; 216 J := J - 1; 217 exit EVALUATE when J < S'FIRST; 218 end if; 219 end if; 220 221 if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' then raise INVALID; end if; 222 end if; 223 224 225 if S(J) = 'C' then 226 TOTAL := TOTAL + 100; 227 J := J - 1; 228 exit EVALUATE when J < S'FIRST; 229 whiLe S(J) = 'C' loop 230 TOTAL := TOTAL + 100; 231 if TOTAL >= 500 then raise INVALID; end if; 232 J := J - 1; 233 exit EVALUATE when J < S'FIRST; 234 end loop; 235 if S(J) = 'X' and TOTAL <= 109 then 236 TOTAL := TOTAL - 10; 237 J := J - 1; 238 exit EVALUATE when J < S'FIRST; 239 end if; 240 if S(J) = 'I' or S(J) = 'V' or S(J) = 'X' or S(J) = 'L' then raise INVALID; end if; 241 end if; 242 243 244 245 if S(J) = 'D' then 246 TOTAL := TOTAL + 500; 247 J := J - 1; 248 exit EVALUATE when J < S'FIRST; 249 if S(J) = 'C' and TOTAL <= 599 then 250 TOTAL := TOTAL - 100; 251 J := J - 1; 252 exit EVALUATE when J < S'FIRST; 253 end if; 254 if S(J) = 'M' then 255 TOTAL := TOTAL + 1000; 256 J := J - 1; 257 exit EVALUATE when J < S'FIRST; 258 end if; 259 if S(J) = 'C' and TOTAL <= 1099 then 260 TOTAL := TOTAL - 100; 261 J := J - 1; 262 exit EVALUATE when J < S'FIRST; 263 end if; 264 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; 265 end if; 266 267 268 if S(J) = 'M' then 269 TOTAL := TOTAL + 1000; 270 J := J - 1; 271 exit EVALUATE when J < S'FIRST; 272 whiLe S(J) = 'M' loop 273 TOTAL := TOTAL + 1000; 274 if TOTAL >= 5000 then raise INVALID; end if; 275 J := J - 1; 276 exit EVALUATE when J < S'FIRST; 277 end loop; 278 if S(J) = 'C' and TOTAL <= 1099 then 279 TOTAL := TOTAL - 100; 280 J := J - 1; 281 exit EVALUATE when J < S'FIRST; 282 end if; 283 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; 284 end if; 285 286 287 end loop EVALUATE; 288 289 290 end if; -- On Only Roman digits 291 292 return TOTAL; 293 exception 294 when INVALID => 295 return 0; 296 when CONSTRAINT_ERROR => 297 return 0; 298 end ROMAN_NUMBER; 299 300 301 procedure ROMAN_NUMERALS(INPUT_WORD : STRING; 302 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is 303 304 W : constant STRING := TRIM(INPUT_WORD); 305 ROMAN_NUMBER_W : INTEGER := ROMAN_NUMBER(W); 306 307 begin 308 if ONLY_ROMAN_DIGITS(W) and then (ROMAN_NUMBER_W /= 0) then 309 PA_LAST := PA_LAST + 1; 310 PA(PA_LAST) := ( STEM => HEAD(W, MAX_STEM_SIZE), 311 IR => ( 312 QUAL => ( 313 POFS => NUM, 314 NUM => ( 315 DECL => (2, 0), 316 CS => X, 317 NUMBER => X, 318 GENDER => X, 319 SORT => CARD) ), 320 321 KEY => 0, 322 ENDING => NULL_ENDING_RECORD, 323 AGE => X, 324 FREQ => A), 325 D_K => RRR, 326 MNPC => NULL_MNPC); 327 RRR_MEANING := HEAD(INTEGER'IMAGE(ROMAN_NUMBER_W) & " as a ROMAN NUMERAL;", 328 MAX_MEANING_SIZE); 329 else 330 null; -- Is not ROMAN NUMERAL, so go on and try something else 331 end if; 332 end ROMAN_NUMERALS; 333 334 335 function BAD_ROMAN_NUMBER(S : STRING) return NATURAL is 336 -- Determines and returns the value of a Roman numeral, or 0 if invalid 337 -- This seems to allow all of Caesar's. Actually there are no rules 338 -- if you look at some of the 12-15 century stuff 339 use TEXT_IO; 340 TOTAL : INTEGER := 0; 341 DECREMENTED_FROM : INTEGER := 0; 342 343 begin 344 345 -- Already known that all the characters may be valid numerals 346 -- Loop over the string to check validity, start with second place 347 --PUT_LINE(" In function BAD_ROMAN_NUMBER "); 348 --PUT_LINE(" BEFORE LOOP S = " & S); 349 TOTAL := VALUE(S(S'LAST)); 350 DECREMENTED_FROM := VALUE(S(S'LAST)); 351 for I in reverse S'FIRST..S'LAST-1 loop 352 353 if VALUE(S(I)) < VALUE(S(I+1)) then 354 -- Decrement 355 TOTAL := TOTAL - VALUE(S(I)); 356 DECREMENTED_FROM := VALUE(S(I+1)); 357 elsif VALUE(S(I)) = VALUE(S(I+1)) then 358 if VALUE(S(I)) < DECREMENTED_FROM then 359 TOTAL := TOTAL - VALUE(S(I)); -- IIX = 8 ! 360 else 361 TOTAL := TOTAL + VALUE(S(I)); 362 end if; 363 elsif VALUE(S(I)) > VALUE(S(I+1)) then 364 TOTAL := TOTAL + VALUE(S(I)); 365 DECREMENTED_FROM := VALUE(S(I+1)); 366 end if; 367 end loop; 368 if TOTAL > 0 then 369 return TOTAL; 370 else 371 return 0; 372 end if; 373 374 exception 375 when others => 376 return 0; 377 end BAD_ROMAN_NUMBER; 378 379 380 381 procedure SYNCOPE(W : STRING; 382 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is 383 S : constant STRING(1..W'LENGTH) := LOWER_CASE(W); 384 PA_SAVE : INTEGER := PA_LAST; 385 SYNCOPE_INFLECTION_RECORD : INFLECTION_RECORD := NULL_INFLECTION_RECORD; 386 -- ((V, ((0, 0), (X, X, X), 0, X, X)), 0, NULL_ENDING_RECORD, X, A); 387 begin 388 389 -- Syncopated forms (see Gildersleeve and Lodge, 131) 390 391 YYY_MEANING := NULL_MEANING_TYPE; 392 393 394 395 -- This one has to go first -- special for 3 4 396 -- ivi => ii , in perfect (esp. for V 3 4) 397 -- This is handled in WORDS as syncope 398 -- It seems to appear in texts as alternative stems ii and ivi 399 for I in reverse S'FIRST..S'LAST-1 loop 400 if (S(I..I+1) = "ii") then 401 PA_LAST := PA_LAST + 1; 402 PA(PA_LAST) := ("Syncope ii => ivi", SYNCOPE_INFLECTION_RECORD, 403 YYY, NULL_MNPC); 404 WORD(S(S'FIRST..I) & "v" & S(I+1..S'LAST), PA, PA_LAST); 405 if PA_LAST > PA_SAVE + 1 then 406 exit; 407 end if; 408 end if; 409 PA_LAST := PA_SAVE; -- No luck, or it would have exited above 410 end loop; 411 if PA_LAST > PA_SAVE + 1 and then 412 PA(PA_LAST).IR.QUAL.POFS = V and then 413 --PA(PA_LAST).IR.QUAL.V.CON = (3, 4)/(6, 1) and then 414 PA(PA_LAST).IR.KEY = 3 then -- Perfect system 415 YYY_MEANING := HEAD( 416 "Syncopated perfect ivi can drop 'v' without contracting vowel " 417 , MAX_MEANING_SIZE); 418 419 PUT_STAT("SYNCOPE ivi at " 420 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 421 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 422 return; 423 else 424 PA_LAST := PA_SAVE; 425 end if; 426 427 428 429 430 -- avis => as, evis => es, ivis => is, ovis => os in perfect 431 for I in reverse S'FIRST..S'LAST-2 loop -- Need isse 432 if ((S(I..I+1) = "as") or 433 (S(I..I+1) = "es") or 434 (S(I..I+1) = "is") or 435 (S(I..I+1) = "os")) then 436 --TEXT_IO.PUT_LINE("SYNCOPE vis S = " & S & " PA_SAVE = " & INTEGER'IMAGE(PA_SAVE)); 437 PA_LAST := PA_LAST + 1; 438 PA(PA_LAST) := ("Syncope s => vis", SYNCOPE_INFLECTION_RECORD, 439 YYY, NULL_MNPC); 440 --TEXT_IO.PUT_LINE("SYNCOPE vis S+ = " & S(S'FIRST..I) & "vi" & S(I+1..S'LAST) & " " & INTEGER'IMAGE(PA_LAST)); 441 WORD(S(S'FIRST..I) & "vi" & S(I+1..S'LAST), PA, PA_LAST); 442 --TEXT_IO.PUT_LINE("SYNCOPE vis DONE " & " PA_LAST = " & INTEGER'IMAGE(PA_LAST)); 443 if PA_LAST > PA_SAVE + 1 then 444 exit; -- Exit loop here if SYNCOPE found hit 445 end if; 446 end if; 447 PA_LAST := PA_SAVE; -- No luck, or it would have exited above 448 end loop; 449 -- Loop over the resulting solutions 450 if PA_LAST > PA_SAVE + 1 and then 451 PA(PA_LAST).IR.QUAL.POFS = V and then 452 PA(PA_LAST).IR.KEY = 3 then -- Perfect system 453 YYY_MEANING := HEAD( 454 "Syncopated perfect often drops the 'v' and contracts vowel " 455 , MAX_MEANING_SIZE); 456 PUT_STAT("SYNCOPE vis at " 457 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 458 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 459 end if; 460 -- end loop; -- over resulting solutions 461 if PA_LAST > PA_SAVE + 1 then 462 463 return; 464 465 else 466 PA_LAST := PA_SAVE; 467 end if; 468 469 470 471 472 473 -- aver => ar, ever => er, in perfect 474 for I in reverse S'FIRST+1..S'LAST-2 loop 475 if ((S(I..I+1) = "ar") or 476 (S(I..I+1) = "er") or 477 (S(I..I+1) = "or")) then 478 PA_LAST := PA_LAST + 1; 479 PA(PA_LAST) := ("Syncope r => v.r", SYNCOPE_INFLECTION_RECORD, 480 YYY, NULL_MNPC); 481 WORD(S(S'FIRST..I) & "ve" & S(I+1..S'LAST), PA, PA_LAST); 482 if PA_LAST > PA_SAVE + 1 then 483 exit; 484 end if; 485 end if; 486 PA_LAST := PA_SAVE; -- No luck, or it would have exited above 487 end loop; 488 489 490 if PA_LAST > PA_SAVE + 1 and then 491 PA(PA_LAST).IR.QUAL.POFS = V and then 492 PA(PA_LAST).IR.KEY = 3 then -- Perfect system 493 YYY_MEANING := HEAD( 494 "Syncopated perfect often drops the 'v' and contracts vowel " 495 , MAX_MEANING_SIZE); 496 497 PUT_STAT("SYNCOPE ver at " 498 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 499 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 500 return; 501 else 502 PA_LAST := PA_SAVE; 503 end if; 504 505 506 507 508 -- iver => ier, in perfect 509 for I in reverse S'FIRST..S'LAST-3 loop 510 if (S(I..I+2) = "ier") then 511 PA_LAST := PA_LAST + 1; 512 PA(PA_LAST) := ("Syncope ier=>iver", SYNCOPE_INFLECTION_RECORD, 513 YYY, NULL_MNPC); 514 WORD(S(S'FIRST..I) & "v" & S(I+1..S'LAST), PA, PA_LAST); 515 if PA_LAST > PA_SAVE + 1 then 516 exit; 517 end if; 518 end if; 519 PA_LAST := PA_SAVE; -- No luck, or it would have exited above 520 end loop; 521 if PA_LAST > PA_SAVE + 1 and then 522 PA(PA_LAST).IR.QUAL.POFS = V and then 523 PA(PA_LAST).IR.KEY = 3 then -- Perfect system 524 YYY_MEANING := HEAD( 525 "Syncopated perfect often drops the 'v' and contracts vowel " 526 , MAX_MEANING_SIZE); 527 528 PUT_STAT("SYNCOPE ier at " 529 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 530 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 531 return; 532 else 533 PA_LAST := PA_SAVE; 534 end if; 535 536 537 538 539 540-- -- sis => s, xis => x, in perfect 541 for I in reverse S'FIRST..S'LAST-2 loop 542 if ((S(I) = 's') or 543 (S(I) = 'x')) then 544 PA_LAST := PA_LAST + 1; 545 PA(PA_LAST) := ("Syncope s/x => +is", SYNCOPE_INFLECTION_RECORD, 546 YYY, NULL_MNPC); 547 WORD(S(S'FIRST..I) & "is" & S(I+1..S'LAST), PA, PA_LAST); 548 if PA_LAST > PA_SAVE + 1 then 549 exit; -- Exit loop here if SYNCOPE found hit 550 end if; 551 end if; 552 PA_LAST := PA_SAVE; -- No luck, or it would have exited above 553 end loop; 554 -- Loop over the resulting solutions 555 if PA_LAST > PA_SAVE + 1 and then 556 PA(PA_LAST).IR.QUAL.POFS = V and then 557 PA(PA_LAST).IR.KEY = 3 then -- Perfect system 558 YYY_MEANING := HEAD( 559 "Syncopated perfect sometimes drops the 'is' after 's' or 'x' " 560 , MAX_MEANING_SIZE); 561 PUT_STAT("SYNCOPEx/sis at " 562 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 563 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 564 return; 565 else 566 PA_LAST := PA_SAVE; 567 end if; 568 569 570 571 572 573 574 -- end loop; -- over resulting solutions 575 if PA_LAST > PA_SAVE + 1 then 576 577 return; 578 579 else 580 PA_LAST := PA_SAVE; 581 end if; 582 583 584 585 586 PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys 587 588 589 exception 590 when others => 591 PA_LAST := PA_SAVE; 592 PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys 593 594 end SYNCOPE; 595 596 597 598 procedure TRY_TRICKS(W : STRING; 599 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER; 600 LINE_NUMBER : INTEGER; WORD_NUMBER : INTEGER) is 601 -- Since the chances are 1/1000 that we have one, 602 -- Ignore the possibility of two in the same word 603 -- That is called lying with statistics 604 use INFLECTIONS_PACKAGE.INTEGER_IO; 605 S : constant STRING(1..W'LENGTH) := W; 606 PA_SAVE : INTEGER := PA_LAST; 607 608 609 procedure TWORD(W : STRING; 610 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is 611 begin 612 WORD_PACKAGE.WORD(W, PA, PA_LAST); 613 SYNCOPE(W, PA, PA_LAST); 614 end TWORD; 615 616 617 procedure FLIP(X1, X2 : STRING; EXPLANATION : STRING := "") is 618 -- At the begining of input word, replaces X1 by X2 619 PA_SAVE : INTEGER := PA_LAST; 620 begin 621 if S'LENGTH >= X1'LENGTH+2 and then 622 S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 then 623 PA_LAST := PA_LAST + 1; 624 PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE), 625 NULL_INFLECTION_RECORD, 626 XXX, NULL_MNPC); 627 TWORD(X2 & S(S'FIRST+X1'LENGTH..S'LAST), PA, PA_LAST); 628 if (PA_LAST > PA_SAVE + 1) and then 629 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 630 if EXPLANATION = "" then 631 XXX_MEANING := HEAD( 632 "An initial '" & X1 & "' may have replaced usual '" & X2 & "'" 633 , MAX_MEANING_SIZE); 634 else 635 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 636 end if; 637 PUT_STAT("TRICK FLIP at " 638 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 639 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 640 return; 641 else 642 PA_LAST := PA_SAVE; 643 end if; 644 end if; 645 PA_LAST := PA_SAVE; 646 end FLIP; 647 648 649 650 procedure FLIP_FLOP(X1, X2 : STRING; EXPLANATION : STRING := "") is 651 -- At the begining of input word, replaces X1 by X2 - then X2 by X1 652 -- To be uesd only when X1 and X2 start with the same letter because it 653 -- will be called from a point where the first letter is established 654 PA_SAVE : INTEGER := PA_LAST; 655 begin 656--TEXT_IO.PUT_LINE("FLIP_FLOP called " & X1 & " " & X2); 657 if S'LENGTH >= X1'LENGTH+2 and then 658 S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 then 659 PA_LAST := PA_LAST + 1; 660 PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE), 661 NULL_INFLECTION_RECORD, 662 XXX, NULL_MNPC); 663 --TEXT_IO.PUT_LINE("Trying " & X2 & S(S'FIRST+X1'LENGTH..S'LAST)); 664 TWORD(X2 & S(S'FIRST+X1'LENGTH..S'LAST), PA, PA_LAST); 665 if (PA_LAST > PA_SAVE + 1) and then 666 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 667 --TEXT_IO.PUT_LINE("FLIPF worked"); 668 if EXPLANATION = "" then 669 XXX_MEANING := HEAD( 670 "An initial '" & X1 & "' may be rendered by '" & X2 & "'" 671 , MAX_MEANING_SIZE); 672 else 673 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 674 end if; 675 PUT_STAT("TRICK FLIPF at " 676 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 677 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 678 return; 679 else 680 PA_LAST := PA_SAVE; 681 end if; 682 end if; 683 --TEXT_IO.PUT_LINE("FLIPF failed"); 684 --TEXT_IO.PUT_LINE("Try FFLOP"); 685 686 687 688 if S'LENGTH >= X2'LENGTH+2 and then 689 S(S'FIRST..S'FIRST+X2'LENGTH-1) = X2 then 690 --TEXT_IO.PUT_LINE("Trying FFLOP"); 691 PA_LAST := PA_LAST + 1; 692 PA(PA_LAST) := (HEAD("Word mod " & X2 & "/" & X1, MAX_STEM_SIZE), 693 NULL_INFLECTION_RECORD, 694 XXX, NULL_MNPC); 695 --TEXT_IO.PUT_LINE("Trying " & X1 & S(S'FIRST+X2'LENGTH..S'LAST)); 696 TWORD(X1 & S(S'FIRST+X2'LENGTH..S'LAST), PA, PA_LAST); 697 if (PA_LAST > PA_SAVE + 1) and then 698 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 699 --TEXT_IO.PUT_LINE("FFLOP worked"); 700 if EXPLANATION = "" then 701 XXX_MEANING := HEAD( 702 "An initial '" & X2 & "' may be rendered by '" & X1 & "'" 703 , MAX_MEANING_SIZE); 704 else 705 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 706 end if; 707 PUT_STAT("TRICK FFLOP at " 708 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 709 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 710 return; 711 else 712 PA_LAST := PA_SAVE; 713 end if; 714 715 end if; 716 --TEXT_IO.PUT_LINE("FFLIP failed"); 717 PA_LAST := PA_SAVE; 718 end FLIP_FLOP; 719 720 721 722 procedure INTERNAL(X1, X2 : STRING; EXPLANATION : STRING := "") is 723 -- Replaces X1 with X2 anywhere in word and tries it for validity 724 PA_SAVE : INTEGER := PA_LAST; 725 begin 726 for I in S'FIRST..S'LAST-X1'LENGTH+1 loop 727 if S(I..I+X1'LENGTH-1) = X1 then 728 PA_LAST := PA_LAST + 1; 729 PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE), 730 NULL_INFLECTION_RECORD, 731 XXX, NULL_MNPC); 732 TWORD(S(S'FIRST..I-1) & X2 & S(I+X1'LENGTH..S'LAST), PA, PA_LAST); 733 if (PA_LAST > PA_SAVE + 1) and then 734 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 735 if EXPLANATION = "" then 736 XXX_MEANING := HEAD( 737 "An internal '" & X1 & "' might be rendered by '" & X2 & "'" 738 , MAX_MEANING_SIZE); 739 else 740 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 741 end if; 742 PUT_STAT("TRICK INTR at " 743 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 744 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 745 return; 746 else 747 PA_LAST := PA_SAVE; 748 end if; 749 end if; 750 end loop; 751 PA_LAST := PA_SAVE; 752 end INTERNAL; 753 754 procedure ADJ_TERMINAL_IIS(EXPLANATION : STRING := "") is 755 PA_SAVE : INTEGER := PA_LAST; 756 I : INTEGER := 0; 757 TRICK_TRANSLATION_RECORD : TRANSLATION_RECORD := NULL_TRANSLATION_RECORD; 758 begin 759 if S'LENGTH > 3 and then 760 S(S'LAST-1..S'LAST) = "is" then -- Terminal 'is' 761 PA_LAST := PA_LAST + 1; 762 TRICK_TRANSLATION_RECORD.FREQ := C; 763 PA(PA_LAST) := (HEAD("Word mod iis -> is", MAX_STEM_SIZE), 764 NULL_INFLECTION_RECORD, 765 XXX, NULL_MNPC); 766 WORD(S(S'FIRST..S'LAST-2) & "iis", PA, PA_LAST); 767 if (PA_LAST > PA_SAVE + 1) then 768 I := PA_LAST; 769 while I > PA_SAVE + 1 loop 770 if PA(I).IR.QUAL.POFS = ADJ and then 771 PA(I).IR.QUAL.ADJ.DECL = (1, 1) and then 772 ((PA(I).IR.QUAL.ADJ.CS = DAT) or 773 (PA(I).IR.QUAL.ADJ.CS = ABL)) and then 774 PA(I).IR.QUAL.ADJ.NUMBER = P then 775 null; -- Only for ADJ 1 1 DAT/ABL P 776 else 777 PA(I..PA_LAST-1) := PA(I+1..PA_LAST); 778 PA_LAST := PA_LAST - 1; 779 end if; 780 I := I - 1; 781 end loop; 782 end if; 783 if (PA_LAST > PA_SAVE + 1) then 784 if EXPLANATION = "" then 785 XXX_MEANING := HEAD("A Terminal 'iis' on ADJ 1 1 DAT/ABL P might drop 'i'", 786 MAX_MEANING_SIZE); 787 else 788 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 789 end if; 790 PUT_STAT("TRICK ADJIS at " 791 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 792 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 793 return; 794 else 795 PA_LAST := PA_SAVE; 796 end if; 797 end if; 798 PA_LAST := PA_SAVE; 799 end ADJ_TERMINAL_IIS; 800 801 802 -- Now SLUR is handled in TRY_SLURY 803 -- 804 -- procedure SLUR(X1 : STRING; EXPLANATION : STRING := "") is 805 -- PA_SAVE : INTEGER := PA_LAST; 806 -- SL : INTEGER := X1'LENGTH; 807 -- begin 808 -- if S'LENGTH >= X1'LENGTH+2 then 809 -- if S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 and then -- Initial X1 810 -- not IS_A_VOWEL(S(S'FIRST+SL)) then 811 -- PA_LAST := PA_LAST + 1; 812 -- PA(PA_LAST) := (HEAD("Slur " & X1 & "/" & X1(1..SL-1) & "~", MAX_STEM_SIZE), 813 -- NULL_INFLECTION_RECORD, 814 -- XXX, NULL_MNPC); 815 -- TWORD(X1(1..SL-1) & S(S'FIRST+SL) & S(S'FIRST+SL..S'LAST), PA, PA_LAST); 816 -- if (PA_LAST > PA_SAVE + 1) and then 817 -- (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 818 -- if EXPLANATION = "" then 819 -- XXX_MEANING := HEAD( 820 -- "An initial '" & X1 & "' may be rendered by " & X1(1) & "~" 821 -- , MAX_MEANING_SIZE); 822 -- else 823 -- XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 824 -- end if; 825 --PUT_STAT("TRICK SLUR at " 826 -- & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 827 -- & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 828 -- return; 829 -- else 830 -- PA_LAST := PA_SAVE; 831 -- end if; 832 -- 833 -- elsif (S(S'FIRST..S'FIRST+SL-1) = X1(1..SL-1)) and then 834 -- (S(S'FIRST+SL-1) = S(S'FIRST+SL)) and then -- Double letter 835 -- not IS_A_VOWEL(S(S'FIRST+SL)) then 836 -- PA_LAST := PA_LAST + 1; 837 -- PA(PA_LAST) := (HEAD("Slur " & X1(1..SL-1) & "~" & "/" & X1, MAX_STEM_SIZE), 838 -- NULL_INFLECTION_RECORD, 839 -- XXX, NULL_MNPC); 840 -- TWORD(X1 & S(S'FIRST+SL..S'LAST), PA, PA_LAST); 841 -- if (PA_LAST > PA_SAVE + 1) and then 842 -- (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 843 -- if EXPLANATION = "" then 844 -- XXX_MEANING := HEAD( 845 -- "An initial '" & X1(1..SL-1) & "~" & "' may be rendered by " & X1 846 -- , MAX_MEANING_SIZE); 847 -- else 848 -- XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 849 -- end if; 850 --PUT_STAT("TRICK SLUR at " 851 -- & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 852 -- & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 853 -- return; 854 -- else 855 -- PA_LAST := PA_SAVE; 856 -- end if; 857 -- 858 -- end if; 859 -- end if; 860 -- PA_LAST := PA_SAVE; 861 -- end SLUR; 862 -- 863 -- 864 865 procedure DOUBLE_CONSONANTS(EXPLANATION : STRING := "") is 866 PA_SAVE : INTEGER := PA_LAST; 867 begin 868 -- Medieval often replaced a classical doubled consonant with single 869 -- The problem is to take possible medieval words 870 -- and double (all) (isolated) consonants 871 for I in S'FIRST+1..S'LAST-1 loop -- probably dont need to go to end 872 if (not IS_A_VOWEL(S(I))) and then 873 (IS_A_VOWEL(S(I-1)) and IS_A_VOWEL(S(I+1))) then 874 PA_LAST := PA_LAST + 1; 875 PA(PA_LAST) := (HEAD("Word mod " & S(I) & 876 " -> " & S(I) & S(I), MAX_STEM_SIZE), 877 NULL_INFLECTION_RECORD, 878 XXX, NULL_MNPC); 879 TWORD(S(S'FIRST..I) & S(I) & S(I+1..S'LAST), PA, PA_LAST); 880 --TEXT_IO.PUT_LINE(S(S'FIRST..I) & S(I) & S(I+1..S'LAST)); 881 if (PA_LAST > PA_SAVE + 1) and then 882 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 883 if EXPLANATION = "" then 884 XXX_MEANING := HEAD( 885 "A doubled consonant may be rendered by just the single" 886 & " MEDIEVAL", MAX_MEANING_SIZE); 887 else 888 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 889 end if; 890 PUT_STAT("TRICK 2CON at " 891 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 892 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 893 return; 894 else 895 PA_LAST := PA_SAVE; 896 end if; 897 898 end if; 899 end loop; 900 PA_LAST := PA_SAVE; 901 end DOUBLE_CONSONANTS; 902 903 904 procedure TWO_WORDS(EXPLANATION : STRING := "") is 905 -- This procedure examines the word to determine if it is made up 906 -- of two separate inflectted words 907 -- They are usually an adjective and a noun or two nouns 908 PA_SAVE, PA_SECOND : INTEGER := PA_LAST; 909 NUM_HIT_ONE, NUM_HIT_TWO : BOOLEAN := FALSE; 910 --MID : INTEGER := S'LENGTH/2; 911 I, I_MID : INTEGER := 0; 912 REMEMBER_SYNCOPE : BOOLEAN := FALSE; 913 procedure WORDS_NO_SYNCOPE (W : STRING; 914 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is 915 begin 916 if WORDS_MDEV(DO_SYNCOPE) then 917 REMEMBER_SYNCOPE := TRUE; 918 WORDS_MDEV(DO_SYNCOPE) := FALSE; 919 end if; 920 WORD_PACKAGE.WORD(W, PA, PA_LAST); 921 if REMEMBER_SYNCOPE then 922 WORDS_MDEV(DO_SYNCOPE) := TRUE; 923 end if; 924 end WORDS_NO_SYNCOPE; 925 926 927 function COMMON_PREFIX(S : STRING) return BOOLEAN is 928 -- Common prefixes that have corresponding words (prepositions usually) 929 -- which could confuse TWO_WORDS. We wish to reject these. 930 begin 931 if S = "dis" or 932 S = "ex" or 933 S = "in" or 934 S = "per" or 935 S = "prae" or 936 S = "pro" or 937 S = "re" or 938 S = "si" or 939 S = "sub" or 940 S = "super" or 941 S = "trans" then 942 return TRUE; 943 else 944 return FALSE; 945 end if; 946 end COMMON_PREFIX; 947 948 begin 949 --TEXT_IO.PUT_LINE("Entering TWO_WORDS PA_LAST = " & INTEGER'IMAGE(PA_LAST)); 950 --if S(S'FIRST) /= 'q' then -- qu words more complicated 951 952 953 if S'LENGTH < 5 then -- Dont try on too short words 954 return; 955 end if; 956 957 I := 2; -- Smallest is re-publica, but that killed by PREFIX, meipsum 958 OUTER_LOOP: 959 while I < S'LENGTH - 2 loop 960 961 PA_LAST := PA_LAST + 1; 962 PA(PA_LAST):= (HEAD("Two words", MAX_STEM_SIZE), 963 NULL_INFLECTION_RECORD, 964 XXX, NULL_MNPC); 965 --TEXT_IO.PUT_LINE("Setting PA TWO_WORDS PA_LAST = " & INTEGER'IMAGE(PA_LAST)); 966 967 while I < S'LENGTH - 2 loop 968 --TEXT_IO.PUT_LINE("Trying " & S(S'FIRST..S'FIRST+I-1)); 969 if not COMMON_PREFIX(S(S'FIRST..S'FIRST+I-1)) then 970 WORDS_NO_SYNCOPE(S(S'FIRST..S'FIRST+I-1), PA, PA_LAST); 971 if (PA_LAST > PA_SAVE + 1) then 972 I_MID := I; 973 for J in PA_SAVE+1..PA_LAST loop 974 if PA(J).IR.QUAL.POFS = NUM then 975 NUM_HIT_ONE := TRUE; 976 exit; 977 end if; 978 end loop; 979 980 --TEXT_IO.PUT_LINE("HIT first " & S(S'FIRST..I_MID-1) & " PA_LAST = " & INTEGER'IMAGE(PA_LAST)); 981 --PARSE_RECORD_IO.PUT(PA(PA_LAST)); TEXT_IO.NEW_LINE; 982 983 exit; 984 end if; 985 end if; 986 I := I + 1; 987 end loop; 988 989 if (PA_LAST > PA_SAVE + 1) then 990 null; 991 --TEXT_IO.PUT_LINE("Confirm first " & S(S'FIRST..I_MID) & " PA_LAST =" & INTEGER'IMAGE(PA_LAST)); 992 else 993 --TEXT_IO.PUT_LINE("No possible first " & S(S'FIRST..I_MID)); 994 PA_LAST := PA_SAVE; 995 return; 996 end if; 997 998 -- Now for second word 999 --TEXT_IO.PUT_LINE("Looking for second >" & S(I_MID+1..S'LAST)); 1000 PA_LAST := PA_LAST + 1; 1001 PA(PA_LAST) := NULL_PARSE_RECORD; -- Separator 1002 PA_SECOND := PA_LAST; 1003 WORDS_NO_SYNCOPE(S(I_MID+1..S'LAST), PA, PA_LAST); 1004 if (PA_LAST > PA_SECOND) and then -- No + 1 since XXX taken care of above 1005 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 1006 for J in PA_SECOND..PA_LAST loop 1007 if PA(J).IR.QUAL.POFS = NUM then 1008 NUM_HIT_TWO := TRUE; 1009 exit; 1010 end if; 1011 end loop; 1012 1013 --TEXT_IO.PUT_LINE("Found second " & S(I_MID+1..S'LAST) & " PA_LAST = " & INTEGER'IMAGE(PA_LAST)); 1014 1015 if EXPLANATION = "" then 1016 1017 if WORDS_MODE(TRIM_OUTPUT) and then 1018 -- Should check that cases correspond 1019 (NUM_HIT_ONE and NUM_HIT_TWO) then 1020 -- Clear out any non-NUM if we are in TRIM 1021 for J in PA_SAVE+1..PA_LAST loop 1022 if PA(J).D_K in GENERAL..UNIQUE and then 1023 PA(J).IR.QUAL.POFS /= NUM then 1024 PA(J..PA_LAST-1) := PA(J+1..PA_LAST); 1025 PA_LAST := PA_LAST - 1; 1026 end if; 1027 end loop; 1028 1029 1030 XXX_MEANING := HEAD( 1031 "It is very likely a compound number " & 1032 S(S'FIRST..S'FIRST+I-1) & " + " & 1033 S(S'FIRST+I..S'LAST), MAX_MEANING_SIZE); 1034 PUT_STAT("TRICK 2NUM at " 1035 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1036 & " " & HEAD(W, 20) & " " & S(1..I_MID) & '+' & S(I_MID+1..S'LAST)); 1037 else 1038 XXX_MEANING := HEAD( 1039 "May be 2 words combined (" & 1040 S(S'FIRST..S'FIRST+I-1) & "+" & 1041 S(S'FIRST+I..S'LAST) & 1042 ") If not obvious, probably incorrect", MAX_MEANING_SIZE); 1043 PUT_STAT("TRICK 2WDS at " 1044 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1045 & " " & HEAD(W, 20) & " " & S(1..I_MID) & '+' & S(I_MID+1..S'LAST)); 1046 end if; 1047 else 1048 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 1049 end if; 1050 1051 --TEXT_IO.PUT_LINE("Returing from 2WDS PA_SAVE+1 = " & INTEGER'IMAGE(PA_SAVE+1) & " " & PA(PA_SAVE+1).STEM); 1052 1053 1054 return; 1055 else 1056 PA_LAST := PA_SAVE; 1057 end if; 1058 1059 I := I + 1; 1060 end loop OUTER_LOOP; 1061 1062 PA_LAST := PA_SAVE; -- No success, so reset to clear the TRICK PA 1063 1064 1065 1066 1067 -- I could try to check cases/gender/number for matches 1068 -- Discard all that do not have a match 1069 -- ADJ, N, NUM 1070 -- But that is probably being too pedantic for a case which may be sloppy 1071 end TWO_WORDS; 1072 1073 1074 -------------------------------------------------------------------------- 1075 -------------------------------------------------------------------------- 1076 -------------------------------------------------------------------------- 1077 -------------------------------------------------------------------------- 1078 1079 begin 1080 -- These things might be genericized, at least the PA(1) assignments 1081--TEXT_IO.PUT_LINE("TRICKS called"); 1082 1083 XXX_MEANING := NULL_MEANING_TYPE; 1084 1085 1086 1087 1088 -- If there is no satisfaction from above, we will try further 1089 1090 case S(S'FIRST) is 1091 1092 when 'a' => 1093 1094 1095 --FLIP_FLOP("abs", "aps"); if PA_LAST > 0 then return; end if; 1096 --FLIP_FLOP("acq", "adq"); if PA_LAST > 0 then return; end if; 1097 FLIP_FLOP("adgn", "agn"); 1098 if PA_LAST > 0 then 1099 return; end if; 1100 FLIP_FLOP("adsc", "asc"); 1101 if PA_LAST > 0 then 1102 return; end if; 1103 FLIP_FLOP("adsp", "asp"); 1104 if PA_LAST > 0 then 1105 return; end if; 1106 --FLIP_FLOP("ante", "anti"); if PA_LAST > 0 then return; end if; 1107 FLIP_FLOP("arqui", "arci"); 1108 if PA_LAST > 0 then 1109 return; end if; 1110 FLIP_FLOP("arqu", "arcu"); 1111 if PA_LAST > 0 then 1112 return; end if; 1113 --FLIP_FLOP("auri", "aure"); if PA_LAST > 0 then return; end if; 1114 --FLIP_FLOP("auri", "auru"); if PA_LAST > 0 then return; end if; 1115 --SLUR("ad"); if PA_LAST > 0 then return; end if; 1116 FLIP("ae", "e"); 1117 if PA_LAST > 0 then 1118 return; end if; 1119 FLIP("al", "hal"); 1120 if PA_LAST > 0 then 1121 return; end if; 1122 FLIP("am", "ham"); 1123 if PA_LAST > 0 then 1124 return; end if; 1125 FLIP("ar", "har"); 1126 if PA_LAST > 0 then 1127 return; end if; 1128 FLIP("aur", "or"); 1129 if PA_LAST > 0 then 1130 return; end if; 1131 1132 1133 1134 1135 -- when 'c' => 1136 1137 --FLIP("circum" , "circun"); if PA_LAST > 0 then return; end if; 1138 --FLIP_FLOP("con", "com"); if PA_LAST > 0 then return; end if; 1139 --FLIP("co" , "com"); if PA_LAST > 0 then return; end if; 1140 --FLIP("co" , "con"); if PA_LAST > 0 then return; end if; 1141 --FLIP_FLOP("conl" , "coll"); if PA_LAST > 0 then return; end if; 1142 1143 1144 when 'd' => 1145 1146 FLIP("dampn" , "damn"); 1147 if PA_LAST > 0 then 1148 return; end if; 1149 FLIP_FLOP("dij" , "disj"); -- OLD p.543 1150 if PA_LAST > 0 then 1151 return; end if; 1152 FLIP_FLOP("dir" , "disr"); -- OLD p.556 1153 if PA_LAST > 0 then 1154 return; end if; 1155 FLIP_FLOP("dir" , "der"); -- OLD p.547 1156 if PA_LAST > 0 then 1157 return; end if; 1158 FLIP_FLOP("del" , "dil"); -- OLD p.507/543 1159 if PA_LAST > 0 then 1160 return; end if; 1161 1162 1163 when 'e' => 1164 1165 FLIP_FLOP("ecf" , "eff"); 1166 if PA_LAST > 0 then 1167 return; end if; 1168 FLIP_FLOP("ecs" , "exs"); 1169 if PA_LAST > 0 then 1170 return; end if; 1171 FLIP_FLOP("es" , "ess"); 1172 if PA_LAST > 0 then 1173 return; end if; 1174 FLIP_FLOP("ex" , "exs"); 1175 if PA_LAST > 0 then 1176 return; end if; 1177 1178 FLIP("eid", "id"); 1179 if PA_LAST > 0 then 1180 return; end if; 1181 FLIP("el", "hel"); 1182 if PA_LAST > 0 then 1183 return; end if; 1184 FLIP("e", "ae"); 1185 if PA_LAST > 0 then 1186 return; end if; 1187 1188 when 'f' => 1189 1190 FLIP_FLOP("faen" , "fen"); 1191 if PA_LAST > 0 then 1192 return; end if; 1193 1194 FLIP_FLOP("faen" , "foen"); 1195 if PA_LAST > 0 then 1196 return; end if; 1197 1198 FLIP_FLOP("fed" , "foed"); 1199 if PA_LAST > 0 then 1200 return; end if; 1201 1202 FLIP_FLOP("fet" , "foet"); 1203 if PA_LAST > 0 then 1204 return; end if; 1205 1206 FLIP("f", "ph"); 1207 if PA_LAST > 0 then 1208 return; end if; -- Try lead then all 1209 1210 when 'g' => 1211 1212 FLIP("gna", "na"); 1213 if PA_LAST > 0 then 1214 return; end if; 1215 1216 when 'h' => 1217 1218 FLIP("har", "ar"); 1219 if PA_LAST > 0 then 1220 return; end if; 1221 FLIP("hal", "al"); 1222 if PA_LAST > 0 then 1223 return; end if; 1224 FLIP("ham", "am"); 1225 if PA_LAST > 0 then 1226 return; end if; 1227 FLIP("hel", "el"); 1228 if PA_LAST > 0 then 1229 return; end if; 1230 FLIP("hol", "ol"); 1231 if PA_LAST > 0 then 1232 return; end if; 1233 FLIP("hum", "um"); 1234 if PA_LAST > 0 then 1235 return; end if; 1236 1237 1238 when 'i' => 1239 1240 1241 --SLUR("in"); if PA_LAST > 1 then return; end if; 1242 1243 --FLIP_FLOP("inb", "imb"); if PA_LAST > 1 then return; end if; 1244 --FLIP_FLOP("inp", "imp"); if PA_LAST > 1 then return; end if; 1245 1246 1247 1248 -- for some forms of eo the stem "i" grates with an "is..." ending 1249 if S'LENGTH > 1 and then 1250 S(S'FIRST..S'FIRST+1) = "is" then 1251 PA(1) := ("Word mod is => iis", NULL_INFLECTION_RECORD, 1252 XXX, NULL_MNPC); 1253 PA_LAST := 1; 1254 TWORD("i" & S(S'FIRST..S'LAST), PA, PA_LAST); 1255 end if; 1256 if (PA_LAST > PA_SAVE + 1) and then 1257 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) and then 1258 PA(PA_LAST).IR.QUAL.POFS = V and then 1259 PA(PA_LAST).IR.QUAL.V.CON = (6, 1) then -- Check it is V 6 1 eo 1260 XXX_MEANING := HEAD( 1261 "Some forms of eo stem 'i' grates with an 'is...' ending, so 'is' -> 'iis' " 1262 , MAX_MEANING_SIZE); 1263 return; 1264 else 1265 PA_LAST := 0; 1266 end if; 1267 1268 1269 1270 1271 1272 1273 when 'k' => 1274 1275 FLIP("k", "c"); 1276 if PA_LAST > 0 then 1277 return; end if; 1278 FLIP("c", "k"); 1279 if PA_LAST > 0 then 1280 return; end if; 1281 1282 1283 when 'l' => 1284 1285 1286 FLIP_FLOP("lub", "lib"); 1287 if PA_LAST > 1 then 1288 return; end if; 1289 1290 1291 when 'm' => 1292 1293 1294 FLIP_FLOP("mani", "manu"); 1295 if PA_LAST > 1 then 1296 return; end if; 1297 1298 1299 1300 when 'n' => 1301 1302 1303 FLIP("na", "gna"); 1304 if PA_LAST > 0 then 1305 return; end if; 1306 1307 FLIP_FLOP("nihil", "nil"); 1308 if PA_LAST > 0 then 1309 return; end if; 1310 1311 --FLIP("nun", "non"); if PA_LAST > 0 then return; end if; 1312 1313 1314 1315 when 'o' => 1316 1317 --SLUR("ob"); if PA_LAST > 0 then return; end if; 1318 FLIP_FLOP("obt", "opt"); 1319 if PA_LAST > 1 then 1320 return; end if; 1321 FLIP_FLOP("obs", "ops"); 1322 if PA_LAST > 1 then 1323 return; end if; 1324 FLIP("ol", "hol"); 1325 if PA_LAST > 0 then 1326 return; end if; 1327 FLIP("opp", "op"); 1328 if PA_LAST > 1 then 1329 return; end if; 1330 FLIP("or", "aur"); 1331 if PA_LAST > 0 then 1332 return; end if; 1333 1334 1335 1336 when 'p' => 1337 1338 1339 FLIP("ph", "f"); 1340 if PA_LAST > 0 then 1341 return; end if; -- Try lead then all 1342 FLIP_FLOP("pre", "prae"); 1343 if PA_LAST > 1 then 1344 return; end if; 1345 1346 1347 -- when 'q' => 1348 1349 1350 --FLIP_FLOP("quadri", "quadru"); if PA_LAST > 0 then return; end if; 1351 1352 1353 when 's' => 1354 1355 1356 -- From Oxford Latin Dictionary p.1835 "sub-" 1357 1358 --SLUR("sub"); 1359 1360 FLIP_FLOP("subsc", "susc"); 1361 if PA_LAST > 0 then 1362 return; end if; 1363 FLIP_FLOP("subsp", "susp"); 1364 if PA_LAST > 0 then 1365 return; end if; 1366 1367 FLIP_FLOP("subc", "susc"); 1368 if PA_LAST > 0 then 1369 return; end if; 1370 FLIP_FLOP("succ", "susc"); 1371 if PA_LAST > 0 then 1372 return; end if; 1373 1374 FLIP_FLOP("subt", "supt"); 1375 if PA_LAST > 0 then 1376 return; end if; 1377 FLIP_FLOP("subt", "sust"); 1378 if PA_LAST > 0 then 1379 return; end if; 1380 1381 1382 when 't' => 1383 1384 1385 FLIP_FLOP("transv", "trav"); 1386 if PA_LAST > 0 then 1387 return; end if; 1388-- FLIP("trig", "tric"); 1389-- if PA_LAST > 0 then 1390-- return; end if; 1391 1392 1393 1394 1395 when 'u' => 1396 1397 FLIP("ul", "hul"); 1398 if PA_LAST > 0 then 1399 return; end if; 1400 FLIP("uol", "vul"); 1401 if PA_LAST > 0 then 1402 return; end if; -- u is not v for this purpose 1403 1404 1405 1406 when 'y' => 1407 1408 FLIP("y", "i"); 1409 if PA_LAST > 0 then 1410 return; end if; 1411 1412 when 'z' => 1413 1414 FLIP("z", "di"); 1415 if PA_LAST > 0 then 1416 return; end if; 1417 1418 when others => null; 1419 1420 end case; -- case on first letter 1421 1422 1423 1424 INTERNAL("ae", "e"); 1425 if PA_LAST > 0 then 1426 return; end if; 1427 1428 INTERNAL("bul", "bol"); 1429 if PA_LAST > 0 then 1430 return; end if; 1431 INTERNAL("bol", "bul"); 1432 if PA_LAST > 0 then 1433 return; end if; 1434 1435 INTERNAL("cl", "cul"); 1436 if PA_LAST > 0 then 1437 return; end if; 1438 1439 INTERNAL("cu", "quu"); 1440 if PA_LAST > 0 then 1441 return; end if; 1442 1443 INTERNAL("f", "ph"); 1444 if PA_LAST > 0 then 1445 return; end if; 1446 INTERNAL("ph", "f"); 1447 if PA_LAST > 0 then 1448 return; end if; 1449 1450 INTERNAL("h", ""); 1451 if PA_LAST > 0 then 1452 return; end if; 1453 1454 1455 INTERNAL("oe", "e"); 1456 if PA_LAST > 0 then 1457 return; end if; 1458 1459 INTERNAL("vul", "vol"); 1460 if PA_LAST > 0 then 1461 return; end if; 1462 INTERNAL("vol", "vul"); 1463 if PA_LAST > 0 then 1464 return; end if; 1465 INTERNAL("uol", "vul"); 1466 if PA_LAST > 0 then 1467 return; end if; 1468 1469 1470 ADJ_TERMINAL_IIS; 1471 if PA_LAST > 0 then 1472 return; end if; 1473 1474 1475 1476 --------------------------------------------------------------- 1477 1478 1479 if WORDS_MDEV(DO_MEDIEVAL_TRICKS) then 1480 -- Medieval -> Classic 1481 1482 -- Harrington/Elliott 1.1.1 1483 1484 INTERNAL("col", "caul"); 1485 if PA_LAST > 0 then 1486 return; end if; 1487 1488 --TEXT_IO.PUT_LINE("Trying com -> con"); 1489 --INTERNAL("com", "con"); if PA_LAST > 0 then return; end if; -- My own 1490 1491 --INTERNAL("cl", "cul"); if PA_LAST > 0 then return; end if; 1492 1493 1494 -- Harrington/Elliott 1.3 1495 1496 INTERNAL("e", "ae"); 1497 if PA_LAST > 0 then 1498 return; end if; 1499 1500 INTERNAL("o", "u"); 1501 if PA_LAST > 0 then 1502 return; end if; 1503 1504 INTERNAL("i", "y"); 1505 if PA_LAST > 0 then 1506 return; end if; 1507 1508 1509 -- Harrington/Elliott 1.3.1 1510 1511 INTERNAL("ism", "sm"); 1512 if PA_LAST > 0 then 1513 return; end if; 1514 1515 INTERNAL("isp", "sp"); 1516 if PA_LAST > 0 then 1517 return; end if; 1518 1519 INTERNAL("ist", "st"); 1520 if PA_LAST > 0 then 1521 return; end if; 1522 1523 INTERNAL("iz", "z"); 1524 if PA_LAST > 0 then 1525 return; end if; 1526 1527 INTERNAL("esm", "sm"); 1528 if PA_LAST > 0 then 1529 return; end if; 1530 1531 INTERNAL("esp", "sp"); 1532 if PA_LAST > 0 then 1533 return; end if; 1534 1535 INTERNAL("est", "st"); 1536 if PA_LAST > 0 then 1537 return; end if; 1538 1539 INTERNAL("ez", "z"); 1540 if PA_LAST > 0 then 1541 return; end if; 1542 1543 1544 -- Harrington/Elliott 1.4 1545 1546 INTERNAL("di", "z"); 1547 if PA_LAST > 0 then 1548 return; end if; 1549 1550 INTERNAL("f", "ph"); 1551 if PA_LAST > 0 then 1552 return; end if; 1553 1554 INTERNAL("is", "ix"); 1555 if PA_LAST > 0 then 1556 return; end if; 1557 1558 1559 INTERNAL("b", "p"); 1560 if PA_LAST > 0 then 1561 return; end if; 1562 1563 INTERNAL("d", "t"); 1564 if PA_LAST > 0 then 1565 return; end if; 1566 1567 INTERNAL("v", "b"); 1568 if PA_LAST > 0 then 1569 return; end if; 1570 1571 INTERNAL("v", "f"); 1572 if PA_LAST > 0 then 1573 return; end if; 1574 1575 INTERNAL("v", "f"); 1576 if PA_LAST > 0 then 1577 return; end if; 1578 1579 INTERNAL("s", "x"); 1580 if PA_LAST > 0 then 1581 return; end if; 1582 1583 1584 1585 -- Harrington/Elliott 1.4.1 1586 1587 INTERNAL("ci", "ti"); 1588 if PA_LAST > 0 then 1589 return; end if; 1590 1591 1592 -- Harrington/Elliott 1.4.2 1593 1594 INTERNAL("nt", "nct"); 1595 if PA_LAST > 0 then 1596 return; end if; 1597 1598 INTERNAL("s", "ns"); 1599 if PA_LAST > 0 then 1600 return; end if; 1601 1602 1603 -- Others 1604 1605 INTERNAL("ch", "c"); 1606 if PA_LAST > 0 then 1607 return; end if; 1608 1609 INTERNAL("c", "ch"); 1610 if PA_LAST > 0 then 1611 return; end if; 1612 1613 INTERNAL("th", "t"); 1614 if PA_LAST > 0 then 1615 return; end if; 1616 1617 INTERNAL("t", "th"); 1618 if PA_LAST > 0 then 1619 return; end if; 1620 1621 1622 1623 1624 DOUBLE_CONSONANTS; 1625 1626 1627 end if; -- Medieval Tricks 1628 --------------------------------------------------------------- 1629 1630 if not (WORDS_MODE(IGNORE_UNKNOWN_NAMES) and CAPITALIZED) then -- Don't try on Names 1631 if WORDS_MDEV(DO_TWO_WORDS) then 1632 TWO_WORDS; 1633 end if; 1634 end if; 1635 1636 1637 1638 -- It could be an improperly formed Roman Numeral 1639 if ONLY_ROMAN_DIGITS(W) then 1640 1641 1642 PA_LAST := 1; 1643 PA(1) := ("Bad Roman Numeral?", NULL_INFLECTION_RECORD, 1644 XXX, NULL_MNPC); 1645 XXX_MEANING := NULL_MEANING_TYPE; 1646 1647 RRR_MEANING := HEAD(INTEGER'IMAGE(BAD_ROMAN_NUMBER(W)) & " as ill-formed ROMAN NUMERAL?;", 1648 MAX_MEANING_SIZE); 1649 PA_LAST := PA_LAST + 1; 1650 PA(PA_LAST) := ( STEM => HEAD(W, MAX_STEM_SIZE), 1651 IR => ( 1652 QUAL => ( 1653 POFS => NUM, 1654 NUM => ( 1655 DECL => (2, 0), 1656 CS => X, 1657 NUMBER => X, 1658 GENDER => X, 1659 SORT => CARD) ), 1660 1661 KEY => 0, 1662 ENDING => NULL_ENDING_RECORD, 1663 AGE => X, 1664 FREQ => D), 1665 D_K => RRR, 1666 MNPC => NULL_MNPC ); 1667 1668 return; 1669 end if; 1670 1671 1672 1673 1674 exception 1675 when others => -- I want to ignore anything that happens in TRICKS 1676 PA_LAST := PA_SAVE; 1677 PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys 1678 1679 TEXT_IO.PUT_LINE( -- ERROR_FILE, 1680 "Exception in TRY_TRICKS processing " & W); 1681 end TRY_TRICKS; 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 procedure TRY_SLURY(W : STRING; 1693 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER; 1694 LINE_NUMBER : INTEGER; WORD_NUMBER : INTEGER) is 1695 -- Since the chances are 1/1000 that we have one, 1696 -- Ignore the possibility of two in the same word 1697 -- That is called lying with statistics 1698 use INFLECTIONS_PACKAGE.INTEGER_IO; 1699 S : constant STRING(1..W'LENGTH) := W; 1700 PA_SAVE : INTEGER := PA_LAST; 1701 1702 1703 procedure TWORD(W : STRING; 1704 PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is 1705 SAVE_USE_PREFIXES : BOOLEAN := WORDS_MDEV(USE_PREFIXES); 1706 begin 1707 WORDS_MDEV(USE_PREFIXES) := FALSE; 1708 WORD_PACKAGE.WORD(W, PA, PA_LAST); 1709 SYNCOPE(W, PA, PA_LAST); 1710 WORDS_MDEV(USE_PREFIXES) := SAVE_USE_PREFIXES; 1711 end TWORD; 1712 1713 1714 1715 procedure FLIP(X1, X2 : STRING; EXPLANATION : STRING := "") is 1716 -- At the begining of input word, replaces X1 by X2 1717 PA_SAVE : INTEGER := PA_LAST; 1718 begin 1719 if S'LENGTH >= X1'LENGTH+2 and then 1720 S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 then 1721 PA_LAST := PA_LAST + 1; 1722 PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE), 1723 NULL_INFLECTION_RECORD, 1724 XXX, NULL_MNPC); 1725 TWORD(X2 & S(S'FIRST+X1'LENGTH..S'LAST), PA, PA_LAST); 1726 if (PA_LAST > PA_SAVE + 1) and then 1727 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 1728 if EXPLANATION = "" then 1729 XXX_MEANING := HEAD( 1730 "An initial '" & X1 & "' may be rendered by '" & X2 & "'" 1731 , MAX_MEANING_SIZE); 1732 else 1733 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 1734 end if; 1735 PUT_STAT("SLURY FLIP at " 1736 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1737 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 1738 return; 1739 else 1740 PA_LAST := PA_SAVE; 1741 end if; 1742 end if; 1743 PA_LAST := PA_SAVE; 1744 end FLIP; 1745 1746 1747 1748 procedure FLIP_FLOP(X1, X2 : STRING; EXPLANATION : STRING := "") is 1749 -- At the begining of input word, replaces X1 by X2 - then X2 by X1 1750 -- To be uesd only when X1 and X2 start with the same letter because it 1751 -- will be called from a point where the first letter is established 1752 PA_SAVE : INTEGER := PA_LAST; 1753 begin 1754 if S'LENGTH >= X1'LENGTH+2 and then 1755 S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 then 1756 PA_LAST := PA_LAST + 1; 1757 PA(PA_LAST) := (HEAD("Word mod " & X1 & "/" & X2, MAX_STEM_SIZE), 1758 NULL_INFLECTION_RECORD, 1759 XXX, NULL_MNPC); 1760 TWORD(X2 & S(S'FIRST+X1'LENGTH..S'LAST), PA, PA_LAST); 1761 if (PA_LAST > PA_SAVE + 1) and then 1762 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 1763 if EXPLANATION = "" then 1764 XXX_MEANING := HEAD( 1765 "An initial '" & X1 & "' may be rendered by '" & X2 & "'" 1766 , MAX_MEANING_SIZE); 1767 else 1768 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 1769 end if; 1770 PUT_STAT("SLURY FLOP at " 1771 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1772 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 1773 return; 1774 else 1775 PA_LAST := PA_SAVE; 1776 end if; 1777 1778 elsif S'LENGTH >= X2'LENGTH+2 and then 1779 S(S'FIRST..S'FIRST+X2'LENGTH-1) = X2 then 1780 PA_LAST := PA_LAST + 1; 1781 PA(PA_LAST) := (HEAD("Word mod " & X2 & "/" & X1, MAX_STEM_SIZE), 1782 NULL_INFLECTION_RECORD, 1783 XXX, NULL_MNPC); 1784 TWORD(X1 & S(S'FIRST+X2'LENGTH..S'LAST), PA, PA_LAST); 1785 if (PA_LAST > PA_SAVE + 1) and then 1786 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 1787 if EXPLANATION = "" then 1788 XXX_MEANING := HEAD( 1789 "An initial '" & X1 & "' may be rendered by '" & X2 & "'" 1790 , MAX_MEANING_SIZE); 1791 else 1792 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 1793 end if; 1794 PUT_STAT("SLURY FLOP at " 1795 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1796 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 1797 return; 1798 else 1799 PA_LAST := PA_SAVE; 1800 end if; 1801 1802 end if; 1803 PA_LAST := PA_SAVE; 1804 end FLIP_FLOP; 1805 1806 1807 1808 1809 1810 procedure SLUR(X1 : STRING; EXPLANATION : STRING := "") is 1811 PA_SAVE : INTEGER := PA_LAST; 1812 SL : INTEGER := X1'LENGTH; 1813 begin 1814 if S'LENGTH >= X1'LENGTH+2 then 1815 if S(S'FIRST..S'FIRST+X1'LENGTH-1) = X1 and then -- Initial X1 1816 not IS_A_VOWEL(S(S'FIRST+SL)) then 1817 PA_LAST := PA_LAST + 1; 1818 PA(PA_LAST) := (HEAD("Slur " & X1 & "/" & X1(1..SL-1) & "~", MAX_STEM_SIZE), 1819 NULL_INFLECTION_RECORD, 1820 XXX, NULL_MNPC); 1821 TWORD(X1(1..SL-1) & S(S'FIRST+SL) & S(S'FIRST+SL..S'LAST), PA, PA_LAST); 1822 if (PA_LAST > PA_SAVE + 1) and then 1823 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 1824 if EXPLANATION = "" then 1825 XXX_MEANING := HEAD( 1826 "An initial '" & X1 & "' may be rendered by " & X1(1..X1'LAST-1) & "~", 1827 MAX_MEANING_SIZE); 1828 else 1829 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 1830 end if; 1831 PUT_STAT("SLURY SLUR at " 1832 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1833 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 1834 return; 1835 else 1836 PA_LAST := PA_SAVE; 1837 end if; 1838 1839 elsif (S(S'FIRST..S'FIRST+SL-1) = X1(1..SL-1)) and then 1840 (S(S'FIRST+SL-1) = S(S'FIRST+SL)) and then -- double letter 1841 not IS_A_VOWEL(S(S'FIRST+SL)) then 1842 PA_LAST := PA_LAST + 1; 1843 PA(PA_LAST) := (HEAD("Slur " & X1(1..SL-1) & "~" & "/" & X1, MAX_STEM_SIZE), 1844 NULL_INFLECTION_RECORD, 1845 XXX, NULL_MNPC); 1846 TWORD(X1 & S(S'FIRST+SL..S'LAST), PA, PA_LAST); 1847 if (PA_LAST > PA_SAVE + 1) and then 1848 (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) then 1849 if EXPLANATION = "" then 1850 XXX_MEANING := HEAD( 1851 "An initial '" & X1(1..SL-1) & "~" & "' may be rendered by " & X1 1852 , MAX_MEANING_SIZE); 1853 else 1854 XXX_MEANING := HEAD(EXPLANATION, MAX_MEANING_SIZE); 1855 end if; 1856 PUT_STAT("SLURY SLUR at " 1857 & HEAD(INTEGER'IMAGE(LINE_NUMBER), 8) & HEAD(INTEGER'IMAGE(WORD_NUMBER), 4) 1858 & " " & HEAD(W, 20) & " " & PA(PA_SAVE+1).STEM); 1859 return; 1860 else 1861 PA_LAST := PA_SAVE; 1862 end if; 1863 1864 end if; 1865 end if; 1866 PA_LAST := PA_SAVE; 1867 end SLUR; 1868 1869 begin 1870 1871 --XXX_MEANING := NULL_MEANING_TYPE; 1872 1873 1874 -- If there is no satisfaction from above, we will try further 1875 1876 if S(S'FIRST) = 'a' then 1877 1878 1879 FLIP_FLOP("abs", "aps"); 1880 if PA_LAST > 0 then 1881 return; end if; 1882 FLIP_FLOP("acq", "adq"); 1883 if PA_LAST > 0 then 1884 return; end if; 1885 --FLIP_FLOP("adgn", "agn"); if PA_LAST > 0 then return; end if; 1886 --FLIP_FLOP("adsc", "asc"); if PA_LAST > 0 then return; end if; 1887 --FLIP_FLOP("adsp", "asp"); if PA_LAST > 0 then return; end if; 1888 FLIP_FLOP("ante", "anti"); 1889 if PA_LAST > 0 then 1890 return; end if; 1891 --FLIP_FLOP("arqui", "arci"); if PA_LAST > 0 then return; end if; 1892 --FLIP_FLOP("arqu", "arcu"); if PA_LAST > 0 then return; end if; 1893 FLIP_FLOP("auri", "aure"); 1894 if PA_LAST > 0 then 1895 return; end if; 1896 FLIP_FLOP("auri", "auru"); 1897 if PA_LAST > 0 then 1898 return; end if; 1899 SLUR("ad"); 1900 if PA_LAST > 0 then 1901 return; end if; 1902 --FLIP("ae", "e"); if PA_LAST > 0 then return; end if; 1903 --FLIP("al", "hal"); if PA_LAST > 0 then return; end if; 1904 --FLIP("am", "ham"); if PA_LAST > 0 then return; end if; 1905 --FLIP("ar", "har"); if PA_LAST > 0 then return; end if; 1906 --FLIP("aur", "or"); if PA_LAST > 0 then return; end if; 1907 1908 1909 1910 1911 elsif S(S'FIRST) = 'c' then 1912 1913 FLIP("circum" , "circun"); 1914 if PA_LAST > 0 then 1915 return; end if; 1916 FLIP_FLOP("con", "com"); 1917 if PA_LAST > 0 then 1918 return; end if; 1919 FLIP("co" , "com"); 1920 if PA_LAST > 0 then 1921 return; end if; 1922 FLIP("co" , "con"); 1923 if PA_LAST > 0 then 1924 return; end if; 1925 FLIP_FLOP("conl" , "coll"); 1926 if PA_LAST > 0 then 1927 return; end if; 1928 1929 1930 --elsif S(S'FIRST) = 'e' then 1931 1932 --FLIP_FLOP("ecf" , "eff"); if PA_LAST > 0 then return; end if; 1933 --FLIP_FLOP("ecs" , "exs"); if PA_LAST > 0 then return; end if; 1934 --FLIP_FLOP("es" , "ess"); if PA_LAST > 0 then return; end if; 1935 --FLIP_FLOP("ex" , "exs"); if PA_LAST > 0 then return; end if; 1936 1937 --FLIP("el", "hel"); if PA_LAST > 0 then return; end if; 1938 --FLIP("e", "ae"); if PA_LAST > 0 then return; end if; 1939 1940 --elsif S(S'FIRST) = 'f' then 1941 1942 --FLIP_FLOP("faen" , "foen"); if PA_LAST > 0 then return; end if; 1943 1944 --FLIP("f", "ph"); if PA_LAST > 0 then return; end if; -- Try lead then all 1945 1946 --elsif S(S'FIRST) = 'g' then 1947 1948 --FLIP("gna", "na"); if PA_LAST > 0 then return; end if; 1949 1950 --elsif S(S'FIRST) = 'h' then 1951 1952 --FLIP("har", "ar"); if PA_LAST > 0 then return; end if; 1953 --FLIP("hal", "al"); if PA_LAST > 0 then return; end if; 1954 --FLIP("ham", "am"); if PA_LAST > 0 then return; end if; 1955 --FLIP("hel", "el"); if PA_LAST > 0 then return; end if; 1956 --FLIP("hol", "ol"); if PA_LAST > 0 then return; end if; 1957 --FLIP("hum", "um"); if PA_LAST > 0 then return; end if; 1958 1959 1960 elsif S(S'FIRST) = 'i' then 1961 1962 1963 SLUR("in"); 1964 if PA_LAST > 1 then 1965 return; end if; 1966 1967 FLIP_FLOP("inb", "imb"); 1968 if PA_LAST > 1 then 1969 return; end if; 1970 FLIP_FLOP("inp", "imp"); 1971 if PA_LAST > 1 then 1972 return; end if; 1973 1974 1975 1976 -- -- for some forms of eo the stem "i" grates with an "is..." ending 1977 -- if S'LENGTH > 1 and then 1978 -- S(S'FIRST..S'FIRST+1) = "is" then 1979 -- PA(1) := ("Word mod is => iis", NULL_INFLECTION_RECORD, 1980 -- XXX, NULL_MNPC); 1981 -- PA_LAST := 1; 1982 -- TWORD("i" & S(S'FIRST..S'LAST), PA, PA_LAST); 1983 -- end if; 1984 -- if (PA_LAST > PA_SAVE + 1) and then 1985 -- (PA(PA_LAST-1).IR.QUAL.POFS /= TACKON) and then 1986 -- PA(PA_LAST).IR.QUAL.POFS = V and then 1987 -- PA(PA_LAST).IR.QUAL.V.CON = (6, 1) then -- Check it is V 6 1 eo 1988 -- XXX_MEANING := HEAD( 1989 --"Some forms of eo stem 'i' grates with an 'is...' ending, so 'is' -> 'iis' " 1990 -- , MAX_MEANING_SIZE); 1991 -- return; 1992 -- else 1993 -- PA_LAST := 0; 1994 -- end if; 1995 1996 1997 1998 1999 2000 2001 --elsif S(S'FIRST) = 'k' then 2002 2003 --FLIP("k", "c"); if PA_LAST > 0 then return; end if; 2004 --FLIP("c", "k"); if PA_LAST > 0 then return; end if; 2005 2006 2007 --elsif S(S'FIRST) = 'l' then 2008 2009 2010 --FLIP_FLOP("lub", "lib"); if PA_LAST > 1 then return; end if; 2011 2012 2013 --elsif S(S'FIRST) = 'm' then 2014 2015 2016 --FLIP_FLOP("mani", "manu"); if PA_LAST > 1 then return; end if; 2017 2018 2019 2020 elsif S(S'FIRST) = 'n' then 2021 2022 2023 --FLIP("na", "gna"); if PA_LAST > 0 then return; end if; 2024 2025 --FLIP_FLOP("nihil", "nil"); if PA_LAST > 0 then return; end if; 2026 2027 FLIP("nun", "non"); 2028 if PA_LAST > 0 then 2029 return; end if; 2030 2031 2032 2033 elsif S(S'FIRST) = 'o' then 2034 2035 SLUR("ob"); 2036 if PA_LAST > 0 then 2037 return; end if; 2038 --FLIP_FLOP("obt", "opt"); if PA_LAST > 1 then return; end if; 2039 --FLIP_FLOP("obs", "ops"); if PA_LAST > 1 then return; end if; 2040 --FLIP("ol", "hol"); if PA_LAST > 0 then return; end if; 2041 --FLIP("opp", "op"); if PA_LAST > 1 then return; end if; 2042 --FLIP("or", "aur"); if PA_LAST > 0 then return; end if; 2043 2044 2045 2046 --elsif S(S'FIRST) = 'p' then 2047 2048 2049 --FLIP("ph", "f"); if PA_LAST > 0 then return; end if; -- Try lead then all 2050 --FLIP_FLOP("pre", "prae"); if PA_LAST > 1 then return; end if; 2051 2052 2053 elsif S(S'FIRST) = 'q' then 2054 2055 2056 FLIP_FLOP("quadri", "quadru"); 2057 if PA_LAST > 0 then 2058 return; end if; 2059 2060 2061 elsif S(S'FIRST) = 's' then 2062 2063 FLIP("se", "ce"); -- Latham 2064 if PA_LAST > 0 then 2065 return; end if; 2066 2067 -- From Oxford Latin Dictionary p.1835 "sub-" 2068 2069 SLUR("sub"); 2070 2071 --FLIP_FLOP("subsc", "susc"); if PA_LAST > 0 then return; end if; 2072 --FLIP_FLOP("subsp", "susp"); if PA_LAST > 0 then return; end if; 2073 2074 --FLIP_FLOP("subc", "susc"); if PA_LAST > 0 then return; end if; 2075 --FLIP_FLOP("succ", "susc"); if PA_LAST > 0 then return; end if; 2076 2077 --FLIP_FLOP("subt", "sust"); if PA_LAST > 0 then return; end if; 2078 2079 2080 --elsif S(S'FIRST) = 't' then 2081 2082 2083 --FLIP_FLOP("transv", "trav"); if PA_LAST > 0 then return; end if; 2084 2085 2086 2087 2088 --elsif S(S'FIRST) = 'u' then 2089 2090 --FLIP("ul", "hul"); if PA_LAST > 0 then return; end if; 2091 --FLIP("uol", "vul"); if PA_LAST > 0 then return; end if; -- u is not v for this purpose 2092 2093 2094 2095 --elsif S(S'FIRST) = 'y' then 2096 2097 --FLIP("y", "i"); if PA_LAST > 0 then return; end if; 2098 2099 2100 end if; -- if on first letter 2101 2102 2103 -- All INTERNAL out 2104 --INTERNAL("ae", "e"); if PA_LAST > 0 then return; end if; 2105 -- 2106 -- 2107 --INTERNAL("cl", "cul"); if PA_LAST > 0 then return; end if; 2108 -- 2109 --INTERNAL("cu", "quu"); if PA_LAST > 0 then return; end if; 2110 -- 2111 --INTERNAL("f", "ph"); if PA_LAST > 0 then return; end if; 2112 --INTERNAL("ph", "f"); if PA_LAST > 0 then return; end if; 2113 -- 2114 --INTERNAL("h", ""); if PA_LAST > 0 then return; end if; 2115 -- 2116 -- 2117 --INTERNAL("vul", "vol"); if PA_LAST > 0 then return; end if; 2118 --INTERNAL("vol", "vul"); if PA_LAST > 0 then return; end if; 2119 --INTERNAL("uol", "vul"); if PA_LAST > 0 then return; end if; 2120 -- 2121 -- 2122 --ADJ_TERMINAL_IIS; if PA_LAST > 0 then return; end if; 2123 2124 2125 2126 --------------------------------------------------------------- 2127 2128 2129 --if WORDS_MDEV(DO_MEDIEVAL_TRICKS) then 2130 ---- Medieval -> Classic 2131 -- 2132 ---- Harrington/Elliott 1.1.1 2133 -- 2134 --INTERNAL("col", "caul"); if PA_LAST > 0 then return; end if; 2135 -- 2136 ----TEXT_IO.PUT_LINE("Trying com -> con"); 2137 ----INTERNAL("com", "con"); if PA_LAST > 0 then return; end if; -- My own 2138 -- 2139 ----INTERNAL("cl", "cul"); if PA_LAST > 0 then return; end if; 2140 -- 2141 -- 2142 ---- Harrington/Elliott 1.3 2143 -- 2144 --INTERNAL("e", "ae"); if PA_LAST > 0 then return; end if; 2145 -- 2146 --INTERNAL("o", "u"); if PA_LAST > 0 then return; end if; 2147 -- 2148 --INTERNAL("i", "y"); if PA_LAST > 0 then return; end if; 2149 -- 2150 -- 2151 ---- Harrington/Elliott 1.3.1 2152 -- 2153 --INTERNAL("ism", "sm"); if PA_LAST > 0 then return; end if; 2154 -- 2155 --INTERNAL("isp", "sp"); if PA_LAST > 0 then return; end if; 2156 -- 2157 --INTERNAL("ist", "st"); if PA_LAST > 0 then return; end if; 2158 -- 2159 --INTERNAL("iz", "z"); if PA_LAST > 0 then return; end if; 2160 -- 2161 --INTERNAL("esm", "sm"); if PA_LAST > 0 then return; end if; 2162 -- 2163 --INTERNAL("esp", "sp"); if PA_LAST > 0 then return; end if; 2164 -- 2165 --INTERNAL("est", "st"); if PA_LAST > 0 then return; end if; 2166 -- 2167 --INTERNAL("ez", "z"); if PA_LAST > 0 then return; end if; 2168 -- 2169 -- 2170 ---- Harrington/Elliott 1.4 2171 -- 2172 --INTERNAL("di", "z"); if PA_LAST > 0 then return; end if; 2173 -- 2174 ----INTERNAL("f", "ph"); if PA_LAST > 0 then return; end if; 2175 -- 2176 --INTERNAL("is", "ix"); if PA_LAST > 0 then return; end if; 2177 -- 2178 -- 2179 --INTERNAL("b", "p"); if PA_LAST > 0 then return; end if; 2180 -- 2181 --INTERNAL("d", "t"); if PA_LAST > 0 then return; end if; 2182 -- 2183 --INTERNAL("v", "b"); if PA_LAST > 0 then return; end if; 2184 -- 2185 --INTERNAL("v", "f"); if PA_LAST > 0 then return; end if; 2186 -- 2187 --INTERNAL("v", "f"); if PA_LAST > 0 then return; end if; 2188 -- 2189 --INTERNAL("s", "x"); if PA_LAST > 0 then return; end if; 2190 -- 2191 -- 2192 -- 2193 ---- Harrington/Elliott 1.4.1 2194 -- 2195 --INTERNAL("ci", "ti"); if PA_LAST > 0 then return; end if; 2196 -- 2197 -- 2198 ---- Harrington/Elliott 1.4.2 2199 -- 2200 --INTERNAL("nt", "nct"); if PA_LAST > 0 then return; end if; 2201 -- 2202 --INTERNAL("nt", "nct"); if PA_LAST > 0 then return; end if; 2203 -- 2204 -- 2205 --DOUBLE_CONSONANTS; 2206 -- 2207 -- 2208 --end if; -- Medieval Tricks 2209 --------------------------------------------- 2210 2211 exception 2212 when others => -- I want to ignore anything that happens in SLURY 2213 PA_LAST := PA_SAVE; 2214 PA(PA_LAST+1) := NULL_PARSE_RECORD; -- Just to clear the trys 2215 2216 TEXT_IO.PUT_LINE( -- ERROR_FILE, 2217 "Exception in TRY_SLURY processing " & W); 2218 end TRY_SLURY; 2219 2220 2221 end TRICKS_PACKAGE; 2222