File Coverage

blib/lib/Graph/Graph6.pm

Criterion	Covered	Total	%
statement	297	331	89.7
branch	152	196	77.5
condition	46	68	67.6
subroutine	23	23	100.0
pod	2	2	100.0
total	520	620	83.8

# Copyright 2015, 2016, 2017, 2018, 2021 Kevin Ryde
#
# This file is part of Graph-Graph6.
#
# Graph-Graph6 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.
#
# Graph-Graph6 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-Graph6.  If not, see .

package Graph::Graph6;
use 5.006;  # for 3-arg open
use strict;
use warnings;
use List::Util 'max';
use Carp 'croak';

use Exporter;
our @ISA = ('Exporter');
our @EXPORT_OK = ('read_graph','write_graph',
                  'HEADER_GRAPH6','HEADER_SPARSE6','HEADER_DIGRAPH6');

our $VERSION = 9;

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


use constant HEADER_GRAPH6   => '>>graph6<<';
use constant HEADER_SPARSE6  => '>>sparse6<<';
use constant HEADER_DIGRAPH6 => '>>digraph6<<';

sub _read_header {
  my ($fh, $str) = @_;
  for (;;) {
    my $s2 = getc $fh;
    if (! defined $str) { return; }

    $str .= $s2;
    if ($str eq substr(HEADER_GRAPH6, 0, length($str))) {
      if (length($str) == length(HEADER_GRAPH6)) {
        ### header: $str
        # $format = 'graph6';
        return;
      }

    } elsif ($str eq substr(HEADER_SPARSE6, 0, length($str))) {
      if (length($str) == length(HEADER_SPARSE6)) {
        ### header: $str
        # $format = 'sparse6';
        return;
      }

    } elsif ($str eq substr(HEADER_DIGRAPH6, 0, length($str))) {
      if (length($str) == length(HEADER_DIGRAPH6)) {
        ### header: $str
        # $format = 'digraph6';
        return;
      }
    } else {
      return $str;
    }
  }
}

sub read_graph {
  my %options = @_;

  my $fh = $options{'fh'};
  if (defined $options{'str'}) {
    require IO::String;
    $fh = IO::String->new($options{'str'});
  }

  my $skip_newlines = 1;
  my $allow_header = 1;
  my $format = 'graph6';
  my $initial = 1;
  my $error;

  # Return: byte 0 to 63
  #      or -1 and $error=undef if end of file
  #      or -1 and $error=string if something bad
  my $read_byte = sub {
    for (;;) {
      my $str;
      my $len = read($fh, $str, 1);
      if (! defined $len) {
        $error = "Error reading: $!";
        return -1;
      }
      ### read byte: $str

      if ($skip_newlines && $str eq "\n") {
        # secret undocumented skipping of newlines, so skip blank lines
        # rather than reckoning one newline as immediate end of file
        ### skip initial newline ...
        next;
      }
      $skip_newlines = 0;

      if ($allow_header && $str eq '>') {
        $str = _read_header($fh, $str);
        if (defined $str) {
          $error = "Incomplete header: $str";
          return -1;
        }
        $allow_header = 0;
        next;
      }
      $allow_header = 0;

      my $n = ord($str) - 63;
      if ($n >= 0 && $n <= 63) {
        return $n;
      }

      if ($str eq '' || $str eq "\n") {
        ### end of file or end of line ...
        return -1;
      }

      if ($initial && $str eq '&') {
        $format = 'digraph6';
        ### $format
        $initial = 0;
        next;
      }
      if ($initial && $str eq ':') {
        $format = 'sparse6';
        ### $format
        $initial = 0;
        next;
      }
      if ($str eq "\r") {
        ### skip CR ...
        next;
      }

      $error = "Unrecognised character: $str";
      return -1;
    }
  };

  # Return: number 0 to 2^36-1
  #         -1 and $error=undef if end of file before any part of number
  #         -1 and $error if something bad, including partial number
  my $read_number = sub {
    my $n = $read_byte->();
    $initial = 0;
    if ($n <= 62) {
      return $n;
    }
    $n = $read_byte->();
    if ($n < 0) {
      $error ||= "Unexpected EOF";
      return -1;
    }
    my $len;
    if ($n <= 62) {
      $len = 2;
    } else {
      $n = 0;
      $len = 6;
    }
    foreach (1 .. $len) {
      my $n2 = $read_byte->();
      if ($n2 < 0) {
        $error ||= "Unexpected EOF";
        return -1;
      }
      $n = ($n << 6) + $n2;
    }
    return $n;
  };

  # Return true if good.
  # Return false and $error=string if something bad.
  # Return false and $error=undef if EOF.
  my $read = sub {

    if (! defined $fh) {
      if (defined(my $filename = $options{'filename'})) {
        open $fh, '<', $filename
          or do {
            $error = "Cannot open file $filename: $!";
            return;
          };
      }
    }

    my $num_vertices = $read_number->();
    ### $num_vertices

    if (my $format_func = $options{'format_func'}) {
      $format_func->($format);
    }
    if (my $format_ref = $options{'format_ref'}) {
      $$format_ref = $format;
    }

    if ($num_vertices < 0) {
      return;  # eof or possible error
    }
    if (my $num_vertices_func = $options{'num_vertices_func'}) {
      $num_vertices_func->($num_vertices);
    }
    if (my $num_vertices_ref = $options{'num_vertices_ref'}) {
      $$num_vertices_ref = $num_vertices;
    }

    my $edge_func = $options{'edge_func'};
    my $edge_aref = $options{'edge_aref'};
    if ($edge_aref) { @$edge_aref = (); }

    ### $format
    if ($format eq 'sparse6') {
      ### sparse6 ...
      my $v = 0;

      # number of bits required to represent $num_vertices - 1
      my $width = 0;
      while (($num_vertices-1) >> $width) { $width++; }

      my $bits = 0;
      my $n = 0;
      my $mask = (1 << $width) - 1;

      while ($v < $num_vertices) {
        if ($bits < 1) {
          $n = $read_byte->();
          if ($n < 0) {
            ### end n ...
            ### $error
            return ! defined $error;
          }
          $bits = 6;
        }
        $bits--;
        my $b = ($n >> $bits) & 1;   # first bit from $n
        $v += $b;   # propagate possible taintedness of $n,$b to $v
        ### $b
        ### to v: $v

        while ($bits < $width) {      # fill $n,$bits to >= $width many bits
          my $n2 = $read_byte->();
          if ($n2 < 0) {
            ### end n2 ...
            ### $error
            return ! defined $error;
          }
          $bits += 6;
          $n <<= 6;
          $n |= $n2;
        }
        $bits -= $width;
        my $x = ($n >> $bits) & $mask;
        ### $x

        if ($x > $v) {
          ### set v: $x
          $v = $x;
        } elsif ($v < $num_vertices) {  # padding can make v>n-1
          ### edge: "$x - $v"
          if ($edge_func) { $edge_func->($x, $v); }
          if ($edge_aref) { push @$edge_aref, [$x, $v]; }
        }
      }
      ### end ...

    } else {
      ### graph6 or digraph6 ...
      my $n;
      my $mask;
      my $from;
      my $to;
      my $output_edge = sub {
        if ($n & $mask) {
          my $taint0 = $n & 0;
          my $from_taint = $from + $taint0;
          my $to_taint   = $to   + $taint0;
          if ($edge_func) { $edge_func->(      $from_taint, $to_taint); }
          if ($edge_aref) { push @$edge_aref, [$from_taint, $to_taint]; }
        }
      };

      if ($format eq 'graph6') {
        # graph6 goes by columns of "to" within which "from" runs 0 though to-1
        # first column is to=1
        $from = 0;
        $to = 1;
        while ($to < $num_vertices) {
          if (($n = $read_byte->()) < 0) {
            $error ||= "Unexpected EOF";  # end of file is not ok
            return;
          }
          for ($mask = 1 << 5; $mask != 0; $mask >>= 1) {
            $output_edge->();
            $from++;
            if ($from >= $to) {
              $to++;
              last unless $to < $num_vertices;
              $from = 0;
            }
          }
        }
      } else {
        # graph6 goes by rows of "from", within which "to" runs 0 to n-1
        $from = 0;
        $to = 0;
        while ($from < $num_vertices) {
          if (($n = $read_byte->()) < 0) {
            $error ||= "Unexpected EOF";  # end of file is not ok
            return;
          }
          for ($mask = 1 << 5; $mask != 0; $mask >>= 1) {
            $output_edge->();
            $to++;
            if ($to >= $num_vertices) {
              $from++;
              last unless $from < $num_vertices;
              $to = 0;
            }
          }
        }
      }

      # read \n or \r\n, so can take successive graphs from file handle
      for (;;) {
        my $str;
        my $len = read($fh, $str, 1);
        if (! defined $len) {
          $error = "Error reading: $!";
          last;
        }
        if ($str eq "\r") {
          next;  # skip CR in case reading MS-DOS file as bytes
        }
        if ($str eq '' || $str eq "\n") {
          last;  # EOF or EOL, good
        }
      }
    }

    return 1;
  };


  if ($read->()) {
    return 1;  # successful read
  }
  if (defined $error) {
    ### $error
    my $error_func = $options{'error_func'} || \&Carp::croak;
    $error_func->($error);
    return undef;
  }
  return 0;  # EOF
}

#------------------------------------------------------------------------------

# For internal use.
# Biggest shift is by (6-1)*6 = 30 bits, so ok in 32-bit Perls circa 5.8 and
# earlier (where counts were taken modulo 32, not full value).
sub _number_to_string {
  my ($n) = @_;
  my $str;
  my $bitpos;
  if ($n > 258047) {  # binary 0b_111110_111111_111111 octal 0767777
    $str = '~~';
    $bitpos = (6-1)*6;
  } elsif ($n > 62) {
    $str = '~';
    $bitpos = (3-1)*6;
  } else {
    $str = '';
    $bitpos = 0;
  }
  do {     # big endian, high to low
    $str .= chr( (($n >> $bitpos) & 0x3F) + 63 );
  } while (($bitpos-=6) >= 0);
  return $str;
}

sub _edges_iterator_none {
  return;
}
sub _edge_predicate_none {
  return 0;
}

sub write_graph {
  my %options = @_;
  ### %options

  my $fh = $options{'fh'};
  if (! $fh
      && defined(my $str_ref = $options{'str_ref'})) {
    ### str_ref ...
    require IO::String;
    $fh = IO::String->new($$str_ref);
  }
  if (! $fh
      && defined(my $filename = $options{'filename'})) {
    ### $filename
    open $fh, '>', $filename
      or return 0;
  }

  my $format = $options{'format'};
  if (! defined $format) { $format = 'graph6'; }

  my $num_vertices = $options{'num_vertices'};
  if (! defined $num_vertices
      && (my $edge_aref = $options{'edge_aref'})) {
    # from maximum in edge_aref
    $num_vertices = -1;
    foreach my $edge (@$edge_aref) {
      $num_vertices = max($num_vertices, @$edge);
    }
    $num_vertices += 1;
  }
  if (! defined $num_vertices) {
    croak 'Missing num_vertices';
  }
  ### $num_vertices

  print $fh
    ($options{'header'} ? ">>$format<<" : ()),
    ($format eq 'sparse6' ? ':'
     : $format eq 'digraph6' ? '&'
     : ()),
       _number_to_string($num_vertices)
       or return 0;

  my $bitpos = 5;
  my $word = 0;
  my $put_bit = sub {
    my ($bit) = @_;
    $word |= $bit << $bitpos;
    if ($bitpos > 0) {
      $bitpos--;
    } else {
      print $fh chr($word + 63) or return 0;
      $bitpos = 5;
      $word = 0;
    }
    return 1;
  };

  if ($format eq 'sparse6') {
    my $edge_iterator;

    if (my $edge_aref = $options{'edge_aref'}) {
      ### edge_aref ...
      # swap to [from <= to]
      my @edges = map { $_->[0] > $_->[1]
                          ? [ $_->[1], $_->[0] ]
                          : $_
                        } @$edge_aref;
      # sort to ascending "to", and within those ascending "from"
      @edges = sort { ($a->[1] <=> $b->[1]) || ($a->[0] <=> $b->[0]) } @edges;
      $edge_iterator = sub {
        return @{(shift @edges) || []};
      };
    }

    if (! $edge_iterator
        && (my $edge_predicate = $options{'edge_predicate'})) {
      ### edge_predicate ...
      my $from = 0;
      my $to = -1;
      $edge_iterator = sub {
        for (;;) {
          $from++;
          if ($from > $to) {
            $to++;
            if ($to >= $num_vertices) {
              return;
            }
            $from = 0;
          }
          if ($edge_predicate->($from,$to)) {
            return ($from,$to);
          }
        }
      };
    }

    $edge_iterator ||= \&_edges_iterator_none;

    # $width = number of bits required to represent $num_vertices - 1
    my $width = 0;
    if ($num_vertices > 0) {
      while (($num_vertices-1) >> $width) { $width++; }
    }
    ### $width

    my $put_n = sub {
      my ($n) = @_;
      for (my $i = $width-1; $i >= 0; $i--) {
        $put_bit->(($n >> $i) & 1) or return 0;
      }
      return 1;
    };

    # When doing a "set v" for a new to >= v+2, the b[i] bit can be either 0
    # or 1.  When 1 it means v++ increment, and the x[i]=to is still >v so
    # set v.  The code here follows the Nauty tools ntos6() and emits b[i]=1.

    my $v = 0;
    while (my ($from, $to) = $edge_iterator->()) {
      ### edge: "$from $to"

      if ($to == $v + 1) {
        ### increment v ...
        $put_bit->(1) or return 0;

      } else {
        if ($to != $v) {   # $to >= $v+2
          ### set v ...
          ($put_bit->(1)   # set v done with b[i]=1
           && $put_n->($to))
            or return 0;
        }
        $put_bit->(0) or return 0;     # v unchanged
      }
      ### write: $from
      $put_n->($from) or return 0;     # edge ($from, $v)

      $v = $to;
    }

    if ($bitpos != 5) {
      ### pad: $bitpos+1
      ### $v

      # Rule for padding so not to look like self-loop n-1 to n-1.
      # There are $bitpos+1 many bits to pad.
      # b[i]=0 bit if num_vertices = 2,4,8,16 so width=1,2,3,4
      #               and pad >= width+1
      #               and edge involving n-2 so final v=n-2
      # 0 111 is set v=n-1 provided prev <= n-2
      # 1 111 is a v+1 and edge n-1,v which is n-1,n out of range
      if (($width >= 1 && $width <= 4)
          && $num_vertices == (1 << $width)    # 1,2,4,8
          && $bitpos >= $width                 # room for final b[i] and x[i]
          && $v == $num_vertices - 2) {
        ### pad 0 ...
        $put_bit->(0) or return 0;
      }

      ### pad with 1s: $bitpos
      until ($bitpos == 5) {
        $put_bit->(1) or return 0;
      }
    }

  } else {
    my $edge_predicate = $options{'edge_predicate'};

    if (! $edge_predicate
        && (my $edge_aref = $options{'edge_aref'})) {
      ### edge_predicate from edge_aref ...
      my %edge_hash;
      foreach my $edge (@$edge_aref) {
        my ($from, $to) = @$edge;
        if ($from > $to && $format eq 'graph6') { ($from,$to) = ($to,$from); }
        $edge_hash{$from}->{$to} = undef;
      }
      $edge_predicate = sub {
        my ($from, $to) = @_;
        return exists $edge_hash{$from}->{$to};
      };
    }

    $edge_predicate ||= \&_edge_predicate_none;

    if ($format eq 'graph6') {
      foreach my $to (1 .. $num_vertices-1) {
        foreach my $from (0 .. $to-1) {
          $put_bit->($edge_predicate->($from,$to) ? 1 : 0) or return 0;
        }
      }
    } elsif ($format eq 'digraph6') {
      foreach my $from (0 .. $num_vertices-1) {
        foreach my $to (0 .. $num_vertices-1) {
          $put_bit->($edge_predicate->($from,$to) ? 1 : 0) or return 0;
        }
      }
    } else {
      croak 'Unrecognised format: ',$format;
    }

    until ($bitpos == 5) {
      $put_bit->(0) or return 0;
    }
  }

  print $fh "\n" or return 0;
  return 1;
}

    # if (! $edge_predicate
    #     && (my $edge_matrix = $options{'edge_matrix'})) {
    #   $edge_predicate = sub {
    #     my ($from, $to) = @_;
    #     return $edge_matrix->[$from]->[$to];
    #   };
    # }

1;
__END__