sub concensus_sort { my( %pre, %suf ); for my $ar ( @_ ) { my @a = @$ar; my @pre; while ( @a ) { my $k = shift @a; $pre{$k} ||= {}; $suf{$k} ||= {}; $pre{$k}{$_}++ for @pre; $suf{$k}{$_}++ for @a; push @pre, $k; } } if ( $main::DEBUG ) { for ( keys %pre ) { for my $p ( keys %{ $pre{$_} } ) { if ( exists $pre{$p}{$_} ) { print "$_-$p AND $p-$_ !!!\n"; } } } } my @result; for my $k ( sort { keys(%{$pre{$a}}) <=> keys(%{$pre{$b}}) or keys(%{$suf{$a}}) <=> keys(%{$suf{$b}}) } keys %suf ) { push @result, $k; # now remove all trace of it in the data structures: delete $pre{$_}{$k} for keys %{ $suf{$k} }; delete $suf{$_}{$k} for keys %{ $pre{$k} }; delete $pre{$k}; delete $suf{$k}; } @result }