sub get_pairs {
  my %hash = ();
  $hash{$_}++ foreach @_;
  my @keys = ();
  
  @keys = sort { $hash{$b} <=> $hash{$a} } keys %hash;
  # let's check for condition red
  if (@keys > 2 && ($hash{$keys[0]} + $hash{$keys[1]} > @keys - 3) && $hash{$keys[3]} == 1) {
    # !!!!CONDITION RED!!!!
    # ok...let's calm down...we can do this...just don't panic
    my $workarea = scalar @keys - 2;
    
    if ($keys[1] < int ($workarea / 2)) {
      $workarea -= 2 * $keys[1];
      $hash{$keys[0]} = $keys[1] + int ($workarea / 3);
    }
    else {
      $hash{$keys[0]} = $hash{$keys[1]} = int ($workarea / 2);
    }
  }
  
  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]]:[$keys[$y],$keys[$x]]);
      print scalar @pairs," = @{$pairs[$#pairs]}$/";
      $hash{$keys[$x]}--;
      $hash{$keys[$y]}--;
    }
  }
  print scalar @pairs," counts$/";
  return @pairs;
}

__DATA__
1 1 1 2 3 4
====================
1 = 1 2
2 = 1 3
3 = 1 4
3 counts
$VAR1 = {
          '4' => 0,
          '1' => 0,
          '3' => 0,
          '2' => 0
        };
1 = 1 4
2 = 2 3
2 counts
$VAR1 = {
          '4' => 0,
          '1' => 0,
          '3' => 0,
          '2' => 0
        };
Unused 1: 1 2
Unused 2: 1 3
Unused 3: 1 4
next
1 = 1 4  2 3