-
Notifications
You must be signed in to change notification settings - Fork 15
/
Copy pathlist_sweep.adb
910 lines (745 loc) · 38.3 KB
/
list_sweep.adb
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
with TEXT_IO;
with STRINGS_PACKAGE; use STRINGS_PACKAGE;
with WORD_PARAMETERS; use WORD_PARAMETERS;
with INFLECTIONS_PACKAGE; use INFLECTIONS_PACKAGE;
with DICTIONARY_PACKAGE; use DICTIONARY_PACKAGE;
with UNIQUES_PACKAGE; use UNIQUES_PACKAGE;
with DEVELOPER_PARAMETERS; use DEVELOPER_PARAMETERS;
with WORD_SUPPORT_PACKAGE; use WORD_SUPPORT_PACKAGE;
procedure LIST_SWEEP(PA : in out PARSE_ARRAY; PA_LAST : in out INTEGER) is
-- This procedure is supposed to process the output PARSE_ARRAY at PA level
-- before it get turned into SIRAA and DMNPCA in LIST_PACKAGE
-- Since it does only PARSE_ARRAY it is just cheaking INFLECTIONS, not DICTIOARY
use INFLECTION_RECORD_IO;
use DICT_IO;
PR, OPR : PARSE_RECORD := NULL_PARSE_RECORD;
DE : DICTIONARY_ENTRY := NULL_DICTIONARY_ENTRY;
I, J, JJ : INTEGER := 0;
DIFF_J : INTEGER := 0;
NOT_ONLY_ARCHAIC : BOOLEAN := FALSE;
NOT_ONLY_MEDIEVAL : BOOLEAN := FALSE;
NOT_ONLY_UNCOMMON : BOOLEAN := FALSE;
function ALLOWED_STEM(PR : PARSE_RECORD) return BOOLEAN is
ALLOWED : BOOLEAN := TRUE; -- modify as necessary and return it
--DE : DICTIONARY_ENTRY;
begin
--TEXT_IO.PUT("ALLOWED? >"); PARSE_RECORD_IO.PUT(PR); TEXT_IO.NEW_LINE;
if PR.D_K not in GENERAL..LOCAL then
return TRUE; end if;
--DICT_IO.SET_INDEX(DICT_FILE(PR.D_K), PR.MNPC);
--DICT_IO.READ(DICT_FILE(PR.D_K), DE);
DICT_IO.READ(DICT_FILE(PR.D_K), DE, PR.MNPC);
--TEXT_IO.PUT("ALLOWED? >"); DICTIONARY_ENTRY_IO.PUT(DE); TEXT_IO.NEW_LINE;
-- if PR.D_K in GENERAL..UNIQUE then
-- if (DE.TRAN.AGE = X) or else (DE.TRAN.AGE > A) then
-- NOT_ONLY_ARCHAIC_STEM := TRUE;
-- end if;
-- if DE.TRAN.AGE < F then -- Or E????
-- NOT_ONLY_MEDIEVAL_STEM := TRUE;
-- end if;
-- if DE.TRAN.FREQ < E then -- -- E for DICTLINE is uncommon !!!!
-- NOT_ONLY_UNCOMMON_STEM := TRUE;
-- end if;
-- end if;
-- NOUN CHECKS
case PR.IR.QUAL.POFS is
when N =>
if WORDS_MDEV(FOR_WORD_LIST_CHECK) then
if (NOM <= PR.IR.QUAL.N.CS) and then
(S <= PR.IR.QUAL.N.NUMBER) then
ALLOWED := TRUE;
elsif (NOM <= PR.IR.QUAL.N.CS) and then
(PR.IR.QUAL.N.NUMBER = P) then
SEARCH_FOR_PL:
declare
DE : DICTIONARY_ENTRY;
MEAN : MEANING_TYPE := NULL_MEANING_TYPE;
begin
ALLOWED := FALSE;
DICT_IO.READ(DICT_FILE(PR.D_K), DE, PR.MNPC);
MEAN := DE.MEAN;
for J in MEANING_TYPE'FIRST..MEANING_TYPE'LAST-2 loop
if MEAN(J..J+2) = "pl." then
ALLOWED := TRUE;
exit;
end if;
end loop;
end SEARCH_FOR_PL;
--====================================
else
ALLOWED := FALSE;
end if;
end if;
when ADJ =>
if WORDS_MDEV(FOR_WORD_LIST_CHECK) then
if (NOM <= PR.IR.QUAL.ADJ.CS) and then
(S <= PR.IR.QUAL.ADJ.NUMBER) and then
(M <= PR.IR.QUAL.ADJ.GENDER) then
ALLOWED := TRUE;
else
ALLOWED := FALSE;
end if;
end if;
-- VERB CHECKS
when V =>
--TEXT_IO.PUT("VERB ");
-- Check for Verb 3 1 dic/duc/fac/fer shortened imperative
-- See G&L 130.5
declare
STEM : constant STRING := TRIM(PR.STEM);
LAST_THREE : STRING(1..3);
begin
if (PR.IR.QUAL.V = ((3, 1), (PRES, ACTIVE, IMP), 2, S)) and
(PR.IR.ENDING.SIZE = 0) then -- For this special case
if STEM'LENGTH >= 3 then
LAST_THREE := STEM(STEM'LAST-2..STEM'LAST);
if (LAST_THREE = "dic") or
(LAST_THREE = "duc") or
(LAST_THREE = "fac") or
(LAST_THREE = "fer") then
null;
else
ALLOWED := FALSE;
end if;
else
ALLOWED := FALSE;
end if;
end if;
end;
-- Check for Verb Imperative being in permitted person
if (PR.IR.QUAL.V.TENSE_VOICE_MOOD.MOOD = IMP) then
if (PR.IR.QUAL.V.TENSE_VOICE_MOOD.TENSE = PRES) and
(PR.IR.QUAL.V.PERSON = 2) then
null;
elsif (PR.IR.QUAL.V.TENSE_VOICE_MOOD.TENSE = FUT) and
(PR.IR.QUAL.V.PERSON = 2 or PR.IR.QUAL.V.PERSON = 3) then
null;
else
--PUT("IMP not in permitted person "); PUT(PR.IR); NEW_LINE;
ALLOWED := FALSE;
end if;
end if;
-- Check for V IMPERS and demand that only 3rd person -- ???????
if (DE.PART.V.KIND = IMPERS) then
if (PR.IR.QUAL.V.PERSON = 3) then
null;
else
--PUT("IMPERS not in 3rd person "); PUT(PR.IR); NEW_LINE;
ALLOWED := FALSE;
end if;
end if;
-- Check for V DEP and demand PASSIVE
if (DE.PART.V.KIND = DEP) then
--TEXT_IO.PUT("DEP ");
if (PR.IR.QUAL.V.TENSE_VOICE_MOOD.VOICE = ACTIVE) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.MOOD = INF) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.TENSE = FUT) then
--TEXT_IO.PUT("PASSIVE ");
--TEXT_IO.PUT("DEP FUT INF not in ACTIVE "); PUT(PR.IR); TEXT_IO.NEW_LINE;
ALLOWED := TRUE;
elsif (PR.IR.QUAL.V.TENSE_VOICE_MOOD.VOICE = ACTIVE) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.MOOD in IND..INF) then
--TEXT_IO.PUT("ACTIVE ");
--TEXT_IO.PUT("DEP not in PASSIVE NOT ALLOWED "); PUT(PR.IR); TEXT_IO.NEW_LINE;
ALLOWED := FALSE;
else
--TEXT_IO.PUT("?????? ");
null;
end if;
end if;
-- Check for V SEMIDEP and demand PASSIVE ex Perf
if (DE.PART.V.KIND = SEMIDEP) then
if (PR.IR.QUAL.V.TENSE_VOICE_MOOD.VOICE = PASSIVE) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.TENSE in PRES..FUT) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.MOOD in IND..IMP) then
--PUT("SEMIDEP Pres not in ACTIVE "); PUT(PR.IR); NEW_LINE;
ALLOWED := FALSE;
elsif (PR.IR.QUAL.V.TENSE_VOICE_MOOD.VOICE = ACTIVE) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.TENSE in PERF..FUTP ) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD.MOOD in IND..IMP) then
--PUT("SEMIDEP Perf not in PASSIVE "); PUT(PR.IR); NEW_LINE;
ALLOWED := FALSE;
else
null;
end if;
end if;
if WORDS_MDEV(FOR_WORD_LIST_CHECK) then
if (PR.IR.QUAL.V.PERSON = 1) and then
(PR.IR.QUAL.V.NUMBER = S) then
if ((DE.PART.V.KIND in X..INTRANS) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD = (PRES, ACTIVE, IND))) or else
((DE.PART.V.KIND = DEP) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD = (PRES, PASSIVE, IND))) or else
((DE.PART.V.KIND = SEMIDEP) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD = (PRES, ACTIVE, IND))) then
ALLOWED := TRUE;
elsif ((DE.PART.V.KIND = PERFDEF) and
(PR.IR.QUAL.V.TENSE_VOICE_MOOD = (PERF, ACTIVE, IND))) then
ALLOWED := TRUE;
else
ALLOWED := FALSE;
end if;
elsif (DE.PART.V.KIND = IMPERS) then
if (PR.IR.QUAL.V.PERSON = 3) and then
(PR.IR.QUAL.V.NUMBER = S) and then
(PR.IR.QUAL.V.TENSE_VOICE_MOOD = (PRES, ACTIVE, IND)) then
ALLOWED := TRUE;
else
ALLOWED := FALSE;
end if;
else
ALLOWED := FALSE;
end if;
end if;
when others =>
null;
end case;
if WORDS_MDEV(FOR_WORD_LIST_CHECK) then -- Non parts
if (PR.IR.QUAL.POFS in VPAR..SUPINE) then
ALLOWED := FALSE;
end if;
end if; -- Non parts
--TEXT_IO.PUT_LINE("Returning FOR ALLOWED " & BOOLEAN'IMAGE(ALLOWED));
return ALLOWED;
end ALLOWED_STEM;
-----------------------------------------------------------
procedure ORDER_PARSE_ARRAY(SL: in out PARSE_ARRAY; DIFF_J : out INTEGER) is
use INFLECTION_RECORD_IO;
use DICT_IO;
HITS : INTEGER := 0;
SL_FIRST : INTEGER := SL'FIRST;
SL_LAST : INTEGER := SL'LAST;
SL_LAST_INITIAL : INTEGER := SL_LAST;
SM : PARSE_RECORD;
--DE, ODE : DICTIONARY_ENTRY;
ROMAN_NUMBER : BOOLEAN := FALSE;
HAS_NOUN_ABBREVIATION : BOOLEAN := FALSE;
-- HAS_ADJECTIVE_ABBREVIATION : BOOLEAN := FALSE;
-- HAS_VERB_ABBREVIATION : BOOLEAN := FALSE;
NOT_ONLY_VOCATIVE : BOOLEAN := FALSE;
NOT_ONLY_LOCATIVE : BOOLEAN := FALSE;
J : INTEGER := SL'FIRST;
function DEPR (PR : PARSE_RECORD) return DICTIONARY_ENTRY is
DE : DICTIONARY_ENTRY;
begin
--TEXT_IO.PUT("DEPR "); PARSE_RECORD_IO.PUT(PR); TEXT_IO.NEW_LINE;
if PR.MNPC = NULL_MNPC then
return NULL_DICTIONARY_ENTRY;
else
if PR.D_K in GENERAL..LOCAL then
--if PR.MNPC /= OMNPC then
DICT_IO.SET_INDEX(DICT_FILE(PR.D_K), PR.MNPC);
DICT_IO.READ(DICT_FILE(PR.D_K), DE);
--OMNPC := PR.MNPC;
--ODE := DE;
--else
--DE := ODE;
--end if;
elsif PR.D_K = UNIQUE then
DE := UNIQUES_DE(PR.MNPC);
end if;
end if;
-- DICT_IO.SET_INDEX(DICT_FILE(PR.D_K), PR.MNPC);
-- DICT_IO.READ(DICT_FILE(PR.D_K), DE);
--TEXT_IO.PUT_LINE("Returning from DEPR MNPC = " & INTEGER'IMAGE(INTEGER(PR.MNPC)) & " ");
--DICTIONARY_ENTRY_IO.PUT(DE); TEXT_IO.NEW_LINE;
return DE;
end DEPR;
begin
if SL'LENGTH = 0 then
return;
end if;
-- Bubble sort since this list should usually be very small (1-5)
HIT_LOOP:
loop
HITS := 0;
--------------------------------------------------
SWITCH:
declare
function "<" (LEFT, RIGHT : QUALITY_RECORD) return BOOLEAN is
begin
if LEFT.POFS = RIGHT.POFS and then
LEFT.POFS = PRON and then
LEFT.PRON.DECL.WHICH = 1 then
return (LEFT.PRON.DECL.VAR < RIGHT.PRON.DECL.VAR);
else
return INFLECTIONS_PACKAGE."<"(LEFT, RIGHT);
end if;
end "<";
function EQU (LEFT, RIGHT : QUALITY_RECORD) return BOOLEAN is
begin
if LEFT.POFS = RIGHT.POFS and then
LEFT.POFS = PRON and then
LEFT.PRON.DECL.WHICH = 1 then
return (LEFT.PRON.DECL.VAR = RIGHT.PRON.DECL.VAR);
else
return INFLECTIONS_PACKAGE."="(LEFT, RIGHT);
end if;
end EQU;
function MEANING (PR : PARSE_RECORD) return MEANING_TYPE is
begin
return DEPR(PR).MEAN;
end MEANING;
begin
-- Need to remove duplicates in ARRAY_STEMS
-- This sort is very sloppy
-- One problem is that it can mix up some of the order of PREFIX, XXX, LOC
-- I ought to do this for every set of results from different approaches
-- not just in one fell swoop at the end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
INNER_LOOP:
for I in SL'FIRST..SL_LAST-1 loop
-- Maybe < = on PR.STEM - will have to make up "<" -- Actually STEM and PART -- and check that later in print
if SL(I+1).D_K > SL(I).D_K or else -- Let DICT.LOC list first
(SL(I+1).D_K = SL(I).D_K and then
SL(I+1).MNPC < SL(I).MNPC) or else
(SL(I+1).D_K = SL(I).D_K and then
SL(I+1).MNPC = SL(I).MNPC and then
SL(I+1).IR.QUAL < SL(I).IR.QUAL) or else
(SL(I+1).D_K = SL(I).D_K and then
SL(I+1).MNPC = SL(I).MNPC and then
EQU(SL(I+1).IR.QUAL, SL(I).IR.QUAL) and then
MEANING(SL(I+1)) < MEANING(SL(I))) or else -- | is > letter
(SL(I+1).D_K = SL(I).D_K and then
SL(I+1).MNPC = SL(I).MNPC and then
EQU(SL(I+1).IR.QUAL, SL(I).IR.QUAL) and then
MEANING(SL(I+1)) = MEANING(SL(I)) and then
SL(I+1).IR.ENDING.SIZE < SL(I).IR.ENDING.SIZE) or else
(SL(I+1).D_K = SL(I).D_K and then
SL(I+1).MNPC = SL(I).MNPC and then
EQU(SL(I+1).IR.QUAL, SL(I).IR.QUAL) and then
MEANING(SL(I+1)) = MEANING(SL(I)) and then
SL(I+1).IR.ENDING.SIZE = SL(I).IR.ENDING.SIZE and then
INFLECTIONS_PACKAGE."<"(SL(I+1).IR.QUAL, SL(I).IR.QUAL))
then
SM := SL(I);
SL(I) := SL(I+1);
SL(I+1) := SM;
HITS := HITS + 1;
end if;
end loop INNER_LOOP;
end SWITCH;
--------------------------------------------------
exit when HITS = 0;
end loop HIT_LOOP;
-- Fix up the Archaic/Medieval
if WORDS_MODE(TRIM_OUTPUT) then
-- Remove those inflections if MDEV and there is other valid
-- TEXT_IO.PUT_LINE("SCANNING FOR TRIM SL'FIRST = " & INTEGER'IMAGE(SL'FIRST) & " SL'LAST = " & INTEGER'IMAGE(SL'LAST) );
-- for I in SL'FIRST..SL_LAST loop
-- PARSE_RECORD_IO.PUT(SL(I)); TEXT_IO.NEW_LINE;
-- end loop;
-- Check to see if we can afford to TRIM, if there will be something left over
for I in SL'FIRST..SL_LAST loop
--TEXT_IO.PUT_LINE("SCANNING FOR TRIM I = " & INTEGER'IMAGE(I) & " INFL AGE = " & AGE_TYPE'IMAGE(SL(I).IR.AGE));
if SL(I).D_K in GENERAL..LOCAL then
DICT_IO.SET_INDEX(DICT_FILE(SL(I).D_K), SL(I).MNPC);
--TEXT_IO.PUT(INTEGER'IMAGE(INTEGER(SL(I).MNPC)));
DICT_IO.READ(DICT_FILE(SL(I).D_K), DE);
--DICTIONARY_ENTRY_IO.PUT(DE); TEXT_IO.NEW_LINE;
if ((SL(I).IR.AGE = X) or else (SL(I).IR.AGE > A)) and
((DE.TRAN.AGE = X) or else (DE.TRAN.AGE > A)) then
NOT_ONLY_ARCHAIC := TRUE;
end if;
if ((SL(I).IR.AGE = X) or else (SL(I).IR.AGE < F)) and -- Or E????
((DE.TRAN.AGE = X) or else (DE.TRAN.AGE < F)) then -- Or E????
NOT_ONLY_MEDIEVAL := TRUE;
end if;
if ((SL(I).IR.FREQ = X) or else (SL(I).IR.FREQ < C)) and -- A/X < C -- C for inflections is uncommon !!!!
((DE.TRAN.FREQ = X) or else (DE.TRAN.FREQ < D)) then -- -- E for DICTLINE is uncommon !!!!
NOT_ONLY_UNCOMMON := TRUE;
end if;
-- TEXT_IO.PUT_LINE("NOT_ONLY_ARCHAIC = " & BOOLEAN'IMAGE(NOT_ONLY_ARCHAIC));
-- TEXT_IO.PUT_LINE("NOT_ONLY_MEDIEVAL = " & BOOLEAN'IMAGE(NOT_ONLY_MEDIEVAL));
-- TEXT_IO.PUT_LINE("NOT_ONLY_UNCOMMON = " & BOOLEAN'IMAGE(NOT_ONLY_UNCOMMON));
-- if ((SL(I).IR.QUAL.POFS = N) and then (SL(I).IR.QUAL.N.CS /= VOC)) or
-- ((SL(I).IR.QUAL.POFS = ADJ) and then (SL(I).IR.QUAL.ADJ.CS /= VOC)) or
-- ((SL(I).IR.QUAL.POFS = VPAR) and then (SL(I).IR.QUAL.VPAR.CS /= VOC)) then
-- NOT_ONLY_VOCATIVE := TRUE;
-- end if;
-- if (SL(I).IR.QUAL.POFS = N) and then (SL(I).IR.QUAL.N.CS /= LOC) then
-- NOT_ONLY_LOCATIVE := TRUE;
-- end if;
-- if (SL(I).IR.QUAL.POFS = ADJ) and then (SL(I).IR.QUAL.ADJ.CS /= VOC) then
-- NOT_ONLY_VOCATIVE := TRUE;
-- end if;
-- if (SL(I).IR.QUAL.POFS = ADJ) and then (SL(I).IR.QUAL.ADJ.CS /= LOC) then
-- NOT_ONLY_LOCATIVE := TRUE;
-- end if;
-- if (SL(I).IR.QUAL.POFS = VPAR) and then (SL(I).IR.QUAL.VPAR.CS /= VOC) then
-- NOT_ONLY_VOCATIVE := TRUE;
-- end if;
-- if (SL(I).IR.QUAL.POFS = VPAR) and then (SL(I).IR.QUAL.VPAR.CS /= LOC) then
-- NOT_ONLY_LOCATIVE := TRUE;
-- end if;
-- TEXT_IO.PUT_LINE("NOT_ONLY_VOCATIVE = " & BOOLEAN'IMAGE(NOT_ONLY_VOCATIVE));
-- TEXT_IO.PUT_LINE("NOT_ONLY_LOCATIVE = " & BOOLEAN'IMAGE(NOT_ONLY_LOCATIVE));
if SL(I).IR.QUAL.POFS = N and then
SL(I).IR.QUAL.N.DECL = (9, 8) then
HAS_NOUN_ABBREVIATION := TRUE;
--TEXT_IO.PUT_LINE("Has noun abbreviation I = " & INTEGER'IMAGE(I));
-- elsif SL(I).IR.QUAL.POFS = ADJ and then
-- SL(I).IR.QUAL.ADJ.DECL = (9, 8) then
-- HAS_ADJECTIVE_ABBREVIATION := TRUE;
-- elsif SL(I).IR.QUAL.POFS = V and then
-- SL(I).IR.QUAL.V.CON = (9, 8) then
-- HAS_VERB_ABBREVIATION := TRUE;
end if;
end if;
end loop;
-- We order and trim within a subset SL, but have to correct the big set PA also
-- Kill not ALLOWED first, then check the remaining from the top
-- I am assuming there is no trimming of FIXES for AGE/...
I := SL_LAST;
while I >= SL'FIRST loop
if (not ALLOWED_STEM(SL(I)) or -- Remove not ALLOWED_STEM & null
(PA(I) = NULL_PARSE_RECORD)) then
--TEXT_IO.PUT_LINE("Not ALLOWED SL_LAST = " & INTEGER'IMAGE(SL_LAST) & " J = " & INTEGER'IMAGE(I));
SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
SL_LAST := SL_LAST - 1;
TRIMMED := TRUE;
--TEXT_IO.PUT_LINE("Not ALLOWED end SL_LAST = " & INTEGER'IMAGE(SL_LAST) & " J = " & INTEGER'IMAGE(I));
end if;
I := I - 1;
end loop;
I := SL_LAST;
while I >= SL'FIRST loop
--TEXT_IO.PUT_LINE("TRIMMING FOR TRIM I = " & INTEGER'IMAGE(I));
if (NOT_ONLY_ARCHAIC and WORDS_MDEV(OMIT_ARCHAIC)) and then
SL(I).IR.AGE = A then
SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
SL_LAST := SL_LAST - 1;
--TEXT_IO.PUT_LINE("Archaic SL_LAST = " & INTEGER'IMAGE(SL_LAST) & " I = " & INTEGER'IMAGE(I));
TRIMMED := TRUE;
elsif (NOT_ONLY_MEDIEVAL and WORDS_MDEV(OMIT_MEDIEVAL)) and then
SL(I).IR.AGE >= F then
SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
SL_LAST := SL_LAST - 1;
--TEXT_IO.PUT_LINE("Medieval SL_LAST = " & INTEGER'IMAGE(SL_LAST) & " I = " & INTEGER'IMAGE(I));
TRIMMED := TRUE;
end if;
I := I - 1;
end loop;
I := SL_LAST;
while I >= SL'FIRST loop
if (NOT_ONLY_UNCOMMON and WORDS_MDEV(OMIT_UNCOMMON)) and then
SL(I).IR.FREQ >= C then -- Remember A < C
SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
SL_LAST := SL_LAST - 1;
--TEXT_IO.PUT_LINE("Uncommon SL_LAST = " & INTEGER'IMAGE(SL_LAST) & " I = " & INTEGER'IMAGE(I));
TRIMMED := TRUE;
end if;
I := I - 1;
end loop;
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----Big problem. This area has been generaing exceptions.
----At least one difficulty is that suffixes change POFS.
----So one has a N inflection (SL) but a V DE
----When the program checks for VOC, it wants a N
---- and then asks about KIND (P, N, T,...)
---- But the DE (v) does not have those
---- The solution would be to fix ADD SUFFIX to do somethnig about passing the ADDON KIND
---- I do not want to face that now
---- It is likely that all this VOC/LOC is worthless anyway. Maybe lower FREQ in INFLECTS
----
---- A further complication is the GANT and AO give different results (AO no exception)
---- That is probably because the program is in error and the result threrfore unspecified
----
----
--
-- I := SL_LAST;
--TEXT_IO.PUT_LINE("Checking VOC/LOC SL_LAST = " & INTEGER'IMAGE(SL_LAST));
-- while I >= SL'FIRST loop
-- -- Check for Vocative being person/name and Locative a place/area
----TEXT_IO.PUT_LINE("Looping down on I I = " & INTEGER'IMAGE(I));
-- if (SL(I).IR.QUAL.POFS = N) then
--TEXT_IO.PUT_LINE("N found I = " & INTEGER'IMAGE(I));
--PARSE_RECORD_IO.PUT(SL(I)); TEXT_IO.NEW_LINE;
-- if NOT_ONLY_VOCATIVE and then
-- (SL(I).IR.QUAL.N.CS = VOC) and then
-- ((DEPR(SL(I)).PART.N.KIND /= N) and
-- (DEPR(SL(I)).PART.N.KIND /= P)) then
----TEXT_IO.PUT_LINE("N VOC not a P or N I = " & INTEGER'IMAGE(I));
-- SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
-- SL_LAST := SL_LAST - 1;
-- TRIMMED := TRUE;
-- elsif NOT_ONLY_LOCATIVE and then
-- (SL(I).IR.QUAL.N.CS = LOC) and then
-- ((DEPR(SL(I)).PART.N.KIND /= L) and
-- (DEPR(SL(I)).PART.N.KIND /= W)) then
----TEXT_IO.PUT_LINE("N LOC not a W or L ");
-- SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
-- SL_LAST := SL_LAST - 1;
-- TRIMMED := TRUE;
-- end if;
-- end if;
-- I := I - 1;
-- end loop;
----TEXT_IO.PUT_LINE("Checked VOC/LOC");
--
--
-- -- Cutting viciously here
-- I := SL_LAST;
-- while I >= SL'FIRST loop
-- if (SL(I).IR.QUAL.POFS = ADJ) then
-- if NOT_ONLY_VOCATIVE and then
-- (SL(I).IR.QUAL.ADJ.CS = VOC) then
-- SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
-- SL_LAST := SL_LAST - 1;
-- TRIMMED := TRUE;
-- elsif NOT_ONLY_LOCATIVE and then
-- (SL(I).IR.QUAL.ADJ.CS = LOC) then
-- SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
-- SL_LAST := SL_LAST - 1;
-- TRIMMED := TRUE;
-- end if;
-- end if;
-- I := I - 1;
-- end loop;
--
--
--
-- I := SL_LAST;
-- while I >= SL'FIRST loop
-- if (SL(I).IR.QUAL.POFS = VPAR) then
-- if NOT_ONLY_VOCATIVE and then
-- (SL(I).IR.QUAL.VPAR.CS = VOC) then
-- SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
-- SL_LAST := SL_LAST - 1;
-- TRIMMED := TRUE;
-- elsif NOT_ONLY_LOCATIVE and then
-- (SL(I).IR.QUAL.VPAR.CS = LOC) then
-- SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
-- SL_LAST := SL_LAST - 1;
-- TRIMMED := TRUE;
-- end if;
-- end if;
-- I := I - 1;
-- end loop;
--
-- This is really working much too hard!
-- just to kill Roman numeral for three single letters
-- Also strange in that code depends on dictionary knowledge
I := SL_LAST;
while I >= SL'FIRST loop
if HAS_NOUN_ABBREVIATION and then
(ALL_CAPS and FOLLOWED_BY_PERIOD) then
if (SL(I).IR.QUAL.POFS /= N) or
( (SL(I).IR.QUAL /= (N, ((9, 8), X, X, M))) and
( TRIM(SL(I).STEM)'LENGTH = 1 and then
(SL(I).STEM(1) = 'A' or
SL(I).STEM(1) = 'C' or
SL(I).STEM(1) = 'D' or
--SL(I).STEM(1) = 'K' or -- No problem here
SL(I).STEM(1) = 'L' or
SL(I).STEM(1) = 'M' -- or
--SL(I).STEM(1) = 'N' or
--SL(I).STEM(1) = 'P' or
--SL(I).STEM(1) = 'Q' or
--SL(I).STEM(1) = 'T'
) ) ) then
SL(I..SL_LAST-1) := SL(I+1..SL_LAST);
SL_LAST := SL_LAST - 1;
TRIMMED := TRUE;
end if;
end if;
I := I - 1;
end loop;
end if; -- On TRIM
DIFF_J := SL_LAST_INITIAL - SL_LAST;
end ORDER_PARSE_ARRAY;
begin -- LIST_SWEEP
-- DICT_IO.READ(DICT_FILE(GENERAL), DE, 31585);
-- DICTIONARY_ENTRY_IO.PUT(DE); TEXT_IO.PUT_LINE("#########");
if PA'LENGTH = 0 then
return;
end if;
-- TEXT_IO.PUT_LINE("PA on entering LIST_SWEEP PA_LAST = " & INTEGER'IMAGE(PA_LAST));
-- for I in 1..PA_LAST loop
-- PARSE_RECORD_IO.PUT(PA(I)); TEXT_IO.NEW_LINE;
-- end loop;
RESET_PRONOUN_KIND:
declare
DE : DICTIONARY_ENTRY;
begin
for I in 1..PA_LAST loop
if PA(I).D_K = GENERAL then
DICT_IO.SET_INDEX(DICT_FILE(PA(I).D_K), PA(I).MNPC);
DICT_IO.READ(DICT_FILE(PA(I).D_K), DE);
if DE.PART.POFS = PRON and then
DE.PART.PRON.DECL.WHICH =1 then
PA(I).IR.QUAL.PRON.DECL.VAR := PRONOUN_KIND_TYPE'POS(DE.PART.PRON.KIND);
--elsif DE.PART.POFS = PACK and then
-- DE.PART.PACK.DECL.WHICH =1 then
-- PA(I).IR.QUAL.PACK.DECL.VAR := PRONOUN_KIND_TYPE'POS(DE.KIND.PRON_KIND);
end if;
end if;
end loop;
end RESET_PRONOUN_KIND;
---------------------------------------------------
-- NEED TO REMOVE DISALLOWED BEFORE DOING ANYTHING - BUT WITHOUT REORDERING
-- The problem I seem to have to face first, if not the first problem,
-- is the situation in which there are several sets of identical IRs with different MNPC
-- These may be variants with some other stem (e.g., K=3) not affecting the (K=1) word
-- Or they might be identical forms with different meanings (| additional meanings)
-- I need to group such common inflections - and pass this on somehow
-- TEXT_IO.PUT_LINE("PA before SWEEPING in LIST_SWEEP PA_LAST = " & INTEGER'IMAGE(PA_LAST));
-- for I in 1..PA_LAST loop
-- PARSE_RECORD_IO.PUT(PA(I)); TEXT_IO.NEW_LINE;
-- end loop;
SWEEPING:
-- To remove disallowed stems/inflections and resulting dangling fixes
declare
FIX_ON : BOOLEAN := FALSE;
PW_ON : BOOLEAN := FALSE;
P_FIRST : INTEGER := 1;
P_LAST : INTEGER := 0;
subtype XONS is PART_OF_SPEECH_TYPE range TACKON..SUFFIX;
begin
--
-- TEXT_IO.NEW_LINE;
-- TEXT_IO.PUT_LINE("SWEEPING ======================================");
-- TEXT_IO.NEW_LINE;
--TEXT_IO.PUT("{");
J := PA_LAST;
while J >= 1 loop -- Sweep backwards over PA
-- if (not ALLOWED_STEM(PA(J)) or -- Remove not ALLOWED_STEM & null
-- (PA(J) = NULL_PARSE_RECORD)) then -- and close ranks
-- TEXT_IO.PUT_LINE("Removing dis ALLOWED STEM J = " & INTEGER'IMAGE(J));
-- PA(J..PA_LAST-1) := PA(J+1..PA_LAST); -- null if J = PA_LAST
-- PA_LAST := PA_LAST - 1;
-- P_LAST := P_LAST - 1;
-- TRIMMED := TRUE;
if ((PA(J).D_K in ADDONS..YYY) or (PA(J).IR.QUAL.POFS in XONS)) and then
(PW_ON) then -- first FIX/TRICK after regular
FIX_ON := TRUE;
PW_ON := FALSE;
P_FIRST := J + 1;
--P_LAST := J + 1;
--TEXT_IO.PUT_LINE("SWEEP FIX/TRICK J = " & INTEGER'IMAGE(J) & " P_FIRST = " & INTEGER'IMAGE(P_FIRST) &
--" P_LAST = " & INTEGER'IMAGE(P_LAST));
JJ := J;
while PA(JJ+1).IR.QUAL.POFS = PA(JJ).IR.QUAL.POFS loop
P_LAST := JJ + 1;
end loop;
----Order internal to this set of inflections
-- TEXT_IO.PUT_LINE("SWEEP INTERNAL J = " & INTEGER'IMAGE(J) & " P_FIRST = " & INTEGER'IMAGE(P_FIRST) &
-- " P_LAST = " & INTEGER'IMAGE(P_LAST) & " DIFF_J = " & INTEGER'IMAGE(DIFF_J) & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
ORDER_PARSE_ARRAY(PA(P_FIRST..P_LAST), DIFF_J);
--PA(J..PA_LAST-1) := PA(J+1..PA_LAST);
PA(P_LAST-DIFF_J+1..PA_LAST-DIFF_J) := PA(P_LAST+1..PA_LAST);
PA_LAST := PA_LAST - DIFF_J;
-- TEXT_IO.PUT_LINE("SWEEP INTERNAL end J = " & INTEGER'IMAGE(J) & " P_FIRST = " & INTEGER'IMAGE(P_FIRST) &
-- " P_LAST = " & INTEGER'IMAGE(P_LAST) & " DIFF_J = " & INTEGER'IMAGE(DIFF_J) & " PA_LAST = " & INTEGER'IMAGE(PA_LAST));
P_FIRST := 1;
P_LAST := 0;
elsif ((PA(J).D_K in ADDONS..YYY) or (PA(J).IR.QUAL.POFS in XONS)) and then
(FIX_ON) then -- another FIX
--TEXT_IO.PUT_LINE("SWEEP Another FIX/TRICK J = " & INTEGER'IMAGE(J));
null;
elsif ((PA(J).D_K in ADDONS..YYY) or
(PA(J).IR.QUAL.POFS = X)) and then -- Kills TRICKS stuff
(not PW_ON) then
--TEXT_IO.PUT_LINE("Killing Tricks stuff J = " & INTEGER'IMAGE(J));
PA(P_LAST-DIFF_J+1..PA_LAST-DIFF_J) := PA(P_LAST+1..PA_LAST);
PA_LAST := PA_LAST - DIFF_J;
--PA_LAST := PA_LAST - 1;
P_LAST := P_LAST - 1;
else
--TEXT_IO.PUT_LINE("SWEEP else J = " & INTEGER'IMAGE(J) & " P_LAST = " & INTEGER'IMAGE(P_LAST));
--for I in 1..PA_LAST loop
--PARSE_RECORD_IO.PUT(PA(I)); TEXT_IO.NEW_LINE;
--end loop;
PW_ON := TRUE;
FIX_ON := FALSE;
if P_LAST <= 0 then
P_LAST := J;
end if;
if J = 1 then
--TEXT_IO.PUT_LINE("SWEEP J = 1 P_LAST = " & INTEGER'IMAGE(P_LAST));
ORDER_PARSE_ARRAY(PA(1..P_LAST), DIFF_J);
PA(P_LAST-DIFF_J+1..PA_LAST-DIFF_J) := PA(P_LAST+1..PA_LAST);
PA_LAST := PA_LAST - DIFF_J;
--TEXT_IO.PUT_LINE("SWEEP J = 1 end PA_LAST = " & INTEGER'IMAGE(PA_LAST) & " DIFF_J = " & INTEGER'IMAGE(DIFF_J));
end if;
end if; -- check PART
J := J - 1;
end loop; -- loop sweep over PA
end SWEEPING;
-- TEXT_IO.PUT_LINE("PA after SWEEPING in LIST_STEMS - before COMPRESS_LOOP PA_LAST = "
-- & INTEGER'IMAGE(PA_LAST));
-- for I in 1..PA_LAST loop
-- PARSE_RECORD_IO.PUT(PA(I)); TEXT_IO.NEW_LINE;
-- end loop;
OPR := PA(1);
-- Last chance to weed out duplicates
J := 2;
COMPRESS_LOOP:
loop
exit when J > PA_LAST;
PR := PA(J);
if PR /= OPR then
SUPRESS_KEY_CHECK:
declare
function "<=" (A, B : PARSE_RECORD) return BOOLEAN is
begin -- !!!!!!!!!!!!!!!!!!!!!!!!!!
if A.IR.QUAL = B.IR.QUAL and
A.MNPC = B.MNPC then
return TRUE;
else
return FALSE;
end if;
end "<=";
function "<" (A, B : PARSE_RECORD) return BOOLEAN is
begin -- !!!!!!!!!!!!!!!!!!!!!!!!!!
if A.IR.QUAL = B.IR.QUAL and
A.MNPC /= B.MNPC then
return TRUE;
else
return FALSE;
end if;
end "<";
begin
if ((PR.D_K /= XXX) and (PR.D_K /= YYY) and (PR.D_K /= PPP)) then
if PR <= OPR then -- Get rid of duplicates, if ORDER is OK
PA(J.. PA_LAST-1) := PA(J+1..PA_LAST); -- Shift PA down 1
PA_LAST := PA_LAST - 1; -- because found key duplicate
end if;
else
J := J + 1;
end if;
end SUPRESS_KEY_CHECK;
else
J := J + 1;
end if;
OPR := PR;
end loop COMPRESS_LOOP;
for I in 1..PA_LAST loop
-- Set to 0 the VAR for N -- DON'T
-- if PA(I).IR.QUAL.POFS = N then
-- PA(I).IR.QUAL.N.DECL.VAR := 0;
-- end if;
-- Destroy the artificial VAR for PRON 1 X
if PA(I).IR.QUAL.POFS = PRON and then
PA(I).IR.QUAL.PRON.DECL.WHICH =1 then
PA(I).IR.QUAL.PRON.DECL.VAR := 0;
end if;
if PA(I).IR.QUAL.POFS = V then
if PA(I).IR.QUAL.V.CON = (3, 4) then
-- Fix V 3 4 to be 4th conjugation
PA(I).IR.QUAL.V.CON := (4, 1);
-- else
-- -- Set to 0 other VAR for V
-- PA(I).IR.QUAL.V.CON.VAR := 0;
end if;
end if;
end loop;
-- TEXT_IO.PUT_LINE("PA after COMPRESS almost leaving LIST_STEMS PA_LAST = " & INTEGER'IMAGE(PA_LAST));
-- for I in 1..PA_LAST loop
-- PARSE_RECORD_IO.PUT(PA(I)); TEXT_IO.NEW_LINE;
-- end loop;
--TEXT_IO.PUT("}");
end LIST_SWEEP;