Re: Pairing the pairs

You may want to consider changing your pairing sub. Observe: (readmore is for comparison)

sub get_pairs {
  my %hash = ();
  $hash{$_}++ foreach @_;
  my @keys = sort { $hash{$b} <=> $hash{$a} } keys %hash;
  my $counter = 0;
  
  foreach my $x (0..$#keys - 1) {
    next unless $hash{$keys[$x]};
    foreach my $y ($x+1..$#keys) {
      last unless $hash{$keys[$x]};
      next unless $hash{$keys[$y]};
      $counter++;
      print "$counter = ",($keys[$x] < $keys[$y] ? "$keys[$x] $keys[$y
+]":"$keys[$y] $keys[$x]"),$/;
      $hash{$keys[$x]}--;
      $hash{$keys[$y]}--;
    }
  }
  print "$counter counts$/"  print "$counter counts$/"
  print Dumper(\%hash); #to see how many matches are made
}

get_pairs(@array);

__DATA__
1 = 3 6
2 = 4 6
3 = 1 6
4 = 6 7
5 = 5 6
6 = 6 8
7 = 2 6
8 = 3 4
9 = 1 3
10 = 3 7
11 = 3 5
12 = 3 8
13 = 1 4
14 = 4 7
15 = 4 5
16 = 4 8
17 = 1 7
17 counts
$VAR1 = {
          '6' => 0,
          '8' => 0,
          '4' => 0,
          '1' => 0,
          '3' => 1,
          '7' => 0,
          '2' => 0,
          '5' => 1
        };
[download]

Your code produces the following results:

1 = 1 2
2 = 1 3
3 = 1 4
4 = 1 5
5 = 3 4
6 = 3 5
7 = 3 6
8 = 3 7
9 = 3 8
10 = 4 5
11 = 4 6
12 = 4 7
13 = 4 8
14 = 5 6
15 = 6 7
16 = 6 8
Counts 16
$VAR1 = {
          '6' => 2,
          '8' => 0,
          '4' => 0,
          '1' => 0,
          '3' => 1,
          '7' => 1,
          '2' => 0,
          '5' => 0
        };
[download]

So what gives? In the sub I provided, the matching attempts to get rid of the largest groups first since these groups are more likely to create the most pairs.

Update: I decided to put a complete solution together along with a comparison of the two subs.

#!/usr/bin/perl

use strict;
use warnings;
my $Z;
my @array;
foreach (1..36){
    $Z->{1 + int rand(8)}++;
}

foreach (sort { $Z->{$a} <=> $Z->{$b}} keys %{$Z}){
    my $element = $_;
    foreach (1..$Z->{$element}){
    push @array, $element;
    }
}


@array = qw(2 8 8 8 1 1 1 1 5 5 5 5 7 7 7 7 4 4 4 4 4 4 3 3 3 3 3 3 3 
+6 6 6 6 6 6 6);

print join " " => @array,"\n";

sub get_pairs1 {
    print "====================\n";
    my @array = @_;
    my $X;
    my $hash;
    my $A;
    my $counter;
    my @pairs;
    foreach (@array){
    $X->{$_} += 1;
    }
    foreach my $x (sort { $a <=> $b } keys %{$X}){
    foreach my $y (sort { $a <=> $b } keys %{$X}){
        next if  $X->{$x} == 0;
        next if $x eq $y;
        next if $X->{$y} == 0;
        next if defined $hash->{$x}{$y};
        $counter++;
        print "$counter = $x $y\n";
        push @pairs, [$x,$y];
        $hash->{$x}{$y} = $hash->{$y}{$x} = 1;
        $X->{$x} -= 1;        $X->{$y} -= 1;
    }
    }
    print "$counter counts$/";
    return @pairs;
} 



sub get_pairs2 {
  my %hash = ();
  $hash{$_}++ foreach @_;
  my @keys = sort { $hash{$b} <=> $hash{$a} } keys %hash;
  my $counter = 0;
  my @pairs = ();
  
  foreach my $x (0..$#keys - 1) {
    next unless $hash{$keys[$x]};
    foreach my $y ($x+1..$#keys) {
      last unless $hash{$keys[$x]};
      next unless $hash{$keys[$y]};
      push @pairs, ($keys[$x] < $keys[$y] ? [$keys[$x],$keys[$y]]:[$ke
+ys[$y],$keys[$x]]);
      print scalar @pairs," = @{$pairs[$#pairs]}$/";
      $hash{$keys[$x]}--;
      $hash{$keys[$y]}--;
    }
  }
  print scalar @pairs," counts$/";
  return @pairs;
}

# assumes that all pairs within the array are unique
sub maximize_rows {
  my @array = @_;
  my $counter = 0;
  foreach my $x (0..$#array - 1) {
    foreach my $y ($x+1..$#array) {
      my %hash = ();
      $hash{$_}++ foreach (@{$array[$x]},@{$array[$y]});
      if (scalar keys %hash == 4) {
        $counter++;
        print "$counter = $array[$x]->[0] $array[$x]->[1]  $array[$y]-
+>[0] $array[$y]->[1]$/";
      }
    }
  }
}

my @arr1 = get_pairs1(@array);
my @arr2 = get_pairs2(@array);

print "====================ROWS$/";
maximize_rows(@arr1);
print "====================NEXT$/";
maximize_rows(@arr2);

__DATA__
2 8 8 8 1 1 1 1 5 5 5 5 7 7 7 7 4 4 4 4 4 4 3 3 3 3 3 3 3 6 6 6 6 6 6 
+6
====================
1 = 1 2
2 = 1 3
3 = 1 4
4 = 1 5
5 = 3 4
6 = 3 5
7 = 3 6
8 = 3 7
9 = 3 8
10 = 4 5
11 = 4 6
12 = 4 7
13 = 4 8
14 = 5 6
15 = 6 7
16 = 6 8
16 counts
1 = 3 6
2 = 4 6
3 = 1 6
4 = 6 7
5 = 5 6
6 = 6 8
7 = 2 6
8 = 3 4
9 = 1 3
10 = 3 7
11 = 3 5
12 = 3 8
13 = 1 4
14 = 4 7
15 = 4 5
16 = 4 8
17 = 1 7
17 counts
====================ROWS
1 = 1 2  3 4
2 = 1 2  3 5
3 = 1 2  3 6
4 = 1 2  3 7
5 = 1 2  3 8
6 = 1 2  4 5
7 = 1 2  4 6
8 = 1 2  4 7
9 = 1 2  4 8
10 = 1 2  5 6
11 = 1 2  6 7
12 = 1 2  6 8
13 = 1 3  4 5
14 = 1 3  4 6
15 = 1 3  4 7
16 = 1 3  4 8
17 = 1 3  5 6
18 = 1 3  6 7
19 = 1 3  6 8
20 = 1 4  3 5
21 = 1 4  3 6
22 = 1 4  3 7
23 = 1 4  3 8
24 = 1 4  5 6
25 = 1 4  6 7
26 = 1 4  6 8
27 = 1 5  3 4
28 = 1 5  3 6
29 = 1 5  3 7
30 = 1 5  3 8
31 = 1 5  4 6
32 = 1 5  4 7
33 = 1 5  4 8
34 = 1 5  6 7
35 = 1 5  6 8
36 = 3 4  5 6
37 = 3 4  6 7
38 = 3 4  6 8
39 = 3 5  4 6
40 = 3 5  4 7
41 = 3 5  4 8
42 = 3 5  6 7
43 = 3 5  6 8
44 = 3 6  4 5
45 = 3 6  4 7
46 = 3 6  4 8
47 = 3 7  4 5
48 = 3 7  4 6
49 = 3 7  4 8
50 = 3 7  5 6
51 = 3 7  6 8
52 = 3 8  4 5
53 = 3 8  4 6
54 = 3 8  4 7
55 = 3 8  5 6
56 = 3 8  6 7
57 = 4 5  6 7
58 = 4 5  6 8
59 = 4 7  5 6
60 = 4 7  6 8
61 = 4 8  5 6
62 = 4 8  6 7
====================NEXT
1 = 3 6  1 4
2 = 3 6  4 7
3 = 3 6  4 5
4 = 3 6  4 8
5 = 3 6  1 7
6 = 4 6  1 3
7 = 4 6  3 7
8 = 4 6  3 5
9 = 4 6  3 8
10 = 4 6  1 7
11 = 1 6  3 4
12 = 1 6  3 7
13 = 1 6  3 5
14 = 1 6  3 8
15 = 1 6  4 7
16 = 1 6  4 5
17 = 1 6  4 8
18 = 6 7  3 4
19 = 6 7  1 3
20 = 6 7  3 5
21 = 6 7  3 8
22 = 6 7  1 4
23 = 6 7  4 5
24 = 6 7  4 8
25 = 5 6  3 4
26 = 5 6  1 3
27 = 5 6  3 7
28 = 5 6  3 8
29 = 5 6  1 4
30 = 5 6  4 7
31 = 5 6  4 8
32 = 5 6  1 7
33 = 6 8  3 4
34 = 6 8  1 3
35 = 6 8  3 7
36 = 6 8  3 5
37 = 6 8  1 4
38 = 6 8  4 7
39 = 6 8  4 5
40 = 6 8  1 7
41 = 2 6  3 4
42 = 2 6  1 3
43 = 2 6  3 7
44 = 2 6  3 5
45 = 2 6  3 8
46 = 2 6  1 4
47 = 2 6  4 7
48 = 2 6  4 5
49 = 2 6  4 8
50 = 2 6  1 7
51 = 3 4  1 7
52 = 1 3  4 7
53 = 1 3  4 5
54 = 1 3  4 8
55 = 3 7  1 4
56 = 3 7  4 5
57 = 3 7  4 8
58 = 3 5  1 4
59 = 3 5  4 7
60 = 3 5  4 8
61 = 3 5  1 7
62 = 3 8  1 4
63 = 3 8  4 7
64 = 3 8  4 5
65 = 3 8  1 7
66 = 4 5  1 7
67 = 4 8  1 7
[download]

The greatest example I've seen thus far of why going according to number of times each unique number shows up can be shown if you use the following value for @array:

@array = qw(6 6 5 5 1 1 1 3 3 3 3 2 2 2 2 4 4 4 4 4 8 8 8 8 8 8 8 8 7 
+7 7 7 7 7 7 7);

__DATA__
6 6 5 5 1 1 1 3 3 3 3 2 2 2 2 4 4 4 4 4 8 8 8 8 8 8 8 8 7 7 7 7 7 7 7 
+7
====================
1 = 1 2
2 = 1 3
3 = 1 4
4 = 2 3
5 = 2 4
6 = 2 5
7 = 3 4
8 = 3 5
9 = 4 6
10 = 4 7
11 = 6 7
12 = 7 8
12 counts
$VAR1 = {
          '6' => 0,
          '3' => 0,
          '7' => 5,
          '2' => 0,
          '8' => 7,
          '1' => 0,
          '4' => 0,
          '5' => 0
        };
1 = 7 8
2 = 4 7
3 = 3 7
4 = 2 7
5 = 1 7
6 = 6 7
7 = 5 7
8 = 4 8
9 = 3 8
10 = 2 8
11 = 1 8
12 = 6 8
13 = 5 8
14 = 3 4
15 = 2 4
16 = 1 4
17 = 2 3
17 counts
$VAR1 = {
          '6' => 0,
          '3' => 0,
          '7' => 1,
          '2' => 0,
          '8' => 1,
          '1' => 0,
          '4' => 0,
          '5' => 0
        };
get_pairs1 produces: 36 rows
get_pairs2 produces: 67 rows
[download]

Not too shabby.

antirice
The first rule of Perl club is - use Perl
The ith rule of Perl club is - follow rule i - 1 for i > 1

Comment on Re: Pairing the pairs Select or Download Code

Replies are listed 'Best First'.
Re: Re: Pairing the pairs by antirice (Priest) on Jun 13, 2003 at 05:00 UTC
Ok, artist has informed me that each pair may appear in only one row. I must've missed that, and as such I'm offering a different version of maximize_rows. I put this in a reply as the other post was obscenely long. Read more... (3 kB) As you can see, grouping like elements together and then trying to cut the larger groups down first offers the maximum number of pairs and rows. Update:I have discovered a condition within the pairing subs that messes up the ability for maximum number of rows to be generated. I admit that my sub is more vulnerable to it than artist's. It occurs when there exists a particular number that has enough to match all the other numbers in the listing and the other numbers occur only once. As an example: Read more... (1132 Bytes) As you can see, there's a problem in them there code. I haven't decided how to tackle this yet. Perhaps someone could lend a hand? :) Final Update (I hope): I've created a condition to find when and where it happens and now seems to work fantastic and stuff. :-P Read more... (2 kB) The demons have been exercised! This code is clear. antirice The first rule of Perl club is - use Perl The ith rule of Perl club is - follow rule i - 1 for i > 1	[reply] [d/l] [select]

Replies are listed 'Best First'.

Re: Re: Pairing the pairs
by antirice (Priest) on Jun 13, 2003 at 05:00 UTC

Ok, artist has informed me that each pair may appear in only one row. I must've missed that, and as such I'm offering a different version of maximize_rows. I put this in a reply as the other post was obscenely long.