Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

Excellent, it works. :)

The code below demonstrates and tests the cleanup() method and its dependencies - the rest is just a minimal hack to wrap a test harness around it. I also hacked in %rev at the last minute when I realised %$assign was the wrong way round for my needs, I still need to refactor that.

#!/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

Thanks very much for your help,

Hugo


In reply to Re^2: decomposing binary matrices (2) by hv
in thread decomposing binary matrices (2) by hv

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (6)
As of 2021-10-25 19:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My first memorable Perl project was:







    Results (89 votes). Check out past polls.

    Notices?