Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Re^2: decomposing binary matrices (2)

by hv (Prior)
on Feb 28, 2007 at 09:22 UTC ( [id://602460]=note: print w/replies, xml ) Need Help??


in reply to Re: decomposing binary matrices (2)
in thread decomposing binary matrices (2)

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

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://602460]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others musing on the Monastery: (5)
As of 2024-03-19 09:07 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found