zing has asked for the wisdom of the Perl Monks concerning the following question:

Hi guys, I have this code which takes in input in the form of triplets of vertices(see DATA) 
use strict;
use warnings;
use Data::Dumper;

my @S;
while (<DATA>) {
    push @S, [split];
}
print "-----TRIPLETS-------\n";
print Dumper \@S;

__DATA__
b c a
a c d
d e b

[download]
What Im stuck with is this :: Suppose I have these points=(a,b,c,d); Then I want to find the set of triplets induced by these 4 vertices. For example for above four points the induced triplets should be: 
b c a 
a c d

[download]
Whereas for vertices=(d,e,a) there isn't any triplet in the data.

Similarly for vertices=(b,e,d) there is a triplet (d e b) in the data(the last one).

Replies are listed 'Best First'.
Re: Finding subgraphs induced by a set of given vertices.
by Anonymous Monk on Oct 03, 2012 at 16:29 UTC

    induced? You mean included 

    #!/usr/bin/perl --
use strict; use warnings; use Data::Dump;

my @S = do {
    open my($data), '<', \q{b c a
a c d
d e b};
    map { [ split ] } readline $data;
};

dd \@S;

for my $QT ( [qw[ a b c d ]], [qw[ b e d ]] ){
    dd $QT;
    for my $triplet ( @S ){
        my %Pie;
        undef @Pie{@$QT};
        delete @Pie{ @$triplet };
#~         warn scalar keys %Pie ;
#~         warn scalar @$QT;
        print "@$triplet\n" if keys(%Pie) <= ( @$QT - @$triplet ) ;
    }
}
__END__
[["b", "c", "a"], ["a", "c", "d"], ["d", "e", "b"]]
["a" .. "d"]
b c a
a c d
["b", "e", "d"]
d e b

    [download]
[reply]
[d/l]

      I just wanted to use Graph module. 

      #!/usr/bin/perl
use strict; use warnings;
use Graph;

my @path_sets = ( [ "b", "c", "a" ], [ "a", "c", "d" ], [ "d", "e", "b
+" ] );
my @vertex_sets = ( [qw[ a b c d ]], [qw[ b e d ]] );

#convert [b,c,d] to "[b-c,c-d]"
sub to_pathstr {
    my @path_set =@_;
    my $pre='';my @ret=();
    for (@path_set) {
        for( @{$_} ){
            push @ret, "$pre-$_" if ($pre);
            $pre=$_;
        }
    }
    return @ret;
}
#if edges of path[b,c,d] shares 2 edges of complete graph[a,b,c,d]
#this path go through 3 vertices of graph, maybe.
for my $vertex_set (@vertex_sets){
    my($g, $c);
    $g=new Graph(directed=>1);
    $g->add_vertices( @$vertex_set );
    $c=$g->complete; #ex. [a,b,c,d] =>a-b,a-c,a-d,b-a,b-c,b-d,c-a,c-b,
+c-d,d-a,d-b,d-c
    print "target vertex=$g\n";

    #convert array [b,c,d] to "b-c,c-d", Graph module's edge represent
+ation
    for my $pathstr( map{ [ to_pathstr($_)] } @path_sets ){
        my $regex=join('|', map{"\Q$_\E"} @{$pathstr});
        my (@matched)= "$c" =~ /($regex)/g; #check how may egdes match
        if( @matched >= 2 ){
            print "matched path=".join(',',@$pathstr)."\n";
        }
    }
    print "\n";
}

      [download]
      Your one with hash operation is nicer than mine.

[reply]
[d/l]
      Thanks Anon,

      How do i modify this code to take in input from command line i.e. instead of this line

      for my $QT ( [qw[ a b c d ]], [qw[ b e d ]] )

      How do i feed it with input vertices from command line

[reply]
[d/l]
Re: Finding subgraphs induced by a set of given vertices.
by LanX (Saint) on Oct 03, 2012 at 17:02 UTC
    to give you some explanation of Anonymous Monks code:

    you are not checking for subgraphs but subsets.

    Perl's way to do this is using hashes, because hash-keys are unique sets of strings.

    And hashslices are a very efficient way to determine the cut between to hashes.

    see also: Using hashes for set operations...

    checking for subgraphs is in general far more complicated

    Cheers Rolf

[reply]
      Hi LanX, I tried to make the code a little flexible 
      my @z;
for (my $r = 0; $r <= 2; $r++)
{$z[$r]=$subgraphs[0][$r];}

for my $QT (@z ){
    print Dumper $QT;
    for my $triplet ( @S ){
        my %Pie;
        undef @Pie{@$QT};
        delete @Pie{ @$triplet };
        print "@$triplet\n" if keys(%Pie) <= ( @$QT - @$triplet ) ;
    }
}

      [download]
      But Im getting this error::

      Can't use string ("c") as an ARRAY ref while "strict refs" in use at combo.pl line 89

      Line 89 being " undef @Pie{@$QT};"
[reply]
[d/l]
      Hi Lanx, I have two questions:-

      1. Could you please explain me this part of the code posted by anonymous 

      for my $triplet ( @S ){
        my %Pie;
        undef @Pie{@$QT};
        delete @Pie{ @$triplet };
        print "@$triplet\n" if keys(%Pie) <= ( @$QT - @$triplet ) ;

      [download]

      2. If I call this code as a subroutine,how do I save the retun value of this subroutine. 

      sub induced {
my (@z)=@_;
for my $QT (\@z ){
    #print Dumper $QT;
    for my $triplet ( @trip ){
        my %Pie;
        undef @Pie{@$QT};
        delete @Pie{ @$triplet };
        print "@$triplet\n" if keys(%Pie) <= ( @$QT - @$triplet ) ;
        return @$triplet;
    }
}}
my @C;
my $d;
my $p=$#subgraphs+1;
for ($d=$p; $d >=1; $d--)
  { 
    print "component $d = @{ $subgraphs[$d-1] }\n";
    my ($qw,$we,$er)=&induced(@{ $subgraphs[$d-1] });
     

}
----------OUTPUT------------
component 2 = e d
component 1 = c a b
b c a

      [download]

      But I want to save the return value "b c a"
[reply]
[d/l]
[select]

        You say you want to return instead of print?

        Think about that for a minute, return instead of print

        Hmm, how to return instead of print?

        Write return instead of print?

        Hmm, yes, write return instead of print, replace print with return, yes, I think that is it :)

        But there is a problem with returning instead of printing -- there can be more than one matching triplet , so by returning you only get the first matching triplet 

        #!/usr/bin/perl --
use strict;
use warnings;
use Data::Dump qw/ pp /;

Main(@ARGV);
exit(0);

#~ sub DEBUG(){}  # disable debugging
sub DEBUG { my ( $p, $f, $l ) = caller; print "$f:$l: ", pp(@_), "\n";
+ }

sub induced {
  my $trip = shift;
  my @matches;
  for my $QT ( @_ ) {
    DEBUG( $QT );
    for my $triplet ( @$trip ) {
      DEBUG($triplet);
      my %seen;        # my %Pie;
      DEBUG( \%seen ); # DEBUG( \%Pie );
      undef @seen{@$QT};
      DEBUG( \%seen );
      delete @seen{@$triplet};
      DEBUG( \%seen );
      DEBUG(
        {
          KEYS_LEFT    => \%seen,
          QT_SIZE      => scalar(@$QT),
          TRIPLET_SIZE => scalar(@$triplet),
        },
      );

      if ( keys( %seen ) <= ( @$QT - @$triplet ) ) {
        DEBUG( $triplet );
        push @matches, $triplet;
      }
    } ## end for my $triplet ( @$trip )
  } ## end for my $QT ( @_ )
  return @matches;
} ## end sub induced

sub Main {
  my @S = ( [ "b", "c", "a" ], [ "a", "c", "d" ], [ "d", "e", "b" ] );
  my @T = ( [qw[ a b c d ]], [qw[ b e d ]] );
  for my $one (@S) {
    my @matches = induced( \@T, $one );
    print "\nGot some? ", pp( $one => { MATCHES => \@matches } ), "\n\
+n";
  }
} ## end sub Main

__END__
qtPie:16: ["b", "c", "a"]
qtPie:18: ["a" .. "d"]
qtPie:20: {}
qtPie:22: { a => undef, b => undef, c => undef }
qtPie:24: {}
qtPie:25: { KEYS_LEFT => {}, QT_SIZE => 3, TRIPLET_SIZE => 4 }
qtPie:18: ["b", "e", "d"]
qtPie:20: {}
qtPie:22: { a => undef, b => undef, c => undef }
qtPie:24: { a => undef, c => undef }
qtPie:25: {
  KEYS_LEFT    => { a => undef, c => undef },
  QT_SIZE      => 3,
  TRIPLET_SIZE => 3,
}

Got some? (["b", "c", "a"], { MATCHES => [] })

qtPie:16: ["a", "c", "d"]
qtPie:18: ["a" .. "d"]
qtPie:20: {}
qtPie:22: { a => undef, c => undef, d => undef }
qtPie:24: {}
qtPie:25: { KEYS_LEFT => {}, QT_SIZE => 3, TRIPLET_SIZE => 4 }
qtPie:18: ["b", "e", "d"]
qtPie:20: {}
qtPie:22: { a => undef, c => undef, d => undef }
qtPie:24: { a => undef, c => undef }
qtPie:25: {
  KEYS_LEFT    => { a => undef, c => undef },
  QT_SIZE      => 3,
  TRIPLET_SIZE => 3,
}

Got some? (["a", "c", "d"], { MATCHES => [] })

qtPie:16: ["d", "e", "b"]
qtPie:18: ["a" .. "d"]
qtPie:20: {}
qtPie:22: { b => undef, d => undef, e => undef }
qtPie:24: { e => undef }
qtPie:25: { KEYS_LEFT => { e => undef }, QT_SIZE => 3, TRIPLET_SIZE =>
+ 4 }
qtPie:18: ["b", "e", "d"]
qtPie:20: {}
qtPie:22: { b => undef, d => undef, e => undef }
qtPie:24: {}
qtPie:25: { KEYS_LEFT => {}, QT_SIZE => 3, TRIPLET_SIZE => 3 }
qtPie:34: ["b", "e", "d"]

Got some? (["d", "e", "b"], { MATCHES => [["b", "e", "d"]] })

        [download]
[reply]
[d/l]
Re: Finding subgraphs induced by a set of given vertices.
by AnomalousMonk (Archbishop) on Oct 04, 2012 at 17:00 UTC

    zing: If you run Anonymonk's code of node 997164 with the necessary changes of 997168 and 997253, how does it work for you? It seems to me to produce the results you want given the limited dataset examples you have given.

[reply]
      AM its now what I want.Here's the output from the code given by anonymous 
      Got some? (["b", "c", "a"], { MATCHES => [] })


Got some? (["a", "c", "d"], { MATCHES => [] })


Got some? (["d", "e", "b"], { MATCHES => [["b", "e", "d"]] })

      [download]
      But for T = a b c d I have induced = "b", "c", "a" , "a", "c", "d" .

      Similarly for T = b e d output should be = "d", "e", "b" .

[reply]
[d/l]
[reply]
      The code fails on this data Code 
      ---------DATA-------------- 
b c a 
a c d 
d e b 
e f g 
g d f 
h i g

      [download]
      And the output is 
      component 2 = e d g f 
component 1 = c a b 
b c a

      [download]
      Which is wrong, because it should have been this 
          

component 2 = e d g f 
e f g 
g d f 
component 1 = c a b 
b c a

      [download]
      Because with the vertices in component 2, we can have 4th & 5th row of DATA. Please help on this
[reply]
[d/l]
[select]
        I hope I was clear explaining my problem. Please let me know if you need any other information. Help me on his
[reply]

Back to Seekers of Perl Wisdom