File Coverage

blib/lib/Graph/Maker/NoughtsAndCrosses.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 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::NoughtsAndCrosses;
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 _make_graph {
  my ($params) = @_;
  if (my $graph_maker = delete($params->{'graph_maker'})) {
    return $graph_maker->(%$params);
  }
  require Graph;
  return Graph->new(%$params);
}

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

  my $N = delete $params{'N'};
  if (! defined $N) { $N = 3; }
  my $rotate  = delete $params{'rotate'};
  my $reflect = delete $params{'reflect'};
  my $players = delete $params{'players'};
  if (! defined $players) { $players = 2; }

  ### $N
  ### $players
  ### $rotate
  ### $reflect

  my $graph = _make_graph(\%params);
  {
    my $name = "Noughts and Crosses ${N}x$N";
    if ($players != 2) {
      $name .= ", $players Player" . ($players==1 ? '' : 's');
    }
    if ($rotate || $reflect) { $name .= ' up to '; }
    $name .= join(' and ',
                  ($rotate  ? ('Rotation')   : ()),
                  ($reflect ? ('Reflection') : ()));
    $graph->set_graph_attribute (name => $name);
  }

  # FIXME: should N=0 board be empty graph or single vertex?
  if ($N >= 0) {
    # $players = min($players, $N*$N);

    my $join = ($players < 10 ? '' : ',');
    my $hi = $N-1;
    my $state_to_str = sub {
      my ($state) = @_;
      return join($join, @$state);

      # return $state;
      # for (my $pos = $N*$hi; $pos > 0; $pos -= $N) {
      #   substr($state,$pos,0, '-');
      # }
      # return $state;
    };

    my $initial_state = [ ('0') x ($N*$N) ];
    my $initial_state_str = $state_to_str->($initial_state);
    $graph->add_vertex($initial_state_str);

    if ($players >= 1) {
      ### $N
      ### $hi
      ### $players

      my $xy_to_n = sub {
        my ($x,$y) = @_;
        return $x + $N*$y;
      };

      my @lines;
      {
        @lines = ([ map {$xy_to_n->($_,$_)} 0..$hi ],      # leading diag
                  [ map {$xy_to_n->($hi-$_,$_)} 0..$hi ]); # opposite diag
        foreach my $y (0 .. $hi) {
          push @lines, [ map {$xy_to_n->($_,$y)} 0..$hi ];  # row
        }
        foreach my $x (0 .. $hi) {
          push @lines, [ map {$xy_to_n->($x,$_)} 0..$hi ];  # column
        }
      }
      my $state_is_winning = sub {
        my ($state, $player) = @_;
        foreach my $line (@lines) {
          if ($N == grep {$state->[$_] == $player} @$line) {
            return 1;
          }
        }
        return 0;
      };

      # 2 3  -> 0 2
      # 0 1     1 3
      my $rotate_state = sub {
        my ($state) = @_;
        my @new_state;
        foreach my $y (0 .. $hi) {
          foreach my $x (0 .. $hi) {
            my $rx = $hi-$y;
            my $ry = $x;
            # map: "$x,$y -> $rx,$ry"
            push @new_state, $state->[$xy_to_n->($rx,$ry)];
          }
        }
        return \@new_state;
      };

      # r: $rotate_state->('0123')

      my $reflect_state = sub {
        my ($state) = @_;
        my @new_state;
        foreach my $y (0 .. $hi) {
          foreach my $x (0 .. $hi) {
            my $rx = $hi - $x;
            push @new_state, $state->[$xy_to_n->($rx,$y)];
          }
        }
        return \@new_state;
      };

      my $all_symmetries = sub {
        my ($state) = @_;
        my @ret = ($state);
        if ($rotate) {
          foreach (2 .. 4) {
            push @ret, $rotate_state->($ret[-1]);
          }
          # rotates: @ret
        }
        if ($reflect) {
          @ret = map {$_, $reflect_state->($_)} @ret;
        }
        return @ret;
      };

      my %canonical;
      my $state_to_canonical = sub {
        my ($state) = @_;
        if ($rotate || $reflect) {
          if (defined(my $new_state = $canonical{$state_to_str->($state)})) {
            return $new_state;
          }
          foreach my $sym_state ($all_symmetries->($state)) {
            $canonical{$state_to_str->($sym_state)} = $state;
          }
        }
        return $state;
      };

      # Recursion goes down to the depth of the graph, which means up to N^2.
      # Could do this in an array instead of on the stack, but expect only
      # graphs of smallish N are practical anyway,
      my $recurse;
      $recurse = sub {
        my ($state, $state_str, $player) = @_;
        $player++;
        if ($player > $players) { $player = 1; }
        ### recurse: "$state_str  player $player"

        my %this_seen;
        foreach my $pos (0 .. $#$state) {
          if ($state->[$pos]) {
            ### already filled: $pos
            next;
          }
          ### $pos
          my $new_state = [@$state];
          $new_state->[$pos] = $player;
          $new_state = $state_to_canonical->($new_state);
          my $new_state_str = $state_to_str->($new_state);

          my $stop_here = $state_is_winning->($new_state, $player)
            || $graph->has_vertex($new_state_str);

          # only one edge if symmetry makes same destinations
          unless ($this_seen{$new_state_str}++) {
            $graph->add_edge($state_str, $new_state_str);
          }

          unless ($stop_here) {
            #### to: $new_state
            $recurse->($new_state, $new_state_str, $player);
          }
        }
      };
      $recurse->($initial_state, $initial_state_str, 0);
    }
  }
  return $graph;
}

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

__END__