1: # This is essentially a copy of an old writeup of mine on Everything2. 2: # 3: # Here's an implementation of a [topological sort] in Perl. 4: # It's reasonably terse, and even has some comments! 5: # 6: # Pass it as input a list of array [reference]s; these 7: # specify that that index into the list must come before all 8: # elements of its array. Output is a topologically sorted 9: # list of indices, or undef if input contains a cycle. Note 10: # that you <em>must</em> pass an array ref for every input 11: # elements (if necessary, by adding an empty list 12: # reference)! 13: # 14: # For instance, tsort ([1,2,3], [3], [3], []) returns 15: # (0,2,1,3). 16: 17: sub tsort { 18: my @out = @_; 19: my @ret; 20: 21: # Compute initial in degrees 22: my @ind; 23: for my $l (@out) { 24: ++$ind[$_] for (@$l) 25: } 26: 27: # Work queue 28: my @q; 29: @q = grep { ! $ind[$_] } 0..$#out; 30: 31: # Loop 32: while (@q) { 33: my $el = pop @q; 34: $ret[@ret] = $el; 35: for (@{$out[$el]}) { 36: push @q, $_ if (! --$ind[$_]); 37: } 38: } 39: 40: @ret == @out ? @ret : undef; 41: } 42:

Back to
Craft