Changeset 3b02b04 for src/dgc


Ignore:
Timestamp:
01/17/13 20:50:41 (12 years ago)
Author:
Tomasz Obrebski <to@…>
Branches:
master
Children:
d2f119e
Parents:
555c7f8
git-author:
Tomasz Obrebski <to@…> (01/17/13 20:50:41)
git-committer:
Tomasz Obrebski <to@…> (01/17/13 20:50:41)
Message:

prawie ca�kiem nowe dgc, du�e zmiany w dgp, pomniejsze poprawki

Location:
src/dgc
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • src/dgc/Makefile

    re7de6cc r3b02b04  
    77ifdef BIN_DIR 
    88        install -m 0755 dgc $(BIN_DIR) 
     9        install -m 0755 l2src $(BIN_DIR) 
    910endif 
    1011 
    … …  
    1314ifdef BIN_DIR 
    1415        rm $(BIN_DIR)/dgc 
     16        rm $(BIN_DIR)/l2src 
    1517endif 
    1618 

  • src/dgc/dgc

    re7de6cc r3b02b04  
    99use lib "$ENV{'HOME'}/.local/lib/utt"; 
    1010 
    11 use strict; 
     11#use strict; 
    1212use Getopt::Long; 
    1313use Data::Dumper; 
    1414use attr; 
    1515use File::HomeDir; 
     16use Parse::RecDescent; 
     17 
     18$::RD_HINT=1; 
     19# use List::MoreUtils; 
    1620 
    1721my $systemconfigfile='/etc/utt/dgc.conf'; 
    18 my $userconfigfile=home()."/.utt/dgc.conf"; 
     22my $userconfigfile=0; #home()."/.utt/dgc.conf"; 
    1923 
    2024Getopt::Long::Configure('no_ignore_case_always'); 
    … …  
    3135  if(open(CONFIG, $file)){ 
    3236        while (<CONFIG>) { 
    33                 chomp; 
    34                 s/#.*//; 
    35                 s/^\s+//; 
    36                 s/\s+$//; 
     37                chomp; s/#.*//; s/^\s+//; s/\s+$//; 
    3738                next unless length; 
    3839                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                 } 
     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; } 
    5445 
    5546        } 
    … …  
    9081die("At least one of --cats and --dic must be given.\n") if !$catfile && !$dicfile; 
    9182 
    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  
     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 
    127197 
    128198loadcats($catfile) if $catfile; 
    … …  
    130200 
    131201 
    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 } 
     202# CZYTANIE GRAMATYKI DGC 
    154203 
    155204while(<INPUT>) 
    156205{ 
     206    $inputlineno++; 
    157207    s/#.*//; 
    158208    s/^\s+//; 
    159209    s/\s+$//; 
    160     if(/^AGR\s+(\S+)\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) ) 
    161247    { 
    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) 
     248        for my $atomcat (map{$_->{cat}} @{$x->{cats}}) 
    183249        { 
    184             if(attr::match @$cat, @{$cats{$atomcat}}) 
    185             { 
    186                 print OUTPUT "REQ ".$atomcat." $2\n"; 
    187                 ++$nreq; 
    188             } 
     250            print_outin("REQ $atomcat $x->{role}", $x); 
    189251        } 
    190252    } 
    191     elsif(/^LEFT\s+\S+$/) 
     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}}) 
    192266    { 
    193         ++$nleft; 
    194         print OUTPUT "$_\n"; 
     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        } 
    195298    } 
    196     elsif(/^RIGHT\s+\S+$/) 
     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>) 
    197330    { 
    198         ++$nright; 
    199         print OUTPUT "$_\n"; 
     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        } 
    200338    } 
    201     elsif(/^INIT\s+[[:lower:]]\S*$/) 
     339    close DICFILE; 
     340} 
     341 
     342 
     343sub loadcats 
     344{ 
     345    my $file = shift; 
     346    open CATFILE, "$file"; 
     347    while(<CATFILE>) 
    202348    { 
    203         ++$ninitr; 
    204         s/INIT/INITR/; 
    205         print OUTPUT "$_\n"; 
     349        tr/ \t\n//d; 
     350        next if !$_; # || exists $cats{$_}; 
     351#       print OUTPUT "CAT $_\n"; 
     352        register("CAT $_", 'cat',     {cat=>"$_", catexp=>attr::parse($_)},                 $_); 
    206353    } 
    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     } 
     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 
    227504    # elsif(/^INIT\s+([[:upper:]]\S*)$/) 
    228505    # { 
    … …  
    251528    #   } 
    252529    # } 
    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  
Note: See TracChangeset for help on using the changeset viewer.