$Games::ABC_Path::Solver::Board::VERSION
=
'0.8.1'
;
use
5.014;
my
$ABCP_VERDICT_NO
= 0;
my
$ABCP_VERDICT_MAYBE
= 1;
my
$ABCP_VERDICT_YES
= 2;
my
%letters_map
= (
map
{
$letters
[
$_
] =>
$_
} ( 0 ..
$ABCP_MAX_LETTER
) );
sub
_get_letter_numeric
{
my
(
$self
,
$letter_ascii
) =
@_
;
my
$index
=
$letters_map
{
$letter_ascii
};
if
( !
defined
(
$index
) )
{
confess
"Unknown letter '$letter_ascii'"
;
}
return
$index
;
}
sub
_iter_changed
{
my
$self
=
shift
;
if
(
@_
)
{
$self
->{_iter_changed} =
shift
;
}
return
$self
->{_iter_changed};
}
sub
_moves
{
my
$self
=
shift
;
if
(
@_
)
{
$self
->{_moves} =
shift
;
}
return
$self
->{_moves};
}
sub
_error
{
my
$self
=
shift
;
if
(
@_
)
{
$self
->{_error} =
shift
;
}
return
$self
->{_error};
}
sub
_inc_changed
{
my
(
$self
) =
@_
;
$self
->_iter_changed(
$self
->_iter_changed + 1 );
return
;
}
sub
_flush_changed
{
my
(
$self
) =
@_
;
my
$ret
=
$self
->_iter_changed;
$self
->_iter_changed(0);
return
$ret
;
}
sub
_add_move
{
my
(
$self
,
$move
) =
@_
;
push
@{
$self
->_moves() },
$move
;
$self
->_inc_changed;
return
;
}
sub
get_successful_layouts
{
my
(
$self
) =
@_
;
return
[ @{
$self
->_successful_layouts } ];
}
sub
_successful_layouts
{
my
$self
=
shift
;
if
(
@_
)
{
$self
->{_successful_layouts} =
shift
;
}
return
$self
->{_successful_layouts};
}
sub
_layout
{
my
$self
=
shift
;
if
(
@_
)
{
$self
->{_layout} =
shift
;
}
return
$self
->{_layout};
}
sub
_l_indexes
{
return
( 0 ..
$ABCP_MAX_LETTER
);
}
sub
_init
{
my
(
$self
,
$args
) =
@_
;
my
$layout_string
=
$args
->{layout};
if
( !
defined
(
$layout_string
) )
{
$layout_string
=
''
;
}
$self
->_layout( \
$layout_string
);
$self
->_successful_layouts( [] );
$self
->_moves( [] );
$self
->_iter_changed(0);
return
;
}
sub
_calc_offset
{
my
(
$self
,
$letter
,
$xy
) =
@_
;
if
( (
$letter
< 0 ) or (
$letter
>= 25 ) )
{
confess
"Letter $letter out of range."
;
}
return
$letter
*
$BOARD_SIZE
+
$self
->_xy_to_int( [
$xy
->y,
$xy
->x ] );
}
sub
_get_verdict
{
my
(
$self
,
$letter
,
$xy
) =
@_
;
return
vec
( ${
$self
->_layout },
$self
->_calc_offset(
$letter
,
$xy
, ), 2 );
}
sub
_set_verdict
{
my
(
$self
,
$letter
,
$xy
,
$verdict
) =
@_
;
if
(
@_
!= 4 )
{
confess
"_set_verdict has wrong number of args."
;
}
if
(
not( (
$verdict
==
$ABCP_VERDICT_NO
)
|| (
$verdict
==
$ABCP_VERDICT_MAYBE
)
|| (
$verdict
==
$ABCP_VERDICT_YES
) )
)
{
confess
"Invalid verdict $verdict ."
;
}
vec
( ${
$self
->_layout },
$self
->_calc_offset(
$letter
,
$xy
), 2 ) =
$verdict
;
return
;
}
sub
_xy_loop
{
my
(
$self
,
$sub_ref
) = (
@_
);
foreach
my
$y
(
$self
->_y_indexes )
{
if
(
$self
->_error() )
{
return
;
}
foreach
my
$x
(
$self
->_x_indexes )
{
if
(
$self
->_error() )
{
return
;
}
$sub_ref
->(
Games::ABC_Path::Solver::Coord->new( {
x
=>
$x
,
y
=>
$y
} ) );
}
}
return
;
}
sub
_set_verdicts_for_letter_sets
{
my
(
$self
,
$letter_list
,
$maybe_list
) =
@_
;
my
%cell_is_maybe
= (
map
{
$_
->_to_s() => 1 }
@$maybe_list
);
foreach
my
$letter_ascii
(
@$letter_list
)
{
my
$letter
=
$self
->_get_letter_numeric(
$letter_ascii
);
$self
->_xy_loop(
sub
{
my
(
$xy
) =
@_
;
$self
->_set_verdict(
$letter
,
$xy
,
(
(
exists
$cell_is_maybe
{
$xy
->_to_s() } )
?
$ABCP_VERDICT_MAYBE
:
$ABCP_VERDICT_NO
)
);
}
);
}
return
;
}
sub
_set_conclusive_verdict_for_letter
{
my
(
$self
,
$letter
,
$l_xy
) =
@_
;
$self
->_xy_loop(
sub
{
my
(
$xy
) =
@_
;
$self
->_set_verdict(
$letter
,
$xy
,
(
$l_xy
->_equal(
$xy
)
?
$ABCP_VERDICT_YES
:
$ABCP_VERDICT_NO
)
);
}
);
OTHER_LETTER:
foreach
my
$other_letter
(
$self
->_l_indexes )
{
if
(
$other_letter
==
$letter
)
{
next
OTHER_LETTER;
}
$self
->_set_verdict(
$other_letter
,
$l_xy
,
$ABCP_VERDICT_NO
);
}
return
;
}
sub
_get_possible_letter_indexes
{
my
(
$self
,
$xy
) =
@_
;
return
[
grep
{
$self
->_get_verdict(
$_
,
$xy
) !=
$ABCP_VERDICT_NO
}
$self
->_l_indexes() ];
}
sub
get_possible_letters_for_cell
{
my
(
$self
,
$x
,
$y
) =
@_
;
return
[
@letters
[
@{
$self
->_get_possible_letter_indexes(
Games::ABC_Path::Solver::Coord->new( {
x
=>
$x
,
y
=>
$y
} )
)
}
]
];
}
sub
_get_possible_letters_string
{
my
(
$self
,
$xy
) =
@_
;
return
join
(
','
,
@{
$self
->get_possible_letters_for_cell(
$xy
->x,
$xy
->y ) } );
}
sub
_infer_letters
{
my
(
$self
) =
@_
;
foreach
my
$letter
(
$self
->_l_indexes )
{
my
@true_cells
;
$self
->_xy_loop(
sub
{
my
(
$xy
) =
@_
;
my
$ver
=
$self
->_get_verdict(
$letter
,
$xy
);
if
( (
$ver
==
$ABCP_VERDICT_YES
)
|| (
$ver
==
$ABCP_VERDICT_MAYBE
) )
{
push
@true_cells
,
$xy
;
}
}
);
if
( !
@true_cells
)
{
$self
->_error( [
'letter'
,
$letter
] );
return
;
}
elsif
(
@true_cells
== 1 )
{
my
$xy
=
$true_cells
[0];
if
(
$self
->_get_verdict(
$letter
,
$xy
) ==
$ABCP_VERDICT_MAYBE
)
{
$self
->_set_conclusive_verdict_for_letter(
$letter
,
$xy
);
$self
->_add_move(
Games::ABC_Path::Solver::Move::LastRemainingCellForLetter
->new(
{
vars
=> {
letter
=>
$letter
,
coords
=>
$xy
,
},
}
)
);
}
}
my
@neighbourhood
= (
map
{ [ (0) x
$LEN
] } (
$self
->_y_indexes ) );
foreach
my
$true
(
@true_cells
)
{
foreach
my
$coords
(
grep
{
$self
->_x_in_range(
$_
->[0] )
and
$self
->_y_in_range(
$_
->[1] )
}
map
{ [
$true
->x +
$_
->[0],
$true
->y +
$_
->[1] ] }
map
{
my
$d
=
$_
;
map
{ [
$_
,
$d
] } ( -1 .. 1 )
} ( -1 .. 1 )
)
{
$neighbourhood
[
$coords
->[1] ][
$coords
->[0] ] = 1;
}
}
foreach
my
$neighbour_letter
(
( (
$letter
> 0 ) ? (
$letter
- 1 ) : () ),
( (
$letter
<
$ABCP_MAX_LETTER
) ? (
$letter
+ 1 ) : () ),
)
{
$self
->_xy_loop(
sub
{
my
(
$xy
) =
@_
;
if
(
$neighbourhood
[
$xy
->y ][
$xy
->x ] )
{
return
;
}
my
$existing_verdict
=
$self
->_get_verdict(
$neighbour_letter
,
$xy
);
if
(
$existing_verdict
==
$ABCP_VERDICT_YES
)
{
$self
->_error( [
'mismatched_verdict'
,
$xy
] );
return
;
}
if
(
$existing_verdict
==
$ABCP_VERDICT_MAYBE
)
{
$self
->_set_verdict(
$neighbour_letter
,
$xy
,
$ABCP_VERDICT_NO
);
$self
->_add_move(
Games::ABC_Path::Solver::Move::LettersNotInVicinity
->new(
{
vars
=> {
target
=>
$neighbour_letter
,
coords
=>
$xy
,
source
=>
$letter
,
},
}
)
);
}
}
);
}
}
return
;
}
sub
_infer_cells
{
my
(
$self
) =
@_
;
$self
->_xy_loop(
sub
{
my
(
$xy
) =
@_
;
my
$letters_aref
=
$self
->_get_possible_letter_indexes(
$xy
);
if
( !
@$letters_aref
)
{
$self
->_error( [
'cell'
,
$xy
] );
return
;
}
elsif
(
@$letters_aref
== 1 )
{
my
$letter
=
$letters_aref
->[0];
if
(
$self
->_get_verdict(
$letter
,
$xy
) ==
$ABCP_VERDICT_MAYBE
)
{
$self
->_set_conclusive_verdict_for_letter(
$letter
,
$xy
);
$self
->_add_move(
Games::ABC_Path::Solver::Move::LastRemainingLetterForCell
->new(
{
vars
=> {
coords
=>
$xy
,
letter
=>
$letter
,
},
},
)
);
}
}
}
);
return
;
}
sub
_inference_iteration
{
my
(
$self
) =
@_
;
$self
->_infer_letters;
$self
->_infer_cells;
return
$self
->_flush_changed;
}
sub
_neighbourhood_and_individuality_inferring
{
my
(
$self
) =
@_
;
my
$num_changed
= 0;
while
(
my
$iter_changed
=
$self
->_inference_iteration() )
{
if
(
$self
->_error() )
{
return
;
}
$num_changed
+=
$iter_changed
;
}
return
$num_changed
;
}
sub
_clone
{
my
(
$self
) =
@_
;
return
ref
(
$self
)->new(
{
layout
=> ${
$self
->_layout() },
}
);
}
sub
solve
{
my
(
$self
) =
@_
;
my
$error
=
$self
->_solve_wrapper;
return
[
map
{
my
$obj
=
$_
;
( blessed(
$obj
) &&
$obj
->isa(
'Games::ABC_Path::Solver::Coord'
) )
? (
$obj
->x,
$obj
->y )
: (
$obj
)
}
@$error
];
}
sub
_solve_wrapper
{
my
(
$self
) =
@_
;
$self
->_neighbourhood_and_individuality_inferring;
if
(
$self
->_error )
{
return
$self
->_error;
}
my
@min_coords
;
my
@min_options
;
$self
->_xy_loop(
sub
{
my
(
$xy
) =
@_
;
my
$letters_aref
=
$self
->_get_possible_letter_indexes(
$xy
);
if
( !
@$letters_aref
)
{
$self
->_error( [
'cell'
,
$xy
] );
}
elsif
(
@$letters_aref
> 1 )
{
if
( ( !
@min_coords
) or (
@$letters_aref
<
@min_options
) )
{
@min_options
=
@$letters_aref
;
@min_coords
= (
$xy
);
}
}
return
;
}
);
if
(
$self
->_error )
{
return
$self
->_error;
}
if
(
@min_coords
)
{
my
(
$xy
) =
@min_coords
;
foreach
my
$letter
(
@min_options
)
{
my
$recurse_solver
=
$self
->_clone;
$self
->_add_move(
Games::ABC_Path::Solver::Move::TryingLetterForCell->new(
{
vars
=> {
letter
=>
$letter
,
coords
=>
$xy
, },
}
),
);
$recurse_solver
->_set_conclusive_verdict_for_letter(
$letter
,
$xy
);
$recurse_solver
->_solve_wrapper;
foreach
my
$move
( @{
$recurse_solver
->get_moves } )
{
$self
->_add_move(
$move
->bump() );
}
if
(
$recurse_solver
->_error() )
{
$self
->_add_move(
Games::ABC_Path::Solver::Move::ResultsInAnError->new(
{
vars
=> {
letter
=>
$letter
,
coords
=>
$xy
,
},
}
)
);
}
else
{
$self
->_add_move(
Games::ABC_Path::Solver::Move::ResultsInASuccess->new(
{
vars
=> {
letter
=>
$letter
,
coords
=>
$xy
, },
}
)
);
push
@{
$self
->_successful_layouts },
@{
$recurse_solver
->get_successful_layouts() };
}
}
my
$count
= @{
$self
->_successful_layouts() };
if
( !
$count
)
{
return
[
'all_options_bad'
];
}
elsif
(
$count
== 1 )
{
return
[
'success'
];
}
else
{
return
[
'success_multiple'
];
}
}
else
{
$self
->_successful_layouts( [
$self
->_clone() ] );
return
[
'success'
];
}
}
my
$letter_re_s
=
join
(
''
,
map
{
quotemeta
(
$_
) }
@letters
);
my
$letter_re
=
qr{[$letter_re_s]}
;
my
$letter_and_space_re
=
qr{[ $letter_re_s]}
;
my
$top_bottom_re
=
qr/^${letter_re}{7}\n/
ms;
my
$inner_re
=
qr/^${letter_re}${letter_and_space_re}{5}${letter_re}\n/
ms;
sub
_assert_letters_appear_once
{
my
(
$self
,
$layout_string
) =
@_
;
my
%count_letters
= (
map
{
$_
=> 0 }
@letters
);
foreach
my
$letter
(
$layout_string
=~ m{(
$letter_re
)}g )
{
if
(
$count_letters
{
$letter
}++ )
{
confess
"Letter '$letter' encountered twice in the layout."
;
}
}
return
;
}
sub
_process_major_diagonal
{
my
(
$self
,
$args
) =
@_
;
my
@major_diagonal_letters
;
$args
->{top} =~ m{\A(
$letter_re
)};
push
@major_diagonal_letters
, $1;
$args
->{bottom} =~ m{(
$letter_re
)\z};
push
@major_diagonal_letters
, $1;
$self
->_set_verdicts_for_letter_sets(
\
@major_diagonal_letters
,
[
map
{ Games::ABC_Path::Solver::Coord->new( {
x
=>
$_
,
y
=>
$_
} ) }
$self
->_y_indexes
],
);
return
;
}
sub
_process_minor_diagonal
{
my
(
$self
,
$args
) =
@_
;
my
@minor_diagonal_letters
;
$args
->{top} =~ m{(
$letter_re
)\z};
push
@minor_diagonal_letters
, $1;
$args
->{bottom} =~ m{\A(
$letter_re
)};
push
@minor_diagonal_letters
, $1;
$self
->_set_verdicts_for_letter_sets(
\
@minor_diagonal_letters
,
[
map
{
Games::ABC_Path::Solver::Coord->new( {
x
=>
$_
,
y
=> 4 -
$_
} )
} (
$self
->_y_indexes )
]
);
return
;
}
sub
_process_input_columns
{
my
(
$self
,
$args
) =
@_
;
my
$top_row
=
$args
->{top};
my
$bottom_row
=
$args
->{bottom};
foreach
my
$x
(
$self
->_x_indexes )
{
$self
->_set_verdicts_for_letter_sets(
[
substr
(
$top_row
,
$x
+ 1, 1 ),
substr
(
$bottom_row
,
$x
+ 1, 1 ),
],
[
map
{
Games::ABC_Path::Solver::Coord->new( {
x
=>
$x
,
y
=>
$_
} )
}
$self
->_y_indexes
],
);
}
return
;
}
sub
_process_input_rows_and_initial_letter_clue
{
my
(
$self
,
$args
) =
@_
;
my
$rows
=
$args
->{rows};
my
(
$clue_x
,
$clue_y
,
$clue_letter
);
foreach
my
$y
(
$self
->_y_indexes )
{
my
$row
=
$rows
->[
$y
];
$self
->_set_verdicts_for_letter_sets(
[
substr
(
$row
, 0, 1 ),
substr
(
$row
, -1 ), ],
[
map
{
Games::ABC_Path::Solver::Coord->new( {
x
=>
$_
,
y
=>
$y
} )
}
$self
->_x_indexes
],
);
my
$s
=
substr
(
$row
, 1, -1 );
if
(
$s
=~ m{(
$letter_re
)}g )
{
my
(
$l
,
$x_plus_1
) = ( $1,
pos
(
$s
) );
if
(
defined
(
$clue_letter
) )
{
confess
"Found more than one clue letter in the layout!"
;
}
(
$clue_x
,
$clue_y
,
$clue_letter
) = (
$x_plus_1
- 1,
$y
,
$l
);
}
}
if
( !
defined
(
$clue_letter
) )
{
confess
"Did not find any clue letters inside the layout."
;
}
$self
->_set_conclusive_verdict_for_letter(
$self
->_get_letter_numeric(
$clue_letter
),
Games::ABC_Path::Solver::Coord->new( {
x
=>
$clue_x
,
y
=>
$clue_y
} ),
);
return
;
}
sub
_input
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{version} ne 1 )
{
die
"Can only handle version 1"
;
}
my
$layout_string
=
$args
->{layout};
if
(
$layout_string
!~
m/\A${top_bottom_re}${inner_re}{5}${top_bottom_re}\z/ms )
{
die
"Invalid format. Should be Letter{7}\n(Letter{spaces or one letter}{5}Letter){5}\nLetter{7}"
;
}
my
@rows
=
split
( /\n/,
$layout_string
);
my
$top_row
=
shift
(
@rows
);
my
$bottom_row
=
pop
(
@rows
);
$self
->_assert_letters_appear_once(
$layout_string
);
my
$parse_context
=
{
top
=>
$top_row
,
bottom
=>
$bottom_row
,
rows
=> \
@rows
, };
$self
->_process_major_diagonal(
$parse_context
);
$self
->_process_minor_diagonal(
$parse_context
);
$self
->_process_input_columns(
$parse_context
);
$self
->_process_input_rows_and_initial_letter_clue(
$parse_context
);
return
;
}
sub
_get_results_text_table
{
my
(
$self
) =
@_
;
my
$render_row
=
sub
{
my
$cols
=
shift
;
return
"| "
.
join
(
" | "
,
map
{
length
(
$_
) == 1 ?
" $_ "
:
$_
}
@$cols
)
.
" |\n"
;
};
return
join
(
''
,
map
{
$render_row
->(
$_
) } (
[
map
{
sprintf
(
"X = %d"
,
$_
+ 1 ) }
$self
->_x_indexes ],
map
{
my
$y
=
$_
;
[
map
{
$self
->_get_possible_letters_string(
Games::ABC_Path::Solver::Coord->new(
{
x
=>
$_
,
y
=>
$y
}
)
)
}
$self
->_x_indexes
]
}
$self
->_y_indexes
)
);
}
sub
get_successes_text_tables
{
my
(
$self
) =
@_
;
return
[
map
{
$_
->_get_results_text_table() }
@{
$self
->get_successful_layouts() } ];
}
sub
input_from_file
{
my
(
$class
,
$board_fn
) =
@_
;
open
my
$in_fh
,
"<"
,
$board_fn
or
die
"Cannot open '$board_fn' - $!"
;
my
$first_line
= <
$in_fh
>;
chomp
(
$first_line
);
my
$magic
=
'ABC Path Solver Layout Version 1:'
;
if
(
$first_line
!~ m{\A\Q
$magic
\E\s*\z} )
{
die
"Can only process files whose first line is '$magic'!"
;
}
my
$layout_string
=
''
;
foreach
my
$line_idx
( 1 .. 7 )
{
chomp
(
my
$line
= <
$in_fh
> );
$layout_string
.=
"$line\n"
;
}
close
(
$in_fh
);
return
$class
->input_from_v1_string(
$layout_string
);
}
sub
input_from_v1_string
{
my
(
$class
,
$layout_string
) =
@_
;
my
$self
=
$class
->new;
$self
->_input( {
layout
=>
$layout_string
,
version
=> 1 } );
return
$self
;
}
sub
get_moves
{
my
(
$self
) =
@_
;
return
[ @{
$self
->_moves } ];
}
1;