File Coverage

blib/lib/Graph/Maker/Johnson.pm

Criterion	Covered	Total	%
statement	6	8	75.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	9	11	81.8

# Copyright 2015, 2016, 2017 Kevin Ryde
#
# This file is part of Graph-Maker-Other.
#
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# This file is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Graph-Maker-Other.  See the file COPYING.  If not, see
# .

package Graph::Maker::Johnson;
use 5.004;
use strict;
use Graph::Maker;

use vars '$VERSION','@ISA';
$VERSION = 8;
@ISA = ('Graph::Maker');

# uncomment this to run the ### lines
# use Smart::Comments;


sub _default_graph_maker {
  require Graph;
  return Graph->new(@_);
}
sub _make_graph {
  my ($params) = @_;
  my $graph_maker = delete($params->{'graph_maker'}) || \&_default_graph_maker;
  return $graph_maker->(%$params);
}

# $aref and $bref are arrayrefs of integers sorted in ascending order.
# Return the number of integers common to both arrays.
sub _sorted_arefs_count_same {
  my ($aref, $bref) = @_;
  my $i = 0;
  my $j = 0;
  my $count = 0;
  while ($i <= $#$aref && $j <= $#$bref) {
    if ($aref->[$i] == $bref->[$j]) {
      $count++;
      $i++;
      $j++;
    } elsif ($aref->[$i] < $bref->[$j]) {
      $i++;
    } else {
      $j++;
    }
  }
  return $count;
}

# Return a list of arrayrefs which contain all the $K element subsets of
# integers 1 to $N.  The integers in each subset are in ascending order.
# The order of the subsets themselves is unspecified.
#
sub _N_K_subsets {
  my ($N, $K) = @_;

  # $pos is 0 to $K-1
  # $upto[$pos] to maximum $N-($K-1)+$pos
  # the top $upto[$K-1] runs to maximum $N-($K-1)+($K-1) = $N
  # so $upto[$pos] <= $N-$K+1+$pos
  my @ret;
  my @upto = (0);
  my $pos = 0;
  my $limit = $N-$K+1;
  for (;;) {
    ### @upto
    ### $pos
    if (++$upto[$pos] > $limit+$pos) {
      # backtrack
      if (--$pos < 0) {
        last;
      }
    } else {
      if (++$pos >= $K) {
        ### subset: "@upto"
        push @ret, [@upto];
        $pos--;
      } else {
        $upto[$pos] = $upto[$pos-1];
      }
    }
  }
  return @ret;
}


sub init {
  my ($self, %params) = @_;

  my $N = delete($params{'N'}) || 0;
  my $K = delete($params{'K'}) || 0;
  ### $N
  ### $K
  my $graph = _make_graph(\%params);

  $graph->set_graph_attribute (name => "Johnson $N,$K");
  my $directed = $graph->is_directed;

  my @vertices = _N_K_subsets($N,$K);
  foreach my $v (@vertices) {
    $graph->add_vertex(join(',',@$v));
  }

  foreach my $i_from (0 .. $#vertices-1) {
    my $from = $vertices[$i_from];
    foreach my $i_to ($i_from+1 .. $#vertices) {
      my $to = $vertices[$i_to];
      ### consider: "from=".join(',',@$from)." to=".join(',',@$to)

      my $count = _sorted_arefs_count_same($from, $to);
      ### $count
      if ($count == $K - 1) {
        my $v_from = join(',',@$from);
        my $v_to   = join(',',@$to);
        ### edge: "$v_from to $v_to"
        $graph->add_edge($v_from, $v_to);
        if ($directed) { $graph->add_edge($v_to, $v_from); }
      }
    }
  }
  return $graph;
}

Graph::Maker->add_factory_type('Johnson' => __PACKAGE__);
1;

__END__