---

Jeg puslede for nogen tid siden med at implementere NetBSD's rcorder
program i Korn shell (vha tsort.) I den forbindelse søgte jeg hist og pist
om info om tsort, og faldt over et sted jeg kan anbefale alle at besøge:
Jeffrey Copeland og Jeffrey Haemers "Work" klumme på
<http://www.alumni.caltech.edu/~copeland/work/>

Bla. havde de en gennemgang af en løsning til et problem der var blevet
postet på comp.lang.misc en gang; en løsning hvortil de brugte topologisk
sortering. De havde derfor også en Perl implementation. Deres Perl
implementation af tsort kunne valgfrit køre med enten en kø eller en stak
til at hive næste element ud. Jeg havde selv tænkt over det samme, fordi
min rcorder implementation ikke gav samme resultat som NetBSD's, fordi der
naturligvis er mange permutationer der kan opfylde kravet for en
topologisk sortering. Men når både en kø og en stak kan bruges, så er der
en stemme (Jeg kan ikke mere huske om stemmen tilhører Michael
Schwartzbach eller Erik Meineche Schmidt) i mit hoved der siger:
"Prioritetskø".

Men hvad kan man bruge en prioritetskø til i tsort? Kan det ikke være lige
meget hvilken orden man hiver ting ud i? Jeg tænkte en smule over det og
kom op med følgende.

Først en hurtigt implementeret prioritetskø, jeg ved at CPAN har Heap
klasser i alskens afskygninger, men jeg må indrømme at jeg synes det ofte
er overkill at bruge OOP i Perl til noget så simpelt. Her er først min
PQ.pm, ikke særlig idiomatisk, og den kan sikkert pyntes på mange måder.
(Ja, der mangler en masse tingeltangel med EXPORT_OK osv, men ærligt talt
så betragter jeg det mest som bureaukratisk pis. Og jeg hader
bureaukratisk pis!)

#! /usr/pkg/bin/perl -w
use strict;

package PQ;

my $cmpfun = sub{ my($a,$b) = @_; return $a cmp $b };

sub setcmp {
$cmpfun = shift;
}

sub put(\@$) {
my($queue) = shift;
my($elem) = shift;
my $x = scalar @{$queue};
while($x > 0 and pqcmp($elem, $queue->[($x-1)/2]) < 0) {
$queue->[$x] = $queue->[($x-1)/2];
$x = ($x-1)/2;
}
$queue->[$x] = $elem;
}

sub get(\@) {
my($queue) = shift;
return undef unless scalar @{$queue};
my($elem) = $queue->[0];
my $n = scalar(@{$queue})-1;
my($x,$bb) = (0,0);
do{
$queue->[$x] = $queue->[$bb];
$x = $bb;
if(2*$x+2 < $n) {
$bb = pqcmp($queue->[2*$x+1],$queue->[2*$x+2])<0?
2*$x+1 : 2*$x +2;
} else { $bb = 2*$x+1 }
} while($bb < $n and pqcmp($queue->[$bb],$queue->[$n]) < 0 );
$queue->[$x] = $queue->[$n];
delete $queue->[$n];
return $elem;
}

sub peek(\@) {
my($queue) = shift;
return undef unless scalar @{$queue};
return $queue->[0];
}

sub pqcmp {
my($a,$b) = @_;
return $cmpfun->($a,$b);
}

sub test {
my @q;
while(<>) {
chomp;
put(@q, $_) if $_ ne ".";
print get(@q),"\n" if $_ eq ".";
print '@q = (',join(",",@q),")\n";
}
}

1;


OK. Det burde være velkendt for enhver, så jeg vil ikke fornærme nogens
intelligens med forklaringer. Videre til Tsort.pm:

#! /usr/pkg/bin/perl -w
use strict;

package TSort;
use PQ;
use Carp qw(croak carp);

my $remove_callback = undef;

sub tsort {
my @result = ();
my %succ;
my %npred;
PQ::setcmp(shift @_) if($_[0] eq "cmp" and shift @_);
$remove_callback = shift @_ if($_[0] eq "remove" and shift @_);

croak "tsort: Odd number of elements in argument list" if (scalar @_)%2;
while(my $l = shift @_) {
my $r = shift @_;
next if grep { $_ eq $r } @{$succ{$l}};
$npred{$l} += 0;
next if $l eq $r;
$npred{$r} += 1;
push @{$succ{$l}},$r;
}

my @removable = ();
for my $i (keys %npred) {
PQ::put @removable, $i unless $npred{$i};
}

while(@removable) {
#print "removable now: ",join(",",@removable),"\n";
my $i = PQ::get @removable;
$remove_callback->($i) if $remove_callback;
push @result, $i;
for my $d (@{$succ{$i}}) {
PQ::put @removable, $d unless --$npred{$d};
}
}

my @cycles = grep {$npred{$_}} keys %npred;
carp "tsort: cycles in ".join(",",@cycles) if @cycles;
return @result;
}

sub test {
my @list = ();
if($ARGV[0] eq "DATA") { print "Reading DATA..\n"; while(<DATA>) {
chomp; push @list,split/ /; } }
else { while(<>) { chomp; push @list,split/ /; } }
print "cmp alphabetically\n";
print map { "$_\n" } tsort(@list);
print 'cmp reverse alphabetically -($a cmp $b)'."\n";
PQ::setcmp(sub{return -($a cmp $b)});
print map { "$_\n" } tsort(@list);
print "cmp always returns -1\n";
PQ::setcmp(sub{return -1});
print map { "$_\n" } tsort(@list);
print "cmp always returns 1\n";
PQ::setcmp(sub{return 1});
print map { "$_\n" } tsort(@list);
}

1;
__DATA__
a a a b c d b c a e a b b z h h aa aa

For kort og godt at forklare: tsort er en funktion der tager et array med
et lige antal elementer, samt evt to funktioner (som jeg vender tilbage
til). Arrayets elementer betragtes som par, således at @_[$i] er en
forudsætning for @[$i+1] for alle lige $i. Resultatet er en ordning af
inputarrayet, som sikrer at intet element optræder i listen før nogen af
dets forudsatte elementer.

Algoritmen er enkel: elementer uden nogen forudsætninger kan fjernes
straks. Derefter kan alle afhængige elementer fjernes hvis det element der
netop blev fjernet, var den sidste forudsætning. For at være generel, kan
man sætte sin egen komparatorfunktion, samt en callbackfunktion, der
bliver kaldt når et element blev fjernet fra prioritetskøen.

Men hvad kan det bruges til?
Hvis nu man har nogle opgaver, der hver især tager et stykke tid, og som
kan have indbyrdes afhængigheder, så kan man bruge det til at lave en plan
for disse opgaver. Så vidt jeg kan vurdere virker nedenstående program
efter hensigten, men det er netop min mening med at poste alt dette, at
jeg gerne vil vide om jeg tager fejl.

Her er så. uden omsvøb, med forbehold, og i håb om konstruktive
kommentarer og kritik, Sched.pm:

#! /usr/pkg/bin/perl -w
use strict;
use TSort;
#TASK
# Tasks1:
# AAAAAE DD
# BBB CCCF
# GGGGGGGGG
# ie

my $task1 = {
A => {req => [], duration => 5},
B => {req => [], duration => 3},
C => {req => [qw(A B)], duration => 3},
D => {req => [qw(C)], duration => 2},
E => {req => [qw(A)], duration => 1},
F => {req => [qw(C E)], duration => 1},
G => {req => [], duration => 9},
};
#ENDTASK

my $timestep = 0;

sub eventcmp {
my($a,$b) = @_;
# return -1 if $a is less than (comes before) $b
# return 0 if either
# return 1 if $a is greater than (comes after) $b
# $a and $b are names of events

# any start event comes before any end event (an end event ends
with a "/")
return -1 if $a !~ m|/| and $b =~ m|/|; # $a is a start event, $b is not
return 1 if $a =~ m|/| and $b !~ m|/|; # $a is not a start event, $b is


# of two start events, the order doesn't really matter
return 0 if $a !~ m|/|;;

# of two end events, the one which finishes sooner comes first,
# and in the callback the timestep is set to the endtime when
# an end event is removed
chop $a; chop $b;
#print "a is $a b is $b\n";
if($task1->{$a}->{"endtime"} < $task1->{$b}->{"endtime"}) {
return -1;
}
else {
return 1;
}
}

sub remove_callback {
# the callback runs BEFORE the end event of a removed start event
is put on the
# removable-queue, therefore all necessary data for the eventcmp
function is present
my($t) = @_;
#print "$t is a start event, it starts NOW at t=$timestep\n" if $t
!~ m|/|;

if($t !~ m|/|) {
$task1->{$t}->{"starttime"} = $timestep;
$task1->{$t}->{"endtime"} = $timestep +
$task1->{$t}->{"duration"};
}
else {
chop $t;
$timestep = $task1->{$t}->{"endtime"};
#print "$t/ is an end event, and the task ends NOW at
t=$timestep\n";
}
}

sub sched {
my @events = ();
for my $t (keys %$task1) {
for my $r (@{ $task1->{$t}->{"req"} }) {
push @events, "$r/", $t; # t depends on end event of r
}
push @events, $t, "$t/" # end event of t depends (only) on t
}
my $i;
#print join("",map { $i++%2?"-$_":" $_"} @events),"\n";
TSort::tsort(cmp => \&eventcmp, remove => \&remove_callback, @events);
}

sched();
print "t 0 1 2 3 4 5 6 7 8 9\n";

for my $t (keys %{$task1}) {
print "$t:";
print " " x $task1->{$t}->{"starttime"};
print "[]" x $task1->{$t}->{"duration"},"\n";
}

Som motivation for kommentarer vil jeg slutte med at udlove en halv liter
af Bryggeriets bedste øl til den Århus-perlmonger, der måtte komme med den
mest interessante kommentar. Jeg afgør dog suverænt hvilken kommentar -
eller om der overhovedet er nogen der opfylder betingelsen.

-Lasse

Denne artikel er Copyright (C) 2002 by Lasse Hillerøe Petersen.
Perl-koden kan frit anvendes jævnfør Perls "Artistic License".