source: src/dgc/dgc

Last change on this file was 845ee69, checked in by to <to@…>, 12 years ago

dgc: format bug fixed, old comments cleaned
  • Property mode set to 100755
File size: 11.9 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
297            print_outin("LINK $head->{cat}$hflagconstr $dep->{cat}$dflagconstr $x->{role}$props",$x, @agrs, @govs);
298        }
299    }
300}
301
302
303sub chk_role
304{
305    ($role, $statement_details) = @_;
306    if($idx{role}{$role}) { 1; } else { print_error("undefined role", $statement_details); 0; }
307}
308
309sub print_outin
310{
311    my ($out,@in) = (shift, @_);
312    print OUTPUT "$out\t\t#";
313    printf OUTPUT " %04d@\"%s\"", $_->{line}, $_->{src} foreach @in;
314    print OUTPUT "\n";
315}
316
317sub print_error
318{
319    my ($message,@in) = (shift,@_);
320    print STDERR "ERROR: $message in statement ";
321    printf STDERR " %04d@\"%s\"", $_->{line}, $_->{src} foreach @in;
322    print STDERR "\n";
323}
324
325
326sub extractcats
327{
328    my $file = shift;
329    open DICFILE, "$file";
330    while(<DICFILE>)
331    {
332        while(/,([^[:space:];]+)/g)
333        {
334            my $cat=$1;
335            next if !$cat; # || exists $cats{$cat};
336#           print OUTPUT "CAT $1\n";
337            register('cat',     {src=>"CAT $cat", cat=>"$cat", catexp=>attr::parse($cat)},                 $cat);
338        }
339    }
340    close DICFILE;
341}
342
343
344sub loadcats
345{
346    my $file = shift;
347    open CATFILE, "$file";
348    while(<CATFILE>)
349    {
350        tr/ \t\n//d;
351        next if !$_; # || exists $cats{$_};
352#       print OUTPUT "CAT $_\n";
353        register("CAT $_", 'cat',     {cat=>"$_", catexp=>attr::parse($_)},                 $_);
354    }
355    close CATFILE;
356}
357
358sub extension
359{
360    my $cat = shift;
361    my $catexp = attr::parse($cat);
362    grep { attr::match(@{$_->{catexp}},@{$catexp}) } @{$in{cat}};
363}
364
365sub uniq  { my %seen; grep { ! $seen{$_}++ } @_ }
366sub union { [ uniq( map { @{$_} } @_ ) ] }
367sub intersection { my $n=@_; my %seen; [ grep { ++$seen{$_} == $n } map { @{$_} } @_ ] }
368sub complement   { my %exclude;   for $c (@{shift()}) { $exclude{$c}++ };   [ grep { ! $exclude{$_} } @{$in{cat}} ] }
369
Note: See TracBrowser for help on using the repository browser.