Search code examples
algorithmperlgraphperl-data-structurestopological-sort

How do I sort a parent-child list given a node relations data structure?


This drawing shows a tree of parent-child relationships. It is directed, without cycles. A child can have multiple parents.

The corresponding array of arrays in Perl is:

(
    [A C],
    [B C],
    [D F G],
    [C E D],
    [E J X I],
    [I J]
)

The first element in each sub-array is the parent of the rest, and the number of sub-arrays is the number of nodes who have at least one child.

Problem

I want to assign a number to each node which tells which level it is on in the graph. The level should also tell whether two nodes are independent, by which I mean they are not in direct parent-child relation. The answer to this specific example should (among many other answers) be:

[A B C D E F G X I J]
[1 1 2 3 3 4 4 4 4 5]

I solution can be implemented in any language, but Perl is preferred.

Still, non of the suggested solutions seems to work for this array:

(
  [ qw( Z A   )],
  [ qw( B D E ) ],
  [ qw( A B C ) ],    
  [ qw( G A E  )],
  [ qw( L B E )]  
)

as does

(
  [ qw/ M A / ],
  [ qw/ N A X / ],
  [ qw/ A B C / ],
  [ qw/ B D E / ],
  [ qw/ C F G / ], 
  [ qw/ F G / ]
  [ qw/ X C / ]
)

Solution

  • Finally, I think I have solved the problem of finding correct levels, using Borodin's and ikegami's solutions (thanks guys, highly appreiciate your efforts):

    #!/usr/local/perl -w 
    
    use strict;
    use warnings;
    use Graph::Directed;
    use List::Util qw( min max );
    
    # my @data = (
    # [ qw/ M A/ ],
    # [ qw/ N A X/ ],
    # [ qw/ A B C / ],
    # [ qw/ B D E F/ ],
    # [ qw/ C F G / ], 
    # [ qw/ F G / ],
    # [ qw/ X C G/ ],
    # [ qw/ L A B /],
    # [ qw/ Q M D/]
    # );
    
    # my @data = (
    # [ qw( Z A   )],
    # [ qw( B D E ) ],
    # [ qw( A B C ) ],    
    # [ qw( G A E  )],
    # [ qw( L B E )]  
    # );
    
    # my @data = (
    # [ qw/ M A / ],
    # [ qw/ N A X / ],
    # [ qw/ A B C / ],
    # [ qw/ B D E / ],
    # [ qw/ C F G / ], 
    # [ qw/ F G / ],
    # [ qw/ X C / ]
    # );
    
    my @data = (
    [ qw/ A M B C/ ],
    [ qw/ B D F C/ ],
    [ qw/ D G/ ],
    [ qw/ F G/ ],
    [ qw/ C G/ ],
    [ qw/ M G/ ],  
    );
    
    
    sub createGraph{
    my @data = @{$_[0]};
    my $graph = Graph->new(directed => 1);
    
    foreach (@data) {
      my ($parent, @children) = @$_;
      $graph->add_edge($parent, $_) for @children;
    }
    
    my @cycleFound = $graph->find_a_cycle;    
    print "$_\n" for (@cycleFound);
    $graph->is_dag() or die("Graph has cycles - unable to sort\n");
    $graph->is_weakly_connected() or die "Graph not weakly connected - unable to analyze\n";  
    return $graph;
    }
    
    sub getLevels{
    my @data = @{$_[0]};
    my $graph = createGraph \@data;
    
    my @artifacts = $graph->topological_sort();
    chomp @artifacts; 
    print "--------------------------\n";
    print "Topologically sorted list: \n";
    print "$_ " for @artifacts;        
    print "\n--------------------------\n";
    
    print "Initial levels (longest path):\n";
    my @sources = $graph->source_vertices;
    my %max_levels = map { $_=>[]} @artifacts;
    my @levels = ();
    for my $vertex (@artifacts) {
        my $path = 0;
        foreach(@sources){
            if(defined($graph->path_length($_, $vertex))){
                if ($graph->path_length($_, $vertex) > $path){
                    $path = $graph->path_length($_, $vertex)
                }
            }
        }
     printf "%s - %d\n", $vertex, $path;
     push @levels, $path;
     push @{$max_levels{$vertex}}, $path;
    }
    print "--------------------------\n";
    
    for (my $i = 0; $i < @levels; $i++){ 
    my $parent_level = $levels[$i];
    my $parent = $artifacts[$i];                
        for (my $j = $i+1; $j < @levels; $j++){ 
            my $child = $artifacts[$j];
            for (@data){
                my ($p, @c) = @{$_};
                if($parent eq $p){
                    my @matches = grep(/$child/, @c);
                    if(scalar(@matches) != 0){
                        $levels[$j]  = 1 + $parent_level;
                        push @{$max_levels{$child}},$levels[$j];
                        $levels[$j] = max @{$max_levels{$child}};
                    }
                }
            }
        }            
    }
    print "Final levels:\n";
    my %sorted = ();
    for (my $i = 0; $i < @levels; $i++){
        $sorted{$artifacts[$i]} = $levels[$i];
    }
    my @orderedList = sort { $sorted{$a} <=> $sorted{$b} } keys %sorted;
    print "$sorted{$_} $_\n" for @orderedList;
    print "--------------------------\n";   
    return  \%max_levels;
    }
    
    getLevels \@data;
    

    Output:

        --------------------------
        Topologically sorted list:
        A M B D C F G
        --------------------------
        Initial levels (longest path):
        A - 0
        M - 1
        B - 1
        D - 2
        C - 1
        F - 2
        G - 2
        --------------------------
        Final levels:
        0 A
        1 M
        1 B
        2 F
        2 C
        2 D
        3 G
        --------------------------