source: src/dgc/dgc @ 3b02b04

Last change on this file since 3b02b04 was 3b02b04, checked in by Tomasz Obrebski <to@…>, 11 years ago

prawie ca�kiem nowe dgc, du�e zmiany w dgp, pomniejsze poprawki
  • Property mode set to 100755
File size: 17.4 KB
Line 
1#!/usr/bin/perl
2
3#package:       UAM Text Tools
4#component:     dgc (dg compiler)
5#version:       1.0
6#author:        Tomasz Obrebski
7
8use lib "/usr/local/lib/utt";
9use lib "$ENV{'HOME'}/.local/lib/utt";
10
11#use strict;
12use Getopt::Long;
13use Data::Dumper;
14use attr;
15use File::HomeDir;
16use Parse::RecDescent;
17
18$::RD_HINT=1;
19# use List::MoreUtils;
20
21my $systemconfigfile='/etc/utt/dgc.conf';
22my $userconfigfile=0; #home()."/.utt/dgc.conf";
23
24Getopt::Long::Configure('no_ignore_case_always');
25
26my $help=0;
27my $catfile=0;
28my $dicfile=0;
29my $gramfile=0;
30my $outputfile=0;
31
32#read configuration files###########################
33my $file;
34foreach $file ($systemconfigfile, $userconfigfile){
35  if(open(CONFIG, $file)){
36        while (<CONFIG>) {
37                chomp; s/#.*//; s/^\s+//; s/\s+$//;
38                next unless length;
39                my ($name, $value) = split(/\s*=\s*/, $_, 2);
40                if(($name eq "categories")or($name eq "c"))      { $catfile=$value; }
41                elsif(($name eq "dictionary")or($name eq "d"))   { $dicfile=$value; }
42                elsif(($name eq "grammar")or($name eq "g"))      { $gramfile=$value; }
43                elsif(($name eq "outputfile")or($name eq "o"))   { $outputfile=$value; }
44                elsif(($name eq "help")or($name eq "h"))         { $help=1; }
45
46        }
47        close CONFIG;
48  }
49}
50#########################################################
51
52GetOptions("help|h" => \$help,
53           "categories|c=s" => \$catfile,
54           "dictionary|d=s" => \$dicfile,
55           "grammar|g=s" => \$gramfile,
56           "outputfile|o=s" => \$outputfile);
57
58my $homedir = $ENV{'HOME'};
59$catfile =~ s/~/$homedir/;
60$dicfile =~ s/~/$homedir/;
61$gramfile =~ s/~/$homedir/;
62$outputfile =~ s/~/$homedir/;
63
64
65if($help)
66{
67    print <<'END'
68Usage: dgc [OPTIONS]
69
70Options:
71   --categories -c filename     List of syntactic categories.
72   --dictionary -d filename     Dictionary.
73   --grammar -g filename        List of grammar rules.
74   --outputfile -o filename     Output file name.
75   --help -h                    Help.
76END
77;
78    exit 0;
79}
80
81die("At least one of --cats and --dic must be given.\n") if !$catfile && !$dicfile;
82
83
84our %in;      #gramatyka wej¶ciowa
85our %idx;     #indeks gramatyki wej¶ciowej (niektóre stwierdzenia)
86our %out;     #gramatyka wyj¶ciowa
87our %class;   #tablica klas
88
89our $attr_re       = $attr::attr_re;
90our $cat_re        = $attr::cat_re;
91our $cats_re       = qr/(?:$attr::cat_re\s*(?:,\s*$attr::cat_re)*)/;
92our $class_re      = qr/(?:\@\w+)/;
93our $av_re         = $attr::av_re;
94our $avlist_re     = $attr::avlist_re;
95our $role_re       = qr/(?:[[:lower:][:digit:]_]+)/;
96our $prop_re       = qr/(?:[[:upper:]]+)/;
97our $proplist_re   = qr/(?:(?:\&$prop_re)+)/;
98
99my $inputlineno=0;
100
101our $statementgrammar = q(
102
103statement : statement1 ";" { $item[1] }
104
105statement1: /cat/i     acat              { ['cat',     { cat=>$item{acat}, catexp=>attr::parse($item{acat}) },       $item{acat}] }
106          | /flag/i    flag              { ['flag',    { flag=>$item{flag} },                                        $item{flag}] }
107          | /role/i    role              { ['role',    { role=>$item{role} },                                        $item{role}] }
108          | /left/i    role              { ['left',    { role=>$item{role} },                                                  0] }
109          | /right/i   role              { ['right',   { role=>$item{role} },                                                  0] }
110          | /sgl/i     role              { ['sgl',     { role=>$item{role} },                                                  0] }
111          | /req/i     xcat role         { ['req',     { cats=>$item{xcat}, role=>$item{role} },                               0] }
112          | /agr/i     role attr         { ['agr',     { role=>$item{role}, attr=>$item{attr} },                     $item{role}] }
113          | /gov/i     role xcat         { ['gov',     { role=>$item{role}, cats=>$item{xcat} },                     $item{role}] }
114          | /init/i    flagconstr        { ['initf',   { flag=>$item{flagconstr} },                                            0] }
115          | /fin/i     flagconstr        { ['finf',    { flag=>$item{flagconstr} },                                            0] }
116          | /init/i    role              { ['initr',   { role=>$item{role} },                                                  0] }
117          | /fin/i     role              { ['finr',    { role=>$item{role} },                                                  0] }
118          | /set/i     xcat flag         { ['set',     { cats=>$item{xcat}, flag=>$item{flag} },                               0] }
119          | /pass/i    role flag         { ['pass',    { role=>$item{role}, flag=>$item{flag} },                               0] }
120          | /constre/i role role         { ['constre', { role1=>$item[2], role2=>$item[3] },                                   0] }
121          | /constri/i role role         { ['constri', { role1=>$item[2], role2=>$item[3] },                                   0] }
122
123          | /link/i    xcat optflags(?) xcat optflags(?) role prop(s?)
124                                         { ['link', { hcats=>$item[2], hflagconstr=>$item[3],
125                                                      dcats=>$item[4], dflagconstr=>$item[5],
126                                                      role=>$item[6], props=>$item[7] },                                       0] }
127
128          | /long/i role role(s? /,/) '^' role(s? /,/)
129                                         { ['long', { rel=>$item[2], up=>$item[3], down=>$item[5] },                           0] }
130
131          | /class/i classname '=' xcat  { ['class', { name=>$item{classname}, cats=>$item{xcat} },             $item{classname}] }
132
133acat:       /$attr::cat_re/
134
135attr:       /$attr::attr_re/
136
137xcat:       classexpr
138
139role:       /\w+/
140
141flag:       /\w+/
142
143optflags:   "//" flagconstr { $item[2] }
144
145flagconstr: /\w+[+-]/
146
147prop:       '&' /\w+/ { $item[2] }
148
149classname:  /\$\w+[+-]/
150
151classexpr  : classexpr1 '|' classexpr   { main::union($item[1],$item[3]) }
152           | classexpr1 '~' classexpr   { main::intersection( $item[1], main::complement($item[3]) ) }
153           | classexpr1
154
155classexpr1 : classexpr2 '&' classexpr1  { main::intersection($item[1],$item[3]) }
156           | classexpr2
157
158classexpr2 : '~' classexpr2            { main::complement($item[2]) }
159           | classexpr3
160
161classexpr3 : classexpr4 '/' /$attr::avlist_re/  { main::intersection($item[1], [main::extension('*/' . $item[3])] ) }
162           | classexpr4
163
164classexpr4 : class
165           | cat
166           | '(' classexpr ')'          { $item[2] }
167
168class :    classname                    { $main::class{$item[1]} or @{[]} }
169
170cat :      /$main::cat_re/              { [main::extension($item[1])] }
171
172);
173
174our $statementparser = Parse::RecDescent->new($statementgrammar);
175
176sub register
177{
178    my ($src, $statement, $data, $index) = @_ ;
179    $data->{line} = $inputlineno;
180    $data->{src} = $src;
181    push @{$in{$statement}}, $data;
182    push @{$idx{$statement}{$index}}, $data if($index);
183
184    if ($statement eq 'class') { $class{ $data->{name} } = $data->{cats} }
185}
186
187
188if(!$outputfile)          { *OUTPUT = *STDOUT; }
189elsif($outputfile eq "-") { *OUTPUT = *STDOUT; }
190else                      { open(OUTPUT, ">$outputfile") or die("Can't open output file: $outputfile!"); }
191
192if(!$gramfile)            { *INPUT = *STDIN; }
193elsif($gramfile eq "-")   { *INPUT = *STDIN; }
194else                      { open(INPUT, "cat $gramfile | m4 |") or die("Unable to open: $gramfile!"); }
195
196# *INPUT = *STDIN; ############### TYMCZASOWO
197
198loadcats($catfile) if $catfile;
199extractcats($dicfile) if $dicfile;
200
201
202# CZYTANIE GRAMATYKI DGC
203
204while(<INPUT>)
205{
206    $inputlineno++;
207    s/#.*//;
208    s/^\s+//;
209    s/\s+$//;
210    s/\s+/ /g;
211    next unless $_;
212    my $result = $statementparser->statement("$_;");
213
214    # print "#input line $inputlineno\n";
215    # print Dumper($result);
216
217    if($result) { register($_, @{$result}) } else { print STDERR "ERROR at line $inputlineno\n" }
218}
219   
220
221# GENEROWANIE GRAMATYKI DGP
222
223my $inline = 0;
224my $outline = 0;
225
226
227# print Dumper($idx{gov}->{subj});
228
229
230for my $x (@{$in{cat}})    { print_outin("CAT $x->{cat}", $x); }
231
232for my $x (@{$in{flag}})   { print_outin("FLAG $x->{flag}", $x); }
233
234for my $x (@{$in{role}})   { print_outin("ROLE $x->{role}", $x); }
235
236for my $x (@{$in{long}})    { print_outin("LONG $x->{rel} " . join(",",@{$x->{up}}) . "^" . join(",",@{$x->{down}}), $x) }
237
238for my $x (@{$in{left}})   { print_outin("LEFT $x->{role}", $x)  if chk_role($x->{role}, $x) }
239
240for my $x (@{$in{right}})  { print_outin("RIGHT $x->{role}", $x) if chk_role($x->{role}, $x) }
241
242for my $x (@{$in{sgl}})    { print_outin("SGL $x->{role}", $x)   if chk_role($x->{role}, $x) }
243
244for my $x (@{$in{req}})
245{
246    if( chk_role($x->{role}, $x) )
247    {
248        for my $atomcat (map{$_->{cat}} @{$x->{cats}})
249        {
250            print_outin("REQ $atomcat $x->{role}", $x);
251        }
252    }
253}
254
255for my $x (@{$in{initr}}) { print_outin("INITR $x->{role}", $x)    if chk_role($x->{role}, $x) }
256
257for my $x (@{$in{finr}}) { print_outin("FINR $x->{role}", $x)      if chk_role($x->{role}, $x) }
258
259for my $x (@{$in{initf}}) { print_outin("INITF $x->{flag}", $x) } # SPRAWDZIÆ CZY FLAGA JEST ZADEKLAROWANA
260
261for my $x (@{$in{finf}}) { print_outin("FINF $x->{flag}", $x); } # SPRAWDZIÆ CZY FLAGA JEST ZADEKLAROWANA
262
263for my $x (@{$in{set}})
264{
265    for my $atomcat (map{$_->{cat}} @{$x->{cats}})
266    {
267        print_outin("SET $atomcat $x->{flag}", $x);
268    }   
269}
270
271for my $x (@{$in{pass}})    { print_outin("PASS $x->{role} $x->{flag}", $x); }
272
273for my $x (@{$in{constre}}) { print_outin("CONSTRE $x->{role1} $x->{role2}", $x) if chk_role($x->{role1}, $x) & chk_role($x->{role2}, $x) }
274
275for my $x (@{$in{constri}}) { print_outin("CONSTRI $x->{role1} $x->{role2}", $x) if chk_role($x->{role1}, $x) & chk_role($x->{role2}, $x) }
276
277for my $x (@{$in{link}})
278{
279    my @agrs = @{ $idx{agr}->{$x->{role} } or [] };
280    my @govs = @{ $idx{gov}->{$x->{role} } or [] };
281
282    my @deps = (@govs > 0) ? @{ intersection( $x->{dcats}, map { $_->{cats} } @govs ) } : @{ $x->{dcats} } ;
283
284    for my $head ( @{ $x->{hcats} } )
285    {
286      DEP:
287        for my $dep (@deps)
288        {
289            for my $agr (@agrs)
290            {
291                next DEP unless attr::agree(@{$head->{catexp}},@{$dep->{catexp}},$agr->{attr});
292            }
293            my $hflagconstr = @{$x->{hflagconstr}} ? "//@{$x->{hflagconstr}}" : "";
294            my $dflagconstr = @{$x->{dflagconstr}} ? "//@{$x->{dflagconstr}}" : "";
295            my $props = join(map { "\&$_" } $x->{props});
296            print_outin("LINK $head->{cat}$hflagconstr $dep->{cat}$dflagconstr $x->{role}$props",$x, @agrs, @govs);
297        }
298    }
299}
300
301
302sub chk_role
303{
304    ($role, $statement_details) = @_;
305    if($idx{role}{$role}) { 1; } else { print_error("undefined role", $statement_details); 0; }
306}
307
308sub print_outin
309{
310    my ($out,@in) = (shift, @_);
311    print OUTPUT "$out\t\t#";
312    printf OUTPUT " %04d@\"%s\"", $_->{line}, $_->{src} foreach @in;
313    print OUTPUT "\n";
314}
315
316sub print_error
317{
318    my ($message,@in) = (shift,@_);
319    print STDERR "ERROR: $message in statement ";
320    printf STDERR " %04d@\"%s\"", $_->{line}, $_->{src} foreach @in;
321    print STDERR "\n";
322}
323
324
325sub extractcats
326{
327    my $file = shift;
328    open DICFILE, "$file";
329    while(<DICFILE>)
330    {
331        while(/,([^[:space:];]+)/g)
332        {
333            my $cat=$1;
334            next if !$cat; # || exists $cats{$cat};
335#           print OUTPUT "CAT $1\n";
336            register('cat',     {src=>"CAT $cat", cat=>"$cat", catexp=>attr::parse($cat)},                 $cat);
337        }
338    }
339    close DICFILE;
340}
341
342
343sub loadcats
344{
345    my $file = shift;
346    open CATFILE, "$file";
347    while(<CATFILE>)
348    {
349        tr/ \t\n//d;
350        next if !$_; # || exists $cats{$_};
351#       print OUTPUT "CAT $_\n";
352        register("CAT $_", 'cat',     {cat=>"$_", catexp=>attr::parse($_)},                 $_);
353    }
354    close CATFILE;
355}
356
357sub extension
358{
359    my $cat = shift;
360    my $catexp = attr::parse($cat);
361    grep { attr::match(@{$_->{catexp}},@{$catexp}) } @{$in{cat}};
362}
363
364sub uniq  { my %seen; grep { ! $seen{$_}++ } @_ }
365sub union { [ uniq( map { @{$_} } @_ ) ] }
366sub intersection { my $n=@_; my %seen; [ grep { ++$seen{$_} == $n } map { @{$_} } @_ ] }
367sub complement   { my %exclude;   for $c (@{shift()}) { $exclude{$c}++ };   [ grep { ! $exclude{$_} } @{$in{cat}} ] }
368
369# printf STDERR "%6d CAT   statements\n", 0+keys(%cats);
370# printf STDERR "%6d ROLE  statements\n", 0+keys(%role);
371# printf STDERR "%6d SGL   statements\n", @sgl+0;
372# printf STDERR "%6d REQ   statements\n", @req+0;
373# printf STDERR "%6d LEFT  statements\n", $nleft;
374# printf STDERR "%6d RIGHT statements\n", $nright;
375# printf STDERR "%6d INITR statements\n", $ninitr;
376# printf STDERR "%6d FINR  statements\n", $nfinr;
377# printf STDERR "%6d INITF statements\n", $ninitf;
378# printf STDERR "%6d FINF  statements\n", $nfinf;
379# printf STDERR "%6d INITC statements\n", $ninitc;
380# printf STDERR "%6d FINC  statements\n", $nfinc;
381# printf STDERR "%6d LINK  statements\n", $nlink;
382# printf STDERR "%6d CLASS statements\n", $nclass;
383# printf STDERR "%6d FLAG  statements\n", $nflag;
384# printf STDERR "%6d SET   statements\n", $nset;
385# printf STDERR "%6d PASS  statements\n", $npass;
386
387
388##################################################################################
389
390# while(<INPUT>)
391# {
392#     $inputlineno++;
393#     s/#.*//;
394#     s/^\s+//;
395#     s/\s+$//;
396#     s/\s+/ /g;
397#     if   (/^CAT ($cat_re)$/)         { register('cat',     {src=>$&, cat=>attr::parse($1)},                 $1); }
398#     elsif(/^FLAG (\S+)$/)            { register('flag',    {src=>$&, flag=>$1},                             $1); }
399#     elsif(/^ROLE (\S+)$/)            { register('role',    {src=>$&, role=>$1},                             $1); }
400#     elsif(/^LEFT (\S+)$/)            { register('left',    {src=>$&, role=>$1},                              0); }
401#     elsif(/^RIGHT (\S+)$/)           { register('right',   {src=>$&, role=>$1},                              0); }
402#     elsif(/^SGL (\S+)$/)             { register('sgl',     {src=>$&, role=>$1},                              0); }
403#     elsif(/^REQ (\S+) (\S+)$/)       { register('req',     {src=>$&, cat=>$1, role=>$2},                     0); }
404#     elsif(/^AGR (\S+) (\S+)$/)       { register('agr',     {src=>$&, role=>$1, attr=>$2},                   $1); }
405#     elsif(/^GOV (\S+) (\S+)$/)       { register('gov',     {src=>$&, role=>$1, cat=>$2, catexp=>attr::parse($2)},       $1); }
406#     elsif(/^INIT ($role_re)$/)       { register('initr',   {src=>$&, role=>$1},                              0); }
407#     elsif(/^FIN ($role_re)$/)        { register('finr',    {src=>$&, role=>$1},                              0); }
408#     elsif(/^INIT ($av_re)$/)         { register('initf',   {src=>$&, flag=>$1},                              0); }
409#     elsif(/^FIN ($av_re)$/)          { register('finf',    {src=>$&, flag=>$1},                              0); }
410#     elsif(/^SET ($cat_re)\s+(\S+)$/) { register('set',     {src=>$&, cat=>$1, flag=>$2},                     0); }
411#     elsif(/^PASS (\S+)\s+(\S+)$/)    { register('pass',    {src=>$&, role=>$1, flag=>$2},                    0); }
412#     elsif(/^CONSTRE (\S+)\s+(\S+)$/) { register('constre', {src=>$&, role1=>$1, role2=>$2},                  0); }
413#     elsif(/^CONSTRI (\S+)\s+(\S+)$/) { register('constri', {src=>$&, role1=>$1, role2=>$2},                  0); }
414
415#     elsif(my ($hs,$hfs,$ds,$dfs,$r,$rprops) = /^LINK\s+($cats_re)((?:;$avlist_re)?)\s+($cats_re)((?:;$avlist_re)?)\s+($role_re)((?:$proplist_re)?)$/)
416#                                        { register('link', {src=>$&, hs=>$hs, hfs=>$hfs, ds=>$ds, dfs=>$dfs, r=>$r, props=>$rprops},0) }
417#     elsif(/^LONG\s+(\S+)((\s+<\S+)*)((\s+\S+>)*)$/)
418#     {
419#       my $rel = $1;
420#       my $ups = $2;
421#       my $downs = $4;
422
423#       $ups =~ s/<//g;
424#       $ups =~ s/^\s+//;
425#       my @up = split(/\s+/,$ups) or ();
426
427#       $downs =~ s/>//g;
428#       $downs =~ s/^\s+//;
429#       my @down = split(/\s+/,$downs) or ();
430
431#       register('long', {src=>$&, rel=>$rel, up=>\@up, down=>\@down},0);
432
433#       print OUTPUT "LONG $rel " . join(",",@up) . "^" . join(",",@down) . "\n";
434#     }
435#     elsif(my ($cl,$cs) = /^CLASS\s+(\S+)\s*\=(.*)$/)
436#     {
437#       $class{$1} = $classparser->classexpr($2);
438#     }
439#     elsif(/^$/)
440#     {
441#       # pomijamy puste linie oraz komentarze
442#     }
443#     else
444#     {
445#       print STDERR "Illegal format: $_\n";
446#     }
447# }
448
449
450
451# sub is_cat  { shift =~ /$attr::cat_re/; }
452# sub is_role { $role{shift}; }
453# sub is_flag { $flag{shift}; }
454
455
456# sub print_in
457# {
458#     my $data = shift();
459#     printf "in@%04d ", $data->{line};
460#     print $data->{src};
461# }
462
463# sub print_out
464# {
465#     printf "out@%08d ", $outline++;
466#     print @_;
467# }
468
469# sub addlinks
470# {
471#     my ($l, $h,$hfs,$d,$dfs,$r,$rprops) = @_;
472
473#     my @heads = extension($h);
474#     my @deps = extension($d);
475
476#     my @deps_gov;
477#   DEP_GOV:
478#     for my $dep (@deps)
479#     {
480#       for my $gov (@govs)
481#       {
482#           next DEP_GOV unless attr::match(@{$dep->{catexp}},@{$gov->{catexp}});
483#       }
484#       push @deps_gov, $dep;
485#     }
486   
487#     for my $head (@heads)
488#     {
489#       DEP:
490#       for my $dep (@deps_gov)
491#       {
492#           for my $agr (@agrs)
493#           {
494#               next DEP unless attr::agree(@{$head->{catexp}},@{$dep->{catexp}},$agr->{attr});
495#           }
496#           print_outin("LINK $head->{cat}$hfs $dep->{cat}$dfs $r$rprops",$l, @agrs,@govs);
497#       }
498#     }
499# }
500
501
502
503
504    # elsif(/^INIT\s+([[:upper:]]\S*)$/)
505    # {
506    #   print OUTPUT "#$_\n";
507    #   my $cat = attr::parse $1;
508    #   for my $atomcat (keys %cats)
509    #   {
510    #       if(attr::match @$cat, @{$cats{$atomcat}})
511    #       {
512    #           print OUTPUT "INITC ".$atomcat."\n";
513    #           ++$ninitc;
514    #       }
515    #   }
516    # }
517    # elsif(/^FIN\s+([[:upper:]]\S*)$/)
518    # {
519    #   print OUTPUT "#$_\n";
520    #   my $cat = attr::parse $1;
521    #   for my $atomcat (keys %cats)
522    #   {
523    #       if(attr::match @$cat, @{$cats{$atomcat}})
524    #       {
525    #           print OUTPUT "FINC ".$atomcat."\n";
526    #           ++$nfinc;
527    #       }
528    #   }
529    # }
Note: See TracBrowser for help on using the repository browser.