Re: Merge lists of ordered strings into canonical ordering

#!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11161855
use warnings;
use List::AllUtils qw( min_by nsort_by );
$SIG{__WARN__} = sub { die @_ };

my @list1= qw( K B I S Y A Q );
my @list2= qw( B S N A );
my @list3= qw( Y N Q );
my $combined= fancy_algorithm(\@list1, \@list2, \@list3);
use Data::Dump 'dd'; dd 'combined', $combined;

my @lists= (
  [qw( X P Y )],
  [qw( X B Y N )],
  [qw( P B N )],
  [qw( X B P N )],
  [qw( X B P Y )],
  [qw( A Z )],
  [qw( A K L )],
);
$combined= fancy_algorithm(@lists);
use Data::Dump 'dd'; dd 'combined', $combined;

sub fancy_algorithm
  {
  my (%names, @order);
  @names{ @$_ } = () for my @args = @_;
  use Data::Dump 'dd'; dd 'input', \@args;
  while( @args )
    {
    my %names;
    my $see = 1;
    $names{$_} += $see++ for map @$_, @args;
    my @names = nsort_by { $names{$_} } sort +keys %names;
    my %score;
    for ( @args )
      {
      my ($head, @rest) = @$_;
      $score{$head} -= 1e9;
      $score{$_} //= 0 for @rest;
      }
    my $pick = min_by { $score{$_} } @names;
    push @order, $pick;
    $_ = [ grep $pick ne $_, @$_ ] for @args;
    @args = grep @$_, @args;
    }
  return \@order;
  }
[download]

Outputs:

(
  "input",
  [
    ["K", "B", "I", "S", "Y", "A", "Q"],
    ["B", "S", "N", "A"],
    ["Y", "N", "Q"],
  ],
)
("combined", ["K", "B", "I", "S", "Y", "N", "A", "Q"])
(
  "input",
  [
    ["X", "P", "Y"],
    ["X", "B", "Y", "N"],
    ["P", "B", "N"],
    ["X", "B", "P", "N"],
    ["X", "B", "P", "Y"],
    ["A", "Z"],
    ["A", "K", "L"],
  ],
)
("combined", ["X", "B", "P", "Y", "N", "A", "Z", "K", "L"])
[download]

Comment on Re: Merge lists of ordered strings into canonical ordering Select or Download Code

Replies are listed 'Best First'.
Re^2: Merge lists of ordered strings into canonical ordering by NERDVANA (Priest) on Sep 20, 2024 at 05:47 UTC
Very interesting! It took me a while to figure out what you were doing here - basically just assuming that the next in the sequence must be found at the start of the remaining options, choosing one that is either the most occurrences at starts of remaining lists or first seen, removing it from the options, then repeat? It seems like you can simplify that a bit though. (I'm not sure what the 1e9 was about unless that was from an earlier attempt?) `sub fancy_algorithm { my @args= @_; p @args; my @order; while (@args) { my ($pick, %score, %seen_order); my $see = 1; $seen_order{$_} += $see++ for map @$_, @args; for (@args) { my $n= --$score{$_->[0]}; $pick= $_->[0] if !defined $pick or $n < $score{$pick} or $n == $score{$pick} && $seen_order{$_->[0]} < $seen_ord +er{$pick}; } push @order, $pick; $_ = [ grep $pick ne $_, @$_ ] for @args; @args = grep @$_, @args; } return \@order; }` [download] It seems to work in every case I've tried, though it gives less ideal results with: `my @lists= ( [qw( S T )], [qw( S U )], [qw( Y Z )], [qw( X Y )], [qw( W X )], [qw( V W )], [qw( U V )], ); # S U V W X Y T Z` [download]	[reply] [d/l] [select]

Replies are listed 'Best First'.

Re^2: Merge lists of ordered strings into canonical ordering
by NERDVANA (Priest) on Sep 20, 2024 at 05:47 UTC

sub fancy_algorithm {
   my @args= @_;
   p @args;
   my @order;
   while (@args) {
      my ($pick, %score, %seen_order);
      my $see = 1;
      $seen_order{$_} += $see++ for map @$_, @args;
      for (@args) {
         my $n= --$score{$_->[0]};
         $pick= $_->[0] if !defined $pick or $n < $score{$pick}
            or $n == $score{$pick} && $seen_order{$_->[0]} < $seen_ord
+er{$pick};
      }
      push @order, $pick;
      $_ = [ grep $pick ne $_, @$_ ] for @args;
      @args = grep @$_, @args;
   }
   return \@order;
}
[download]

It seems to work in every case I've tried, though it gives less ideal results with:

my @lists= (
  [qw( S T )],
  [qw( S U )],
  [qw( Y Z )],
  [qw( X Y )],
  [qw( W X )],
  [qw( V W )],
  [qw( U V )],
);

# S U V W X Y T Z
[download]

[reply]
[d/l]
[select]