| 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 | use lib "/usr/local/lib/utt"; |
|---|
| 9 | use lib "$ENV{'HOME'}/.local/lib/utt"; |
|---|
| 10 | |
|---|
| 11 | use strict; |
|---|
| 12 | use Getopt::Long; |
|---|
| 13 | use Data::Dumper; |
|---|
| 14 | use attr; |
|---|
| 15 | use File::HomeDir; |
|---|
| 16 | |
|---|
| 17 | my $systemconfigfile='/etc/utt/dgc.conf'; |
|---|
| 18 | my $userconfigfile=home()."/.utt/dgc.conf"; |
|---|
| 19 | |
|---|
| 20 | Getopt::Long::Configure('no_ignore_case_always'); |
|---|
| 21 | |
|---|
| 22 | my $help=0; |
|---|
| 23 | my $catfile=0; |
|---|
| 24 | my $dicfile=0; |
|---|
| 25 | my $gramfile=0; |
|---|
| 26 | my $outputfile=0; |
|---|
| 27 | |
|---|
| 28 | #read configuration files########################### |
|---|
| 29 | my $file; |
|---|
| 30 | foreach $file ($systemconfigfile, $userconfigfile){ |
|---|
| 31 | if(open(CONFIG, $file)){ |
|---|
| 32 | while (<CONFIG>) { |
|---|
| 33 | chomp; |
|---|
| 34 | s/#.*//; |
|---|
| 35 | s/^\s+//; |
|---|
| 36 | s/\s+$//; |
|---|
| 37 | next unless length; |
|---|
| 38 | my ($name, $value) = split(/\s*=\s*/, $_, 2); |
|---|
| 39 | if(($name eq "categories")or($name eq "c")){ |
|---|
| 40 | $catfile=$value; |
|---|
| 41 | } |
|---|
| 42 | elsif(($name eq "dictionary")or($name eq "d")){ |
|---|
| 43 | $dicfile=$value; |
|---|
| 44 | } |
|---|
| 45 | elsif(($name eq "grammar")or($name eq "g")){ |
|---|
| 46 | $gramfile=$value; |
|---|
| 47 | } |
|---|
| 48 | elsif(($name eq "outputfile")or($name eq "o")){ |
|---|
| 49 | $outputfile=$value; |
|---|
| 50 | } |
|---|
| 51 | elsif(($name eq "help")or($name eq "h")){ |
|---|
| 52 | $help=1; |
|---|
| 53 | } |
|---|
| 54 | |
|---|
| 55 | } |
|---|
| 56 | close CONFIG; |
|---|
| 57 | } |
|---|
| 58 | } |
|---|
| 59 | ######################################################### |
|---|
| 60 | |
|---|
| 61 | GetOptions("help|h" => \$help, |
|---|
| 62 | "categories|c=s" => \$catfile, |
|---|
| 63 | "dictionary|d=s" => \$dicfile, |
|---|
| 64 | "grammar|g=s" => \$gramfile, |
|---|
| 65 | "outputfile|o=s" => \$outputfile); |
|---|
| 66 | |
|---|
| 67 | my $homedir = $ENV{'HOME'}; |
|---|
| 68 | $catfile =~ s/~/$homedir/; |
|---|
| 69 | $dicfile =~ s/~/$homedir/; |
|---|
| 70 | $gramfile =~ s/~/$homedir/; |
|---|
| 71 | $outputfile =~ s/~/$homedir/; |
|---|
| 72 | |
|---|
| 73 | |
|---|
| 74 | if($help) |
|---|
| 75 | { |
|---|
| 76 | print <<'END' |
|---|
| 77 | Usage: dgc [OPTIONS] |
|---|
| 78 | |
|---|
| 79 | Options: |
|---|
| 80 | --categories -c filename List of syntactic categories. |
|---|
| 81 | --dictionary -d filename Dictionary. |
|---|
| 82 | --grammar -g filename List of grammar rules. |
|---|
| 83 | --outputfile -o filename Output file name. |
|---|
| 84 | --help -h Help. |
|---|
| 85 | END |
|---|
| 86 | ; |
|---|
| 87 | exit 0; |
|---|
| 88 | } |
|---|
| 89 | |
|---|
| 90 | die("At least one of --cats and --dic must be given.\n") if !$catfile && !$dicfile; |
|---|
| 91 | |
|---|
| 92 | my $ncat=0; |
|---|
| 93 | my $nrole=0; |
|---|
| 94 | my $nsgl=0; |
|---|
| 95 | my $nleft=0; |
|---|
| 96 | my $nright=0; |
|---|
| 97 | my $ninitr=0; |
|---|
| 98 | my $nfinr=0; |
|---|
| 99 | my $ninitf=0; |
|---|
| 100 | my $nfinf=0; |
|---|
| 101 | my $ninitc=0; |
|---|
| 102 | my $nfinc=0; |
|---|
| 103 | my $nreq=0; |
|---|
| 104 | my $nlink=0; |
|---|
| 105 | my $nflag=0; |
|---|
| 106 | my $nset=0; |
|---|
| 107 | my $npass=0; |
|---|
| 108 | my $nlong=0; |
|---|
| 109 | my $nconstr=0; |
|---|
| 110 | my $nclass=0; |
|---|
| 111 | |
|---|
| 112 | my %cats; |
|---|
| 113 | my %roles; |
|---|
| 114 | my %agr; |
|---|
| 115 | my %gov; |
|---|
| 116 | |
|---|
| 117 | if(!$outputfile) { |
|---|
| 118 | *OUTPUT = *STDOUT; |
|---|
| 119 | } |
|---|
| 120 | elsif($outputfile eq "-") { |
|---|
| 121 | *OUTPUT = *STDOUT; |
|---|
| 122 | } |
|---|
| 123 | else { |
|---|
| 124 | open(OUTPUT, ">$outputfile") or die("Can't open output file: $outputfile!"); |
|---|
| 125 | } |
|---|
| 126 | |
|---|
| 127 | |
|---|
| 128 | loadcats($catfile) if $catfile; |
|---|
| 129 | extractcats($dicfile) if $dicfile; |
|---|
| 130 | |
|---|
| 131 | |
|---|
| 132 | my $cats_re = qr/(?:$attr::cat_re\s*(?:,\s*$attr::cat_re)*)/; |
|---|
| 133 | my $class_re = qr/(?:\@\w+)/; |
|---|
| 134 | |
|---|
| 135 | my $avlist_re = $attr::avlist_re; |
|---|
| 136 | |
|---|
| 137 | my $role_re = qr/(?:[[:lower:][:digit:]_]+)/; |
|---|
| 138 | my $prop_re = qr/(?:\&[[:upper:]]+)/; |
|---|
| 139 | my $proplist_re = qr/(?:$prop_re+)/; |
|---|
| 140 | |
|---|
| 141 | # class parse_class: |
|---|
| 142 | # /$attr::cat_re/g; |
|---|
| 143 | |
|---|
| 144 | |
|---|
| 145 | if(!$gramfile) { |
|---|
| 146 | *INPUT = *STDIN; |
|---|
| 147 | } |
|---|
| 148 | elsif($gramfile eq "-"){ |
|---|
| 149 | *INPUT = *STDIN; |
|---|
| 150 | } |
|---|
| 151 | else { |
|---|
| 152 | open(INPUT, $gramfile) or die("Unable to open: $gramfile!"); |
|---|
| 153 | } |
|---|
| 154 | |
|---|
| 155 | while(<INPUT>) |
|---|
| 156 | { |
|---|
| 157 | s/#.*//; |
|---|
| 158 | s/^\s+//; |
|---|
| 159 | s/\s+$//; |
|---|
| 160 | if(/^AGR\s+(\S+)\s+(\S+)$/) |
|---|
| 161 | { |
|---|
| 162 | push @{$agr{$1}}, $2; |
|---|
| 163 | } |
|---|
| 164 | elsif(/^GOV\s+(\S+)\s+(\S+)$/) |
|---|
| 165 | { |
|---|
| 166 | push @{$gov{$1}}, attr::parse($2); |
|---|
| 167 | } |
|---|
| 168 | elsif(/^ROLE\s+\S+$/) |
|---|
| 169 | { |
|---|
| 170 | $roles{$_}=1; |
|---|
| 171 | print OUTPUT "$_\n"; |
|---|
| 172 | } |
|---|
| 173 | elsif(/^SGL\s+\S+$/) |
|---|
| 174 | { |
|---|
| 175 | ++$nsgl; |
|---|
| 176 | print OUTPUT "$_\n"; |
|---|
| 177 | } |
|---|
| 178 | elsif(/^REQ\s+(\S+)\s+(\S+)$/) |
|---|
| 179 | { |
|---|
| 180 | print OUTPUT "#$_\n"; |
|---|
| 181 | my $cat = attr::parse $1; |
|---|
| 182 | for my $atomcat (keys %cats) |
|---|
| 183 | { |
|---|
| 184 | if(attr::match @$cat, @{$cats{$atomcat}}) |
|---|
| 185 | { |
|---|
| 186 | print OUTPUT "REQ ".$atomcat." $2\n"; |
|---|
| 187 | ++$nreq; |
|---|
| 188 | } |
|---|
| 189 | } |
|---|
| 190 | } |
|---|
| 191 | elsif(/^LEFT\s+\S+$/) |
|---|
| 192 | { |
|---|
| 193 | ++$nleft; |
|---|
| 194 | print OUTPUT "$_\n"; |
|---|
| 195 | } |
|---|
| 196 | elsif(/^RIGHT\s+\S+$/) |
|---|
| 197 | { |
|---|
| 198 | ++$nright; |
|---|
| 199 | print OUTPUT "$_\n"; |
|---|
| 200 | } |
|---|
| 201 | elsif(/^INIT\s+[[:lower:]]\S*$/) |
|---|
| 202 | { |
|---|
| 203 | ++$ninitr; |
|---|
| 204 | s/INIT/INITR/; |
|---|
| 205 | print OUTPUT "$_\n"; |
|---|
| 206 | } |
|---|
| 207 | elsif(/^FIN\s+[[:lower:]]\S*$/) |
|---|
| 208 | { |
|---|
| 209 | ++$nfinr; |
|---|
| 210 | s/FIN/FINR/; |
|---|
| 211 | print OUTPUT "$_\n"; |
|---|
| 212 | } |
|---|
| 213 | elsif(/^INIT\s+[[:upper:]]+[+-]$/) |
|---|
| 214 | { |
|---|
| 215 | ++$ninitf; |
|---|
| 216 | s/INIT/INITF/; |
|---|
| 217 | s/[+-]//g; |
|---|
| 218 | print OUTPUT "$_\n"; |
|---|
| 219 | } |
|---|
| 220 | elsif(/^FIN\s+[[:upper:]]+$/) |
|---|
| 221 | { |
|---|
| 222 | ++$nfinf; |
|---|
| 223 | s/FIN/FINF/; |
|---|
| 224 | s/[+-]//g; |
|---|
| 225 | print OUTPUT "$_\n"; |
|---|
| 226 | } |
|---|
| 227 | # elsif(/^INIT\s+([[:upper:]]\S*)$/) |
|---|
| 228 | # { |
|---|
| 229 | # print OUTPUT "#$_\n"; |
|---|
| 230 | # my $cat = attr::parse $1; |
|---|
| 231 | # for my $atomcat (keys %cats) |
|---|
| 232 | # { |
|---|
| 233 | # if(attr::match @$cat, @{$cats{$atomcat}}) |
|---|
| 234 | # { |
|---|
| 235 | # print OUTPUT "INITC ".$atomcat."\n"; |
|---|
| 236 | # ++$ninitc; |
|---|
| 237 | # } |
|---|
| 238 | # } |
|---|
| 239 | # } |
|---|
| 240 | # elsif(/^FIN\s+([[:upper:]]\S*)$/) |
|---|
| 241 | # { |
|---|
| 242 | # print OUTPUT "#$_\n"; |
|---|
| 243 | # my $cat = attr::parse $1; |
|---|
| 244 | # for my $atomcat (keys %cats) |
|---|
| 245 | # { |
|---|
| 246 | # if(attr::match @$cat, @{$cats{$atomcat}}) |
|---|
| 247 | # { |
|---|
| 248 | # print OUTPUT "FINC ".$atomcat."\n"; |
|---|
| 249 | # ++$nfinc; |
|---|
| 250 | # } |
|---|
| 251 | # } |
|---|
| 252 | # } |
|---|
| 253 | elsif(my ($hs,$hfs,$ds,$dfs,$r,$rprops) = /^LINK\s+($cats_re)((?:;$avlist_re)?)\s+($cats_re)((?:;$avlist_re)?)\s+($role_re)((?:$proplist_re)?)$/) |
|---|
| 254 | { |
|---|
| 255 | print OUTPUT "#$_\n"; |
|---|
| 256 | for my $h ($hs =~ /$attr::cat_re/g) |
|---|
| 257 | { |
|---|
| 258 | for my $d ($ds =~ /$attr::cat_re/g) |
|---|
| 259 | { |
|---|
| 260 | addlinks($h,$hfs,$d,$dfs,$r,$rprops); |
|---|
| 261 | } |
|---|
| 262 | } |
|---|
| 263 | } |
|---|
| 264 | # elsif(my ($hs,$ds,$fs,$r) = /^LINK\s+($cats_re)\s+($cats_re)\s+(\S+)\s+(\S+)$/) |
|---|
| 265 | # { |
|---|
| 266 | # print OUTPUT "#$_\n"; |
|---|
| 267 | # for my $h ($hs =~ /$attr::cat_re/g) |
|---|
| 268 | # { |
|---|
| 269 | # for my $d ($ds =~ /$attr::cat_re/g) |
|---|
| 270 | # { |
|---|
| 271 | # addlinks1($h,$d,$fs,$r); |
|---|
| 272 | # } |
|---|
| 273 | # } |
|---|
| 274 | # } |
|---|
| 275 | elsif(/^FLAG\s+\S+$/) |
|---|
| 276 | { |
|---|
| 277 | ++$nflag; |
|---|
| 278 | print OUTPUT "$_\n" |
|---|
| 279 | } |
|---|
| 280 | elsif(/^SET\s+(\S+)\s+(\S+)$/) |
|---|
| 281 | { |
|---|
| 282 | print OUTPUT "#$_\n"; |
|---|
| 283 | my $cat = attr::parse $1; |
|---|
| 284 | my $flag = $2; |
|---|
| 285 | for my $atomcat (keys %cats) |
|---|
| 286 | { |
|---|
| 287 | if(attr::match @$cat, @{$cats{$atomcat}}) |
|---|
| 288 | { |
|---|
| 289 | print OUTPUT "SET ".$atomcat." $flag\n"; |
|---|
| 290 | ++$nset; |
|---|
| 291 | } |
|---|
| 292 | } |
|---|
| 293 | } |
|---|
| 294 | elsif(/^PASS\s+\S+\s+\S+$/) |
|---|
| 295 | { |
|---|
| 296 | ++$npass; |
|---|
| 297 | print OUTPUT "$_\n" |
|---|
| 298 | } |
|---|
| 299 | elsif(/^CONSTR[IE]\s+\S+\s+\S+$/) |
|---|
| 300 | { |
|---|
| 301 | ++$nconstr; |
|---|
| 302 | print OUTPUT "$_\n" |
|---|
| 303 | } |
|---|
| 304 | elsif(/^LONG\s+(\S+)((\s+<\S+)*)((\s+\S+>)*)$/) |
|---|
| 305 | { |
|---|
| 306 | ++$nlong; |
|---|
| 307 | my $rel = $1; |
|---|
| 308 | my $ups = $2; |
|---|
| 309 | my $downs = $4; |
|---|
| 310 | |
|---|
| 311 | $ups =~ s/<//g; |
|---|
| 312 | $ups =~ s/^\s+//; |
|---|
| 313 | my @up = split(/\s+/,$ups); |
|---|
| 314 | |
|---|
| 315 | $downs =~ s/>//g; |
|---|
| 316 | $downs =~ s/^\s+//; |
|---|
| 317 | my @down = split(/\s+/,$downs); |
|---|
| 318 | print OUTPUT "LONG $rel " . join(",",@up) . "^" . join(",",@down) . "\n"; |
|---|
| 319 | } |
|---|
| 320 | elsif(my ($cl,$cs) = /^CLASS\s+(\S+)\s*\:\s*(.*)/) |
|---|
| 321 | { |
|---|
| 322 | print OUTPUT "#$_\n"; |
|---|
| 323 | for my $c ($cs =~ /\S+/g) |
|---|
| 324 | { |
|---|
| 325 | my $cat = attr::parse $c; |
|---|
| 326 | |
|---|
| 327 | for my $atomcat (sort(keys %cats)) |
|---|
| 328 | { |
|---|
| 329 | if(attr::match @$cat, @{$cats{$atomcat}}) |
|---|
| 330 | { |
|---|
| 331 | print OUTPUT "CLASS $cl $atomcat\n"; |
|---|
| 332 | ++$nclass; |
|---|
| 333 | } |
|---|
| 334 | } |
|---|
| 335 | } |
|---|
| 336 | } |
|---|
| 337 | elsif(/^$/) { |
|---|
| 338 | # pomijamy puste linie oraz komentarze |
|---|
| 339 | } |
|---|
| 340 | else |
|---|
| 341 | { |
|---|
| 342 | print STDERR "Illegal format: $_\n"; |
|---|
| 343 | } |
|---|
| 344 | } |
|---|
| 345 | |
|---|
| 346 | |
|---|
| 347 | sub addlinks |
|---|
| 348 | { |
|---|
| 349 | my ($h,$hfs,$d,$dfs,$r,$rprops) = @_; |
|---|
| 350 | |
|---|
| 351 | for my $a (@{$agr{$r}}) { print OUTPUT "#AGR $r $a\n"; } |
|---|
| 352 | for my $c (@{$gov{$r}}) { print OUTPUT "#GOV $r ".attr::unparse(@$c)."\n"; } |
|---|
| 353 | my $head = attr::parse $h; |
|---|
| 354 | my $dep = attr::parse $d; |
|---|
| 355 | |
|---|
| 356 | for my $atomhead (keys %cats) |
|---|
| 357 | { |
|---|
| 358 | if(attr::match @$head, @{$cats{$atomhead}}) |
|---|
| 359 | { |
|---|
| 360 | DEP: |
|---|
| 361 | for my $atomdep (keys %cats) |
|---|
| 362 | { |
|---|
| 363 | next DEP if ! attr::match @$dep, @{$cats{$atomdep}}; |
|---|
| 364 | |
|---|
| 365 | for my $a (@{$agr{$r}}) |
|---|
| 366 | { |
|---|
| 367 | next DEP if ! attr::agree(@{$cats{$atomhead}},@{$cats{$atomdep}},$a); |
|---|
| 368 | } |
|---|
| 369 | |
|---|
| 370 | for my $c (@{$gov{$r}}) |
|---|
| 371 | { |
|---|
| 372 | next DEP if ! attr::match(@$c,@{$cats{$atomdep}}); |
|---|
| 373 | } |
|---|
| 374 | |
|---|
| 375 | print OUTPUT "LINK $atomhead$hfs $atomdep$dfs $r$rprops\n"; |
|---|
| 376 | ++$nlink; |
|---|
| 377 | |
|---|
| 378 | } |
|---|
| 379 | } |
|---|
| 380 | } |
|---|
| 381 | } |
|---|
| 382 | |
|---|
| 383 | |
|---|
| 384 | sub addlinks1 |
|---|
| 385 | { |
|---|
| 386 | my ($h,$d,$fs,$r) = @_; |
|---|
| 387 | |
|---|
| 388 | for my $a (@{$agr{$r}}) { print OUTPUT "#AGR $r $a\n"; } |
|---|
| 389 | for my $c (@{$gov{$r}}) { print OUTPUT "#GOV $r ".attr::unparse(@$c)."\n"; } |
|---|
| 390 | my $head = attr::parse $h; |
|---|
| 391 | my $dep = attr::parse $d; |
|---|
| 392 | |
|---|
| 393 | for my $atomhead (keys %cats) |
|---|
| 394 | { |
|---|
| 395 | if(attr::match @$head, @{$cats{$atomhead}}) |
|---|
| 396 | { |
|---|
| 397 | DEP: |
|---|
| 398 | for my $atomdep (keys %cats) |
|---|
| 399 | { |
|---|
| 400 | next DEP if ! attr::match @$dep, @{$cats{$atomdep}}; |
|---|
| 401 | |
|---|
| 402 | for my $a (@{$agr{$r}}) |
|---|
| 403 | { |
|---|
| 404 | next DEP if ! attr::agree(@{$cats{$atomhead}},@{$cats{$atomdep}},$a); |
|---|
| 405 | } |
|---|
| 406 | |
|---|
| 407 | for my $c (@{$gov{$r}}) |
|---|
| 408 | { |
|---|
| 409 | next DEP if ! attr::match(@$c,@{$cats{$atomdep}}); |
|---|
| 410 | } |
|---|
| 411 | |
|---|
| 412 | print OUTPUT "LINK $atomhead $atomdep $fs $r\n"; |
|---|
| 413 | ++$nlink; |
|---|
| 414 | |
|---|
| 415 | } |
|---|
| 416 | } |
|---|
| 417 | } |
|---|
| 418 | } |
|---|
| 419 | |
|---|
| 420 | |
|---|
| 421 | printf STDERR "%6d CAT statements\n", 0+keys(%cats); |
|---|
| 422 | printf STDERR "%6d ROLE statements\n", 0+keys(%roles); |
|---|
| 423 | printf STDERR "%6d SGL statements\n", $nsgl; |
|---|
| 424 | printf STDERR "%6d REQ statements\n", $nreq; |
|---|
| 425 | printf STDERR "%6d LEFT statements\n", $nleft; |
|---|
| 426 | printf STDERR "%6d RIGHT statements\n", $nright; |
|---|
| 427 | printf STDERR "%6d INITR statements\n", $ninitr; |
|---|
| 428 | printf STDERR "%6d FINR statements\n", $nfinr; |
|---|
| 429 | printf STDERR "%6d INITF statements\n", $ninitf; |
|---|
| 430 | printf STDERR "%6d FINF statements\n", $nfinf; |
|---|
| 431 | printf STDERR "%6d INITC statements\n", $ninitc; |
|---|
| 432 | printf STDERR "%6d FINC statements\n", $nfinc; |
|---|
| 433 | printf STDERR "%6d LINK statements\n", $nlink; |
|---|
| 434 | printf STDERR "%6d CLASS statements\n", $nclass; |
|---|
| 435 | printf STDERR "%6d FLAG statements\n", $nflag; |
|---|
| 436 | printf STDERR "%6d SET statements\n", $nset; |
|---|
| 437 | printf STDERR "%6d PASS statements\n", $npass; |
|---|
| 438 | |
|---|
| 439 | |
|---|
| 440 | sub extractcats |
|---|
| 441 | { |
|---|
| 442 | my $file = shift; |
|---|
| 443 | open DICFILE, "$file"; |
|---|
| 444 | while(<DICFILE>) |
|---|
| 445 | { |
|---|
| 446 | while(/,([^[:space:];]+)/g) |
|---|
| 447 | { |
|---|
| 448 | my $cat=$1; |
|---|
| 449 | next if !$cat || exists $cats{$cat}; |
|---|
| 450 | $ncat++; |
|---|
| 451 | print OUTPUT "CAT $1\n"; |
|---|
| 452 | $cats{$cat}=attr::parse($cat); |
|---|
| 453 | } |
|---|
| 454 | } |
|---|
| 455 | close DICFILE; |
|---|
| 456 | } |
|---|
| 457 | |
|---|
| 458 | |
|---|
| 459 | sub loadcats |
|---|
| 460 | { |
|---|
| 461 | my $file = shift; |
|---|
| 462 | open CATFILE, "$file"; |
|---|
| 463 | while(<CATFILE>) |
|---|
| 464 | { |
|---|
| 465 | tr/ \t\n//d; |
|---|
| 466 | next if !$_ || exists $cats{$_}; |
|---|
| 467 | print OUTPUT "CAT $_\n"; |
|---|
| 468 | ++$ncat; |
|---|
| 469 | $cats{$_}=attr::parse($_); |
|---|
| 470 | } |
|---|
| 471 | close CATFILE; |
|---|
| 472 | } |
|---|
| 473 | |
|---|
