Learn the order of elements - perl

Question

I want to find an efficient way (in Perl preferably) to learn the fixed order of a family of words by comparing their order in multiple subsets of the group.
(They are job parameters. There are about 30 different ones. Different jobs need different combinations of parameters & there are only ever a few parameters in each job)
For example, given:
first
second
third
sixth
seventh
tenth
first
third
fourth
fifth
sixth
third
fifth
seventh
eighth
ninth
tenth
It should be able to remember the relative order relationships it sees to work out that the order is:
first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth
I have generated lists like:
first.second.third.sixth.seventh.tenth
first.third.fourth.fifth.sixth
third.fifth.seventh.eighth.ninth.tenth
then sorted uniquely + alphabetically and visually compared them, but I have hundreds of different combinations of the 30ish parameters, so it will be a big job to sort through them all and put them together manually.
I think #daniel-tran has answered the "how" in https://stackoverflow.com/a/48041943/224625 and using that and some hackery like:
$order->{$prev}->{$this} = 1;
$order->{$this}->{$prev} = 0;
I've managed to populate a hash of hashes with a 1 or a 0 for each pair of consecutive parameters to say which comes first, like:
$VAR1 = {
'first' => {
'second' => 1,
'third' => 1,
},
'second' => {
'first' => 0,
'third' => 1,
},
'third' => {
'first' => 0,
'second' => 0,
'fourth' => 1,
'fifth' => 1,
'sixth' => 1,
},
'fourth' => {
'third' => 0,
'fifth' => 1,
},
...
but I hit the wall trying to work out what to do in my sort function when it's asked to sort a pair that have never been seen as immediate neighbours, thus don't have a relationship defined.
Is there an easy solution?
Am I going about this the right way?
Is there a better WTDI in the first place?
Thanks,
John

Answer 1

The question you linked to includes another answer using a graph and topological sort. The Graph module is pretty easy to use:
use warnings;
use strict;
use Graph;
my $graph = Graph->new(directed => 1);
my $prev;
while (<DATA>) {
chomp;
$graph->add_edge($prev, $_) if length && length $prev;
$prev = $_;
}
print $_,"\n" for $graph->topological_sort;
__DATA__
first
second
third
sixth
seventh
tenth
first
third
fourth
fifth
sixth
third
fifth
seventh
eighth
ninth
tenth
Output:
first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth

Answer 2

I tried to implement a naive solution myself. I built the %order hash where the values of each key were the elements that followed it. I then created a transitive closure of this structure (i.e. if first was before second and second was before third, then first must be before third). If there was enough information, each key would have a different number of values, and sorting the elements by the number of the values would give the ordered list.
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my #partial = (
[qw[ first second third sixth seventh tenth ]],
[qw[ first third fourth fifth sixth ]],
[qw[ third fifth seventh eighth ninth tenth ]]);
my %order;
my %all;
for my $list (#partial) {
undef #all{ #$list };
undef $order{ $list->[ $_ - 1 ] }{ $list->[$_] }
for 1 .. $#$list;
}
my $changed = 1;
while ($changed) {
undef $changed;
for my $from (keys %order) {
if (my #to = keys %{ $order{$from} }) {
if (my #to2 = map keys %{ $order{$_} }, #to) {
my $before = keys %{ $order{$from} };
undef #{ $order{$from} }{#to2};
$changed = 1 if $before != keys %{ $order{$from} };
}
}
}
}
my %key_counts;
$key_counts{ keys %{ $order{$_} } }++ for keys %order;
warn "Not enough information\n"
if keys %key_counts != keys %order;
say join ' ',
sort { keys %{ $order{$b} } <=> keys %{ $order{$a} } }
keys %order;
output
first second third fourth fifth sixth seventh eighth ninth tenth

Answer 3

This is a direct and simple-minded manual solution.
It collects all elements in given sub-sequences and sorts them. The sorting criterion is the position (index) of compared elements in the first sub-sequence that has both. If none of the sub-sequences have both elements an undecided (zero) is returned from the sort's block.
use warnings;
use strict;
use feature 'say';
use List::MoreUtils qw(uniq firstval);
my #all = qw(ant bug frog cat dog elk); # to draw input (sublists) from
my #s1 = #all[0,1,3,5];
my #s2 = #all[1,2,4,5];
my #s3 = #all[2,3,4];
my #inv = ( # for index comparison
{ map { $s1[$_] => $_ } 0..$#s1 },
{ map { $s2[$_] => $_ } 0..$#s2 },
{ map { $s3[$_] => $_ } 0..$#s3 }
);
my #sorted = sort {
my $fv = firstval { exists $_->{$a} and exists $_->{$b} } #inv;
($fv) ? $fv->{$a} <=> $fv->{$b} : 0;
} uniq #s1, #s2, #s3;
say "#sorted";
The complexity of this isn't as good as it can be since some of the comparisons can (in principle) be avoided but that doesn't show for smaller problems. It prints the correct sequence, and for the posted problem as well (replace #sN arrays with the ones provided in the question).
This code assumes consistent and complete enough subsequences.
For an arbitrary number of subsets of the full list (3 above) the ancillary #inv is built as
my #subseqs = (\#s1, \#s2, \#s3);
my #inv;
for my $rr (#subseqs) {
push #inv, { map { $rr->[$_] => $_ } 0..$#$rr }
}