-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathSentence.pm
172 lines (145 loc) · 4.87 KB
/
Sentence.pm
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
package Sentence;
use strict;
use PlainSentence;
our @ISA = ( 'PlainSentence' );
# --- konstansok
my $DEBUG = '';
# csak a match működésében más, mint a PlainSentence, ti.
# beágyazott struktúrákat is kezel, nem csak egyszintűt
# --- egyebek: a lényeg
# param: egy alkalmazandó szabály
# működ: command alapján szétosztja a kérést a megfelelő eljáráshoz
sub apply {
my $self = shift;
my $rule = shift;
if ( $rule->command eq $Rule::MATCH ) {
$self->match( $rule );
} else { # XXX egyelőre, ha nem MATCH, akkor DELETE
$self->delete( $rule );
}
}
# param: egy alkalmazandó delete-szabály
# működ: törli a szabályban megadott annotációt
sub delete {
my $self = shift;
my $rule = shift;
my $type = $rule->type;
$self->strcs->delete( $type );
}
# param: egy alkalmazandó match-szabály
# működ: karakteres regexp-kódolással, regexp-illesztéssel
# megkeresi, és strc-ben tárolja az illeszkedő szerkezeteket
sub match {
my $self = shift;
my $rule = shift;
$self->_regexp_code( $rule );
my ( $coded_sent, $poslistref ) = $self->_regexp_match( $rule );
$self->_regexp_store( $rule, $coded_sent, $poslistref );
# XXX postlistref jó esetben nem fog kelleni
}
# param: egy alkalmazandó szabály
# működ: szabály termjeinek és a mondat illeszkedő
# szerkezeteinek / tokenjeinek kódolása
sub _regexp_code {
my $self = shift;
my $rule = shift;
$rule->autocode;
#print "\n *** A bekódolt szabály:\n";
#print $rule->info . "\n";
#print "\n *** Az illeszkedések kódokkal:\n";
# bekódolok minden tokent/szerkezetet
my @arr = ( @{ $self->seq }, @{ $self->strcs->as_array } );
foreach my $w ( @arr ) {
foreach my $t ( @{ $rule->seq } ) {
if ( $w->satisfies( $t ) ) {
$w->code( $t->code ); # ennyi a kódolás
print $w->info . " - oké!\n" if $DEBUG;
last;
# XXX az első megtaláltnál kilépünk, azaz az ütközés nincs kezelve
} else {
$w->code( '-' ); # ennyi a kódolás XXX hc
print $w->info . " - nem jó.\n" if $DEBUG;
}
}
}
}
# param: egy alkalmazandó szabály
# működ: regex-készítés és match-elés
sub _regexp_match {
my $self = shift;
my $rule = shift;
my $coded_sent = '';
my @poslist = @{ $self->strcs->coverage };
print 'poslist:' .
( join ' ', map { ref $_ ? $_->info : $_ } @poslist ) . "\n" if $DEBUG;
# XXX ez azonos a Annotation::as_string -béli kóddal
if ( $self->len == $self->strcs->len ) {
# XXX ez kicsit gyagya, de helyes
# ellenőrzése annak, hogy már vannak-e struktúrák
foreach my $t ( @poslist ) {
if ( ref( $t ) eq 'Token' ) { # XXX isa?
$coded_sent .= $t->code;
} else { # ha nem Token, akkor ugye egy szó-index
$coded_sent .= ${ $self->seq }[$t]->code;
}
}
} else {
for ( my $i = 0; $i < $self->len; ++$i ) {
$coded_sent .= ${ $self->seq }[$i]->code;
push @poslist, $i; # "default" poslist: index-sorozat egyesével
}
}
my $coded_rule;
foreach my $t ( @{ $rule->seq } ) {
$coded_rule .= $t->pre . $t->code . $t->post;
}
print "\n *** A kódolt mondat:\n" . $coded_sent . "\n" if $DEBUG;
print "\n *** A kódolt szabály:\n" . $coded_rule . "\n" if $DEBUG;
# itt történik meg minden ...
$coded_sent =~ s/($coded_rule)/$self->LM . $1 . $self->RM/ge;
print "\n *** A felismert szerkezetek (kódolt alak):\n" .
$coded_sent . "\n\n" if $DEBUG;
( $coded_sent, \@poslist ); # XXX XXX XXX na ez már tényleg szörnyű
}
# param: egy alkalmazandó szabály
# _regexp_match eredményeként kijött kódolt mondat
# működ: regexp-pel kódolt mondat visszaalakítása
# és a találatok feljegyzése a mondat struktúrái (strc) közé
sub _regexp_store {
my $self = shift;
my $rule = shift;
my $coded_sent = shift;
my $poslistref = shift; # XXX
my @poslist = @{ $poslistref }; # XXX
my $i = 0;
my $beg;
my $end;
# XXX legjobb lefedés alapján kell visszaalakítani
foreach my $ch ( split //, $coded_sent ) {
if ( $ch eq $self->LM ) {
$beg = ref( $poslist[$i] ) eq 'Token'
? $poslist[$i]->position->begpos
: $poslist[$i];
--$i;
} elsif ( $ch eq $self->RM ) {
--$i;
$end = ref( $poslist[$i] ) eq 'Token'
? $poslist[$i]->position->endpos
: $poslist[$i]; # XXX totál nem értem, hogy itt miért nincs -1 a végén,
# ha egyszer a poslist-ben a _kezdetek_ vannak
my $s = Token->new;
# fej-perkoláció: elvileg mindig a szerkezet
# utolsó (mindig jó ez? XXX) szavának msd-je jön át
$s->form( ${ $self->seq }[$end]->form );
$s->lemma( ${ $self->seq }[$end]->lemma );
$s->msd->copy( ${ $self->seq }[$end]->msd );
# mindig Msd -> hibakezelés nem kell
$s->type->copy( $rule->type );
$s->position( $beg, $end );
# 2008.04.15. capit attribútumot vajh miért nem másoljuk? XXX
$self->add_strcs_elem( $s ); # mindig Token -> hibakezelés nem kell
}
++$i;
}
}
1;