tsort.pl

From Club Ubuntu

use strict;
use warnings;
use Data::Dumper;

sub clean(\%) {
  my $graph = shift;
  for (values %$graph) {
    @$_ = keys %{ { map { $_, 1 } @$_ } };
    $graph->{$_} ||= [] for @$_;
  }
  return %$graph;
}

sub unconnected(%) {
  my %graph = @_;
  delete @graph{map { @$_ } values %graph};
  return keys %graph;
}

sub merge_into(\%%) {
  my ($graph1, %graph2) = @_;
  push @{$graph1->{$_}}, @{$graph2{$_}} for keys %graph2;
  clean %$graph1;
}

sub toposort(\%;\@) {
  my ($graph, $remaining_nodes) = @_;
  my %graph = %$graph;

  my @items;

  while (my @unconnected = unconnected %graph) {
    my @sched = splice(@unconnected, 0, scalar @unconnected);
    push @items, [@sched];
    delete @graph{@sched};
  }

  @$remaining_nodes = keys %graph if defined $remaining_nodes;

  return @items;
}

sub prio_graph(%) {
  my %prio = @_;
  my @prio = @prio{sort {$a <=> $b} keys %prio};

  return unless @prio;

  my %graph;

  for my $i (0 .. $#prio) {
    my ($current, @next) = @prio[$i .. $#prio];
    for (@$current) {
      push @{$graph{$_}}, map { @$_ } @next;
    }
  }

  return clean %graph;
}

my %graph = (
  a => ['b', 'q'],
  b => ['c'],
  d => ['e'],
  q => ['d'],
  x => ['y'],
  y => ['x'] );

clean %graph;

my %prio = (5 => ['q', 'e'], 7 => [], 10 => ['z', 'f', 'r']);

merge_into %graph, prio_graph(%prio);

my @items = toposort %graph, my @cyclical;

print Dumper(\@items, \@cyclical), "\n";

%graph = ('A' => ['B'], 'B' => ['C'], M => ['N'], X => ['Y'], 'Y' => ['Z']);
clean %graph;

my @items = toposort %graph;

print Dumper(\@items);