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


line stmt bran cond sub pod time code
1             # Copyright 2017 Kevin Ryde
2             #
3             # This file is part of Graph-Maker-Other.
4             #
5             # This file is free software; you can redistribute it and/or modify it
6             # under the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # This file is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Graph-Maker-Other. See the file COPYING. If not, see
17             # .
18              
19             package Graph::Maker::NoughtsAndCrosses;
20 1     1   1443 use 5.004;
  1         5  
21 1     1   10 use strict;
  1         2  
  1         37  
22 1     1   158 use Graph::Maker;
  0            
  0            
23              
24             use vars '$VERSION','@ISA';
25             $VERSION = 7;
26             @ISA = ('Graph::Maker');
27              
28             # uncomment this to run the ### lines
29             # use Smart::Comments '###';
30              
31              
32             sub _make_graph {
33             my ($params) = @_;
34             if (my $graph_maker = delete($params->{'graph_maker'})) {
35             return $graph_maker->(%$params);
36             }
37             require Graph;
38             return Graph->new(%$params);
39             }
40              
41             sub init {
42             my ($self, %params) = @_;
43              
44             my $N = delete $params{'N'};
45             if (! defined $N) { $N = 3; }
46             my $rotate = delete $params{'rotate'};
47             my $reflect = delete $params{'reflect'};
48             my $players = delete $params{'players'};
49             if (! defined $players) { $players = 2; }
50              
51             ### $N
52             ### $players
53             ### $rotate
54             ### $reflect
55              
56             my $graph = _make_graph(\%params);
57             {
58             my $name = "Noughts and Crosses ${N}x$N";
59             if ($players != 2) {
60             $name .= ", $players Player" . ($players==1 ? '' : 's');
61             }
62             if ($rotate || $reflect) { $name .= ' up to '; }
63             $name .= join(' and ',
64             ($rotate ? ('Rotation') : ()),
65             ($reflect ? ('Reflection') : ()));
66             $graph->set_graph_attribute (name => $name);
67             }
68              
69             # FIXME: should N=0 board be empty graph or single vertex?
70             if ($N >= 0) {
71             # $players = min($players, $N*$N);
72              
73             my $join = ($players < 10 ? '' : ',');
74             my $hi = $N-1;
75             my $state_to_str = sub {
76             my ($state) = @_;
77             return join($join, @$state);
78              
79             # return $state;
80             # for (my $pos = $N*$hi; $pos > 0; $pos -= $N) {
81             # substr($state,$pos,0, '-');
82             # }
83             # return $state;
84             };
85              
86             my $initial_state = [ ('0') x ($N*$N) ];
87             my $initial_state_str = $state_to_str->($initial_state);
88             $graph->add_vertex($initial_state_str);
89              
90             if ($players >= 1) {
91             ### $N
92             ### $hi
93             ### $players
94              
95             my $xy_to_n = sub {
96             my ($x,$y) = @_;
97             return $x + $N*$y;
98             };
99              
100             my @lines;
101             {
102             @lines = ([ map {$xy_to_n->($_,$_)} 0..$hi ], # leading diag
103             [ map {$xy_to_n->($hi-$_,$_)} 0..$hi ]); # opposite diag
104             foreach my $y (0 .. $hi) {
105             push @lines, [ map {$xy_to_n->($_,$y)} 0..$hi ]; # row
106             }
107             foreach my $x (0 .. $hi) {
108             push @lines, [ map {$xy_to_n->($x,$_)} 0..$hi ]; # column
109             }
110             }
111             my $state_is_winning = sub {
112             my ($state, $player) = @_;
113             foreach my $line (@lines) {
114             if ($N == grep {$state->[$_] == $player} @$line) {
115             return 1;
116             }
117             }
118             return 0;
119             };
120              
121             # 2 3 -> 0 2
122             # 0 1 1 3
123             my $rotate_state = sub {
124             my ($state) = @_;
125             my @new_state;
126             foreach my $y (0 .. $hi) {
127             foreach my $x (0 .. $hi) {
128             my $rx = $hi-$y;
129             my $ry = $x;
130             # map: "$x,$y -> $rx,$ry"
131             push @new_state, $state->[$xy_to_n->($rx,$ry)];
132             }
133             }
134             return \@new_state;
135             };
136              
137             # r: $rotate_state->('0123')
138              
139             my $reflect_state = sub {
140             my ($state) = @_;
141             my @new_state;
142             foreach my $y (0 .. $hi) {
143             foreach my $x (0 .. $hi) {
144             my $rx = $hi - $x;
145             push @new_state, $state->[$xy_to_n->($rx,$y)];
146             }
147             }
148             return \@new_state;
149             };
150              
151             my $all_symmetries = sub {
152             my ($state) = @_;
153             my @ret = ($state);
154             if ($rotate) {
155             foreach (2 .. 4) {
156             push @ret, $rotate_state->($ret[-1]);
157             }
158             # rotates: @ret
159             }
160             if ($reflect) {
161             @ret = map {$_, $reflect_state->($_)} @ret;
162             }
163             return @ret;
164             };
165              
166             my %canonical;
167             my $state_to_canonical = sub {
168             my ($state) = @_;
169             if ($rotate || $reflect) {
170             if (defined(my $new_state = $canonical{$state_to_str->($state)})) {
171             return $new_state;
172             }
173             foreach my $sym_state ($all_symmetries->($state)) {
174             $canonical{$state_to_str->($sym_state)} = $state;
175             }
176             }
177             return $state;
178             };
179              
180             # Recursion goes down to the depth of the graph, which means up to N^2.
181             # Could do this in an array instead of on the stack, but expect only
182             # graphs of smallish N are practical anyway,
183             my $recurse;
184             $recurse = sub {
185             my ($state, $state_str, $player) = @_;
186             $player++;
187             if ($player > $players) { $player = 1; }
188             ### recurse: "$state_str player $player"
189              
190             my %this_seen;
191             foreach my $pos (0 .. $#$state) {
192             if ($state->[$pos]) {
193             ### already filled: $pos
194             next;
195             }
196             ### $pos
197             my $new_state = [@$state];
198             $new_state->[$pos] = $player;
199             $new_state = $state_to_canonical->($new_state);
200             my $new_state_str = $state_to_str->($new_state);
201              
202             my $stop_here = $state_is_winning->($new_state, $player)
203             || $graph->has_vertex($new_state_str);
204              
205             # only one edge if symmetry makes same destinations
206             unless ($this_seen{$new_state_str}++) {
207             $graph->add_edge($state_str, $new_state_str);
208             }
209              
210             unless ($stop_here) {
211             #### to: $new_state
212             $recurse->($new_state, $new_state_str, $player);
213             }
214             }
215             };
216             $recurse->($initial_state, $initial_state_str, 0);
217             }
218             }
219             return $graph;
220             }
221              
222             Graph::Maker->add_factory_type('noughts_and_crosses' => __PACKAGE__);
223             1;
224              
225             __END__