package DAG; use strict; use warnings; use Graph::Directed; use Carp; use base 'Graph::Directed'; sub new { my ( $self, %args ) = @_; $args{multiedged} = 1; my $obj = $self->SUPER::new(%args); return $obj; } sub set_parents { my ( $self, $p1, $p2, $c, $checks ) = @_; $checks ||=1; if ( ( $self->in_degree($c) || 0) > 0) { croak "already has parents"; } $self->add_edge_by_id($p1, $c, 1); $self->add_edge_by_id($p2, $c, 2); if ($checks && !$self->is_dag()) { $self->delete_edge_by_id($p1, $c, 1); $self->delete_edge_by_id($p2, $c, 2); croak 'Not a DAG anymore'; } return $self; } #### ... sub is_ancestor { my ( $self, $v1, $v2 ) = @_; for my $child ( $self->get_successors($v1) ) { return 1 if $child eq $v2; } for my $child ( $self->get_successors($v1) ) { my $found = $self->is_ancestor( $child, $v2 ); return 1 if $found; } return 0; } sub set_parents { my ( $self, $p1, $p2, $c, $checks ) = @_; $checks ||=1; if ( ( $self->in_degree($c) || 0) > 0) { croak "already has parents"; } $self->add_edge_by_id($p1, $c, 1); if ($checks && $self->is_ancestor($c, $p1)) { $self->delete_edge_by_id($p1, $c, 1); croak 'Not a DAG anymore'; } $self->add_edge_by_id($p2, $c, 2); if ($checks && $p1 ne $p2 && $self->is_ancestor($c, $p2)) { $self->delete_edge_by_id($p2, $c, 2); croak 'Not a DAG anymore'; } return $self; } #### P1 --+ +--> Child P2 --+