our
$AUTHORITY
=
'cpan:MATY'
;
$PMLTQ::Relation::PDT::VERSION
=
'2.0.1'
;
sub
ADiveAuxCP ($){
$_
[0]->{afun}=~/^Aux[CP]/ ? 1 : 0;
}
sub
A_ExpandCoordGetEParents {
my
(
$node
,
$through
)=
@_
;
my
@toCheck
=
$node
->children;
my
@checked
;
while
(
@toCheck
) {
@toCheck
=
map
{
if
(
&$through
(
$_
)) {
$_
->children() }
elsif
(
$_
->{afun}=~/Coord|Apos/&
&$_
->{is_member}){ A_ExpandCoordGetEParents(
$_
,
$through
) }
elsif
(
$_
->{is_member}){
push
@checked
,
$_
;() }
else
{()}
}
@toCheck
;
}
return
@checked
;
}
sub
AGetEParents {
my
(
$node
,
$through
)=
@_
;
my
$init_node
=
$node
;
return
()
if
!
$node
or
$node
->{afun}=~/^(?:Coord|Apos|Aux[SCP])$/;
if
(
$node
->{is_member}) {
while
(
$node
->{afun}!~/Coord|Apos|AuxS/ or
$node
->{is_member}) {
$node
=
$node
->parent;
if
(!
$node
) {
print
STDERR
"GetEParents: Error - no coordination head $init_node->{AID}: "
.ThisAddress(
$init_node
).
"\n"
;
return
();
}
elsif
(
$node
->{afun} eq
'AuxS'
) {
print
STDERR
"GetEParents: Error - no coordination head $node->{AID}: "
.ThisAddress(
$node
).
"\n"
;
return
();
}
}
}
if
(
&$through
(
$node
->parent)) {
while
(
$node
and
&$through
(
$node
->parent)) {
$node
=
$node
->parent;
}
}
return
unless
$node
;
$node
=
$node
->parent;
return
unless
$node
;
return
$node
if
$node
->{afun}!~/Coord|Apos/;
A_ExpandCoordGetEParents(
$node
,
$through
);
}
sub
A_FilterEChildren{
my
(
$node
,
$dive
,
$suff
,
$from
)=
@_
;
my
@sons
;
$node
=
$node
->firstson;
while
(
$node
) {
unless
(
$node
==
$from
){
if
(!
$suff
&
&$node
->{afun}=~/Coord|Apos/&&!
$node
->{is_member}
or
$suff
&
&$node
->{afun}=~/Coord|Apos/&
&$node
->{is_member}) {
push
@sons
,A_FilterEChildren(
$node
,
$dive
,1,0)
}
elsif
(
&$dive
(
$node
) and
$node
->firstson){
push
@sons
,A_FilterEChildren(
$node
,
$dive
,
$suff
,0);
}
elsif
((
$suff
&
&$node
->{is_member})
||(!
$suff
&&!
$node
->{is_member})){
push
@sons
,
$node
;
}
}
$node
=
$node
->rbrother;
}
@sons
;
}
sub
AGetEChildren{
my
(
$node
,
$dive
)=
@_
;
return
()
if
!
$node
or
$node
->{afun}=~/^(?:Coord|Apos|Aux[SCP])$/;
my
@sons
;
my
$from
;
$dive
=
sub
{ 0 }
unless
defined
(
$dive
);
push
@sons
,A_FilterEChildren(
$node
,
$dive
,0,0);
if
(
$node
->{is_member}){
my
@oldsons
=
@sons
;
while
(
$node
->{afun}!~/Coord|Apos|AuxS/ or
$node
->{is_member}){
$from
=
$node
;
$node
=
$node
->parent;
push
@sons
,A_FilterEChildren(
$node
,
$dive
,0,
$from
);
}
if
(
$node
->{afun} eq
'AuxS'
){
print
STDERR
"Error: Missing Coord/Apos: $node->{id} "
.ThisAddress(
$node
).
"\n"
;
@sons
=
@oldsons
;
}
}
return
@sons
;
}
sub
ExpandCoord {
my
(
$node
,
$keep
)=
@_
;
return
unless
$node
;
if
(IsCoord(
$node
)) {
return
((
$keep
?
$node
: ()),
map
{ ExpandCoord(
$_
,
$keep
) }
grep
{
$_
->{is_member} }
$node
->children);
}
else
{
return
(
$node
);
}
}
sub
IsCoord {
my
$node
=
$_
[0];
return
0
unless
$node
;
return
0
if
$node
->{nodetype} eq
'root'
;
return
$node
->{functor} =~ /ADVS|APPS|CONFR|CONJ|CONTRA|CSQ|DISJ|GRAD|OPER|REAS/;
}
sub
TGetEParents {
my
$node
=
$_
[0];
return
()
if
IsCoord(
$node
);
if
(
$node
and
$node
->{is_member}) {
while
(
$node
and (!IsCoord(
$node
) or
$node
->{is_member})) {
$node
=
$node
->parent;
}
}
return
()
unless
$node
;
$node
=
$node
->parent;
return
()
unless
$node
;
return
(
$node
)
if
!IsCoord(
$node
);
return
(ExpandCoord(
$node
));
}
sub
T_FilterEChildren {
my
(
$node
,
$suff
,
$from
)=
@_
;
my
@sons
;
$node
=
$node
->firstson;
while
(
$node
) {
unless
(
$node
==
$from
){
if
((
$suff
&
&$node
->{is_member})
||(!
$suff
&&!
$node
->{is_member})){
push
@sons
,
$node
unless
IsCoord(
$node
);
}
push
@sons
,T_FilterEChildren(
$node
,1,0)
if
(!
$suff
&
&IsCoord
(
$node
)
&&!
$node
->{is_member})
or(
$suff
&
&IsCoord
(
$node
)
&
&$node
->{is_member});
}
$node
=
$node
->rbrother;
}
return
@sons
;
}
sub
TGetEChildren {
my
$node
=
$_
[0];
return
()
if
IsCoord(
$node
);
my
@sons
;
my
$init_node
=
$node
;
my
$from
;
push
@sons
,T_FilterEChildren(
$node
,0,0);
if
(
$node
->{is_member}){
my
@oldsons
=
@sons
;
while
(
$node
and
$node
->{nodetype} ne
'root'
and (
$node
->{is_member} || !IsCoord(
$node
))){
$from
=
$node
;
$node
=
$node
->parent;
push
@sons
,T_FilterEChildren(
$node
,0,
$from
)
if
$node
;
}
if
(
$node
->{nodetype} eq
'root'
){
stderr(
"Error: Missing coordination head: $init_node->{id} $node->{id} "
,ThisAddressNTRED(
$node
),
"\n"
);
@sons
=
@oldsons
;
}
}
return
@sons
;
}
sub
ThisAddress {
my
(
$node
) =
@_
;
my
$type
=
$node
->type;
my
(
$id_attr
) =
$type
&&
$type
->find_members_by_role(
'#ID'
);
return
'#'
.
$node
->{
$id_attr
->get_name }
}
sub
ThisAddressNTRED {
my
(
$node
) =
@_
;
return
'#???'
}
1;