1 | #!/usr/bin/perl |
---|
2 | |
---|
3 | #package: UAM Text Tools |
---|
4 | #component: dgc (dg compiler) |
---|
5 | #version: 1.0 |
---|
6 | #author: Tomasz Obrebski |
---|
7 | |
---|
8 | # wymaga niejawnie programu canonize!!!! |
---|
9 | use lib "/usr/local/lib/utt"; |
---|
10 | use lib "$ENV{'HOME'}/.local/lib/utt"; |
---|
11 | |
---|
12 | use strict; |
---|
13 | use Getopt::Long; |
---|
14 | use Data::Dumper; |
---|
15 | use attr; |
---|
16 | use File::HomeDir; |
---|
17 | |
---|
18 | my $systemconfigfile='/usr/local/etc/utt/dgc.conf'; |
---|
19 | my $userconfigfile=home()."/.utt/dgc.conf"; |
---|
20 | |
---|
21 | Getopt::Long::Configure('no_ignore_case_always'); |
---|
22 | |
---|
23 | my $help=0; |
---|
24 | my $catfile=0; |
---|
25 | my $dicfile=0; |
---|
26 | my $gramfile=0; |
---|
27 | my $outputfile=0; |
---|
28 | |
---|
29 | #read configuration files########################### |
---|
30 | my $file; |
---|
31 | foreach $file ($systemconfigfile, $userconfigfile){ |
---|
32 | if(open(CONFIG, $file)){ |
---|
33 | while (<CONFIG>) { |
---|
34 | chomp; |
---|
35 | s/#.*//; |
---|
36 | s/^\s+//; |
---|
37 | s/\s+$//; |
---|
38 | next unless length; |
---|
39 | my ($name, $value) = split(/\s*=\s*/, $_, 2); |
---|
40 | if(($name eq "categories")or($name eq "c")){ |
---|
41 | $catfile=$value; |
---|
42 | } |
---|
43 | elsif(($name eq "dictionary")or($name eq "d")){ |
---|
44 | $dicfile=$value; |
---|
45 | } |
---|
46 | elsif(($name eq "grammar")or($name eq "g")){ |
---|
47 | $gramfile=$value; |
---|
48 | } |
---|
49 | elsif(($name eq "outputfile")or($name eq "o")){ |
---|
50 | $outputfile=$value; |
---|
51 | } |
---|
52 | elsif(($name eq "help")or($name eq "h")){ |
---|
53 | $help=1; |
---|
54 | } |
---|
55 | |
---|
56 | } |
---|
57 | close CONFIG; |
---|
58 | } |
---|
59 | } |
---|
60 | ######################################################### |
---|
61 | |
---|
62 | GetOptions("help|h" => \$help, |
---|
63 | "categories|c=s" => \$catfile, |
---|
64 | "dictionary|d=s" => \$dicfile, |
---|
65 | "grammar|g=s" => \$gramfile, |
---|
66 | "outputfile|o=s" => \$outputfile); |
---|
67 | |
---|
68 | my $homedir = $ENV{'HOME'}; |
---|
69 | $catfile =~ s/~/$homedir/; |
---|
70 | $dicfile =~ s/~/$homedir/; |
---|
71 | $gramfile =~ s/~/$homedir/; |
---|
72 | $outputfile =~ s/~/$homedir/; |
---|
73 | |
---|
74 | |
---|
75 | if($help) |
---|
76 | { |
---|
77 | print <<'END' |
---|
78 | Usage: dgc [OPTIONS] |
---|
79 | |
---|
80 | Options: |
---|
81 | --categories -c filename List of syntactic categories. |
---|
82 | --dictionary -d filename Dictionary. |
---|
83 | --grammar -g filename List of grammar rules. |
---|
84 | --outputfile -o filename Output file name. |
---|
85 | --help -h Help. |
---|
86 | END |
---|
87 | ; |
---|
88 | exit 0; |
---|
89 | } |
---|
90 | |
---|
91 | die("At least one of --cats and --dic must be given.\n") if !$catfile && !$dicfile; |
---|
92 | |
---|
93 | my $ncat=0; |
---|
94 | my $nrole=0; |
---|
95 | my $nsgl=0; |
---|
96 | my $nleft=0; |
---|
97 | my $nright=0; |
---|
98 | my $nreq=0; |
---|
99 | my $nlink=0; |
---|
100 | my $nflag=0; |
---|
101 | |
---|
102 | my %cats; |
---|
103 | my %roles; |
---|
104 | my %agr; |
---|
105 | my %gov; |
---|
106 | |
---|
107 | if(!$outputfile) { |
---|
108 | *OUTPUT = *STDOUT; |
---|
109 | } |
---|
110 | elsif($outputfile eq "-") { |
---|
111 | *OUTPUT = *STDOUT; |
---|
112 | } |
---|
113 | else { |
---|
114 | open(OUTPUT, ">$outputfile") or die("Can't open output file: $outputfile!"); |
---|
115 | } |
---|
116 | |
---|
117 | |
---|
118 | loadcats($catfile) if $catfile; |
---|
119 | extractcats($dicfile) if $dicfile; |
---|
120 | |
---|
121 | |
---|
122 | my $cats_re = qr/(?:$attr::cat_re\s*(?:,\s*$attr::cat_re)*)/; |
---|
123 | |
---|
124 | # class parse_class: |
---|
125 | # /$attr::cat_re/g; |
---|
126 | |
---|
127 | |
---|
128 | if(!$gramfile) { |
---|
129 | *INPUT = *STDIN; |
---|
130 | } |
---|
131 | elsif($gramfile eq "-"){ |
---|
132 | *INPUT = *STDIN; |
---|
133 | } |
---|
134 | else { |
---|
135 | open(INPUT, $gramfile) or die("Unable to open: $gramfile!"); |
---|
136 | } |
---|
137 | |
---|
138 | while(<INPUT>) |
---|
139 | { |
---|
140 | s/#.*//; |
---|
141 | s/^\s+//; |
---|
142 | s/\s+$//; |
---|
143 | if(/^AGR\s+(\S+)\s+(\S+)$/) |
---|
144 | { |
---|
145 | push @{$agr{$1}}, $2; |
---|
146 | } |
---|
147 | elsif(/^GOV\s+(\S+)\s+(\S+)$/) |
---|
148 | { |
---|
149 | push @{$gov{$1}}, attr::parse($2); |
---|
150 | } |
---|
151 | elsif(/^ROLE\s+\S+$/) |
---|
152 | { |
---|
153 | $roles{$_}=1; |
---|
154 | print OUTPUT "$_\n"; |
---|
155 | } |
---|
156 | elsif(/^SGL\s+\S+$/) |
---|
157 | { |
---|
158 | ++$nsgl; |
---|
159 | print OUTPUT "$_\n"; |
---|
160 | } |
---|
161 | elsif(/^REQ\s+(\S+)\s+(\S+)$/) |
---|
162 | { |
---|
163 | print OUTPUT "#$_\n"; |
---|
164 | my $cat = attr::parse $1; |
---|
165 | for my $atomcat (keys %cats) |
---|
166 | { |
---|
167 | if(attr::match @$cat, @{$cats{$atomcat}}) |
---|
168 | { |
---|
169 | print OUTPUT "REQ ".$atomcat." $2\n"; |
---|
170 | ++$nreq; |
---|
171 | } |
---|
172 | } |
---|
173 | } |
---|
174 | elsif(/^LEFT\s+\S+$/) |
---|
175 | { |
---|
176 | ++$nleft; |
---|
177 | print OUTPUT "$_\n"; |
---|
178 | } |
---|
179 | elsif(/^RIGHT\s+\S+$/) |
---|
180 | { |
---|
181 | ++$nright; |
---|
182 | print OUTPUT "$_\n"; |
---|
183 | } |
---|
184 | elsif(my ($hs,$ds,$r) = /^LINK\s+($cats_re)\s+($cats_re)\s+(\S+)$/) |
---|
185 | { |
---|
186 | print OUTPUT "#$_\n"; |
---|
187 | for my $h ($hs =~ /$attr::cat_re/g) |
---|
188 | { |
---|
189 | for my $d ($ds =~ /$attr::cat_re/g) |
---|
190 | { |
---|
191 | addlinks($h,$d,$r); |
---|
192 | } |
---|
193 | } |
---|
194 | } |
---|
195 | elsif(/^FLAG\s+\S+$/) |
---|
196 | { |
---|
197 | ++$nflag; |
---|
198 | print OUTPUT "$_\n" |
---|
199 | } |
---|
200 | elsif(/^$/) { |
---|
201 | # pomijamy puste linie oraz komentarze |
---|
202 | } |
---|
203 | else |
---|
204 | { |
---|
205 | print STDERR "Illegal format: $_\n"; |
---|
206 | } |
---|
207 | } |
---|
208 | |
---|
209 | |
---|
210 | sub addlinks |
---|
211 | { |
---|
212 | my ($h,$d,$r) = @_; |
---|
213 | |
---|
214 | for my $a (@{$agr{$r}}) { print OUTPUT "#AGR $r $a\n"; } |
---|
215 | for my $c (@{$gov{$r}}) { print OUTPUT "#GOV $r ".attr::unparse(@$c)."\n"; } |
---|
216 | my $head = attr::parse $h; |
---|
217 | my $dep = attr::parse $d; |
---|
218 | |
---|
219 | for my $atomhead (keys %cats) |
---|
220 | { |
---|
221 | if(attr::match @$head, @{$cats{$atomhead}}) |
---|
222 | { |
---|
223 | DEP: |
---|
224 | for my $atomdep (keys %cats) |
---|
225 | { |
---|
226 | next DEP if ! attr::match @$dep, @{$cats{$atomdep}}; |
---|
227 | |
---|
228 | for my $a (@{$agr{$r}}) |
---|
229 | { |
---|
230 | next DEP if ! attr::agree(@{$cats{$atomhead}},@{$cats{$atomdep}},$a); |
---|
231 | } |
---|
232 | |
---|
233 | for my $c (@{$gov{$r}}) |
---|
234 | { |
---|
235 | next DEP if ! attr::match(@$c,@{$cats{$atomdep}}); |
---|
236 | } |
---|
237 | |
---|
238 | print OUTPUT "LINK "; |
---|
239 | print OUTPUT $atomhead." "; |
---|
240 | print OUTPUT $atomdep." $r\n"; |
---|
241 | ++$nlink; |
---|
242 | |
---|
243 | } |
---|
244 | } |
---|
245 | } |
---|
246 | } |
---|
247 | |
---|
248 | |
---|
249 | printf STDERR "%6d CAT statements\n", 0+keys(%cats); |
---|
250 | printf STDERR "%6d ROLE statements\n", 0+keys(%roles); |
---|
251 | printf STDERR "%6d SGL statements\n", $nsgl; |
---|
252 | printf STDERR "%6d REQ statements\n", $nreq; |
---|
253 | printf STDERR "%6d LEFT statements\n", $nleft; |
---|
254 | printf STDERR "%6d RIGHT statements\n", $nright; |
---|
255 | printf STDERR "%6d LINK statements\n", $nlink; |
---|
256 | printf STDERR "%6d FLAG statements\n", $nflag; |
---|
257 | |
---|
258 | |
---|
259 | sub extractcats |
---|
260 | { |
---|
261 | my $file = shift; |
---|
262 | open DICFILE, "canonize $file |"; |
---|
263 | while(<DICFILE>) |
---|
264 | { |
---|
265 | while(/,([^[:space:];]+)/g) |
---|
266 | { |
---|
267 | my $cat=$1; |
---|
268 | next if !$cat || exists $cats{$cat}; |
---|
269 | $ncat++; |
---|
270 | print OUTPUT "CAT $1\n"; |
---|
271 | $cats{$cat}=attr::parse($cat); |
---|
272 | } |
---|
273 | } |
---|
274 | close DICFILE; |
---|
275 | } |
---|
276 | |
---|
277 | |
---|
278 | sub loadcats |
---|
279 | { |
---|
280 | my $file = shift; |
---|
281 | open CATFILE, "canonize $file |"; |
---|
282 | while(<CATFILE>) |
---|
283 | { |
---|
284 | tr/ \t\n//d; |
---|
285 | next if !$_ || exists $cats{$_}; |
---|
286 | print OUTPUT "CAT $_\n"; |
---|
287 | ++$ncat; |
---|
288 | $cats{$_}=attr::parse($_); |
---|
289 | } |
---|
290 | close CATFILE; |
---|
291 | } |
---|
292 | |
---|