#!/usr/bin/perl -w
use strict;
use Graph;

{
  package Graph;
  sub maximal_match {
    my($self, $vlist) = @_;
    my($path, %assign, %seen);
    while (($a = $self->alternating_path($vlist, \%assign, \%seen))) {
      $assign{$_->[0]} = $_->[1] for @$a;
      $seen{$_} = 1 for ($a->[0][0], $a->[$#$a][1]);
    }
    return wantarray ? %assign : scalar keys(%assign);
  }

  sub alternating_path {
    my($g, $vlist, $assign, $seen) = @_;
    my %rev = reverse %$assign;
    my %seen_locally;
    my $curlist = [ map [ $_ ], grep !$seen->{$_}, @$vlist ];
    while (@$curlist) {
      my $nextlist = [];
      for my $cur (@$curlist) {
        my $v = pop @$cur;
        for my $next ($g->neighbours($v)) {
          next if $seen_locally{$next}++;
          return [ @$cur, [ $v, $next ] ] unless $seen->{$next};
          push @$nextlist, [ @$cur, [ $v, $next ], $rev{$next} ];
        }
      }
      $curlist = $nextlist;
    }
    return; 
  }
}   # package Graph
    
{   
  package Hugo::Set;
  sub new { bless $_[1], $_[0] } 
  sub graph {
    my $self = shift;
    $self->{graph} ||= do {
      my $g = Graph::Undirected->new;
      for my $var (@{ $self->{vars} }) {
        for my $value (@{ $self->{values} }) {
          $g->add_edge($var, $value);
        }
      }
      $g;
    };
  } 
  sub cleanup {
    my $self = shift;
    my $max = @{ $self->{vars} } - 1;
    my $g = $self->graph;
    for my $var (@{ $self->{vars} }) {
      for my $value ($g->neighbours($var)) {
        my $g2 = $g->copy_graph;
        $g2->delete_vertices($var, $value);
        next if $g2->maximal_match($self->{vars}) == $max;
        $g->delete_edge($var, $value);
      }
    }
  }
}

sub pretty {
  my $set = shift;
  my $g = $set->graph;
  for my $c ($g->connected_components) {
    my($vars, $values);
    push @{ /[a-z]/i ? $vars : $values }, $_ for sort @$c;
    printf "   %s\n", join ' ', @$values;
    for my $var (@$vars) {
      printf "%s  %s\n", $var, join ' ',
        map sprintf("%*d", length($_), $g->has_edge($var, $_) ? 1 : 0)
+,
          @$values;
    }
    print "\n";
  }
}

{
  my @varnames = ('A' .. 'Z');
  my @values = (0 .. 99);
  my $test = 0;
  sub trial {
    printf "Test %s\n", ++$test;
    my @piece = split /\s+/, shift();
    my $set = Hugo::Set->new({
      vars => [ @varnames[0 .. $#piece] ],
      values => [ @values[1 .. length($piece[0])] ],
    });
    my $var = 'A';
    for (0 .. $#piece) {
      while ($piece[$_] =~ /0/g) {
        $set->graph->delete_edge($var, $+[0]);
      }
      ++$var;
    }
    pretty($set);
    $set->cleanup;
    pretty($set);
  }
}

trial($_) for grep length($_), split /\n/, <<EOF;
111 111 111
110 101 011
01010 00111 11001 11101 01010
000111 000111 000110 111111 111111 110111
11000 10110 10110 10110 11111
1100 1011 1011 1011
11000 11000 11111 11111
EOF
[download]