366 lines
11 KiB
Text
366 lines
11 KiB
Text
ClearAll[NeighbourQ, CellDistance, VisualizeHidato, HiddenSingle, \
|
|
NakedN, HiddenN, ChainSearch, HidatoSolve, Cornering, ValidPuzzle, \
|
|
GapSearch, ReachDelete, GrowNeighbours]
|
|
NeighbourQ[cell1_, cell2_] := (CellDistance[cell1, cell2] === 1)
|
|
ValidPuzzle[cells_List, cands_List] :=
|
|
MemberQ[cands, {1}] \[And] MemberQ[cands, {Length[cells]}] \[And]
|
|
Length[cells] == Length[candidates] \[And]
|
|
MinMax[Flatten[cands]] === {1,
|
|
Length[cells]} \[And] (Union @@ cands === Range[Length[cells]])
|
|
CellDistance[cell1_, cell2_] := ManhattanDistance[cell1, cell2]
|
|
VisualizeHidato[cells_List, cands_List, path_ : {}] :=
|
|
Module[{grid, nums, cb, hx, pt},
|
|
grid = {EdgeForm[Thick],
|
|
MapThread[
|
|
If[Length[#2] > 1, {FaceForm[],
|
|
Rectangle[#1]}, {FaceForm[LightGray],
|
|
Rectangle[#1]}] &, {cells, cands}]};
|
|
nums =
|
|
MapThread[
|
|
If[Length[#1] == 1, Text[Style[First[#1], 16], #2 + 0.5 {1, 1}],
|
|
Text[
|
|
Tooltip[Style[Length[#1], Red, 10], #1], #2 +
|
|
0.5 {1, 1}]] &, {cands, cells}];
|
|
cb = CoordinateBounds[cells];
|
|
If[Length[path] > 0,
|
|
pt = Arrow[# + {0.5, 0.5} & /@ cells[[path]]];
|
|
,
|
|
pt = {};
|
|
];
|
|
Graphics[{grid, nums, pt},
|
|
PlotRange -> cb + {{-0.5, 1.5}, {-0.5, 1.5}},
|
|
ImageSize -> 60 (1 + cb[[1, 2]] - cb[[1, 1]])]
|
|
]
|
|
HiddenSingle[cands_List] := Module[{singles, newcands = cands},
|
|
singles = Cases[Tally[Flatten[cands]], {_, 1}];
|
|
If[Length[singles] > 0,
|
|
singles = Sort[singles[[All, 1]]];
|
|
newcands =
|
|
If[ContainsAny[#, singles], Intersection[#, singles], #] & /@
|
|
newcands;
|
|
newcands
|
|
,
|
|
cands
|
|
]
|
|
]
|
|
HiddenN[cands_List, n_Integer?(# > 1 &)] := Module[{tmp, out},
|
|
tmp = cands;
|
|
tmp = Join @@ MapIndexed[{#1, First[#2]} &, tmp, {2}];
|
|
tmp = Transpose /@ GatherBy[tmp, First];
|
|
tmp[[All, 1]] = tmp[[All, 1, 1]];
|
|
tmp = Select[tmp, 2 <= Length[Last[#]] <= n &];
|
|
If[Length[tmp] > 0,
|
|
tmp = Transpose /@ Subsets[tmp, {n}];
|
|
tmp[[All, 2]] = Union @@@ tmp[[All, 2]];
|
|
tmp = Select[tmp, Length[Last[#]] == n &];
|
|
If[Length[tmp] > 0,
|
|
(* for each tmp {cands,
|
|
cells} in each of the cells delete everything except the cands *)
|
|
|
|
out = cands;
|
|
Do[
|
|
Do[
|
|
out[[c]] = Select[out[[c]], MemberQ[t[[1]], #] &];
|
|
,
|
|
{c, t[[2]]}
|
|
]
|
|
,
|
|
{t, tmp}
|
|
];
|
|
out
|
|
,
|
|
cands
|
|
]
|
|
,
|
|
cands
|
|
]
|
|
]
|
|
NakedN[cands_List, n_Integer?(# > 1 &)] := Module[{tmp, newcands, ids},
|
|
tmp = {Range[Length[cands]], cands}\[Transpose];
|
|
tmp = Select[tmp, 2 <= Length[Last[#]] <= n &];
|
|
If[Length[tmp] > 0,
|
|
tmp = Transpose /@ Subsets[tmp, {n}];
|
|
tmp[[All, 2]] = Union @@@ tmp[[All, 2]];
|
|
tmp = Select[tmp, Length[Last[#]] == n &];
|
|
If[Length[tmp] > 0,
|
|
newcands = cands;
|
|
Do[
|
|
ids = Complement[Range[Length[newcands]], t[[1]]];
|
|
newcands[[ids]] =
|
|
DeleteCases[newcands[[ids]],
|
|
Alternatives @@ t[[2]], \[Infinity]];
|
|
,
|
|
{t, tmp}
|
|
];
|
|
newcands
|
|
,
|
|
cands
|
|
]
|
|
,
|
|
cands
|
|
]
|
|
]
|
|
Cornering[cells_List, cands_List] :=
|
|
Module[{newcands, neighbours, filled, neighboursfiltered, cellid,
|
|
filledneighours, begin, end, beginend},
|
|
filled = Flatten[MapIndexed[If[Length[#1] == 1, #2, {}] &, cands]];
|
|
begin = If[MemberQ[cands, {1}], {}, {1}];
|
|
end = If[MemberQ[cands, {Length[cells]}], {}, {Length[cells]}];
|
|
beginend = Join[begin, end];
|
|
neighbours = Outer[NeighbourQ, cells, cells, 1];
|
|
neighbours =
|
|
Association[
|
|
MapIndexed[
|
|
First[#2] -> {Complement[Flatten[Position[#1, True]], filled],
|
|
Intersection[Flatten[Position[#1, True]], filled]} &,
|
|
neighbours]];
|
|
KeyDropFrom[neighbours, filled];
|
|
neighbours = Select[neighbours, Length[First[#]] == 1 &];
|
|
If[Length[neighbours] > 0,
|
|
newcands = cands;
|
|
neighbours = KeyValueMap[List, neighbours];
|
|
Do[
|
|
cellid = n[[1]];
|
|
filledneighours = n[[2, 2]];
|
|
filledneighours = Join @@ cands[[filledneighours]];
|
|
filledneighours =
|
|
Union[filledneighours - 1, filledneighours + 1];
|
|
filledneighours = Union[filledneighours, beginend];
|
|
newcands[[cellid]] =
|
|
Intersection[newcands[[cellid]], filledneighours];
|
|
,
|
|
{n, neighbours}
|
|
];
|
|
newcands
|
|
,
|
|
cands
|
|
]
|
|
]
|
|
ChainSearch[cells_, cands_] := Module[{neighbours, sols, out},
|
|
neighbours = Outer[NeighbourQ, cells, cells, 1];
|
|
neighbours =
|
|
Association[
|
|
MapIndexed[First[#2] -> Flatten[Position[#1, True]] &,
|
|
neighbours]];
|
|
sols = Reap[ChainSearch[neighbours, cands, {}];][[2]];
|
|
If[Length[sols] > 0,
|
|
sols = sols[[1]];
|
|
If[Length[sols] > 1,
|
|
Print["multiple solutions found, showing first"];
|
|
];
|
|
sols = First[sols];
|
|
out = cands;
|
|
out[[sols]] = List /@ Range[Length[out]];
|
|
out
|
|
,
|
|
cands
|
|
]
|
|
]
|
|
ChainSearch[neighbours_, cands_List, solcellids_List] :=
|
|
Module[{largest, largestid, next, poss},
|
|
largest = Length[solcellids];
|
|
largestid = Last[solcellids, 0];
|
|
If[largest < Length[cands],
|
|
next = largest + 1;
|
|
poss =
|
|
Flatten[MapIndexed[If[MemberQ[#1, next], First[#2], {}] &, cands]];
|
|
If[Length[poss] > 0,
|
|
If[largest > 0,
|
|
poss = Intersection[poss, neighbours[largestid]];
|
|
];
|
|
poss = Complement[poss, solcellids]; (* can't be in previous path*)
|
|
|
|
If[Length[poss] > 0, (* there are 'next' ones iterate over,
|
|
calling this function *)
|
|
Do[
|
|
ChainSearch[neighbours, cands, Append[solcellids, p]]
|
|
,
|
|
{p, poss}
|
|
]
|
|
]
|
|
,
|
|
Print["There should be a next!"];
|
|
Abort[];
|
|
]
|
|
,
|
|
Sow[solcellids] (*
|
|
we found a solution with this ordering of cells *)
|
|
]
|
|
]
|
|
GrowNeighbours[neighbours_, set_List] :=
|
|
Module[{lastdone, ids, newneighbours, old},
|
|
old = Join @@ set[[All, All, 1]];
|
|
lastdone = Last[set];
|
|
ids = lastdone[[All, 1]];
|
|
newneighbours = Union @@ (neighbours /@ ids);
|
|
newneighbours = Complement[newneighbours, old]; (*only new ones*)
|
|
|
|
If[Length[newneighbours] > 0,
|
|
Append[set, Thread[{newneighbours, lastdone[[1, 2]] + 1}]]
|
|
,
|
|
set
|
|
]
|
|
]
|
|
ReachDelete[cells_List, cands_List, neighbours_, startid_] :=
|
|
Module[{seed, distances, val, newcands},
|
|
If[MatchQ[cands[[startid]], {_}],
|
|
val = cands[[startid, 1]];
|
|
seed = {{{startid, 0}}};
|
|
distances =
|
|
Join @@ FixedPoint[GrowNeighbours[neighbours, #] &, seed];
|
|
If[Length[distances] > 0,
|
|
distances = Select[distances, Last[#] > 0 &];
|
|
If[Length[distances] > 0,
|
|
newcands = cands;
|
|
distances[[All, 2]] =
|
|
Transpose[
|
|
val + Outer[Times, {-1, 1}, distances[[All, 2]] - 1]];
|
|
Do[newcands[[\[CurlyPhi][[1]]]] =
|
|
Complement[newcands[[\[CurlyPhi][[1]]]],
|
|
Range @@ \[CurlyPhi][[2]]];
|
|
, {\[CurlyPhi], distances}
|
|
];
|
|
newcands
|
|
,
|
|
cands
|
|
]
|
|
,
|
|
cands
|
|
]
|
|
,
|
|
Print["invalid starting point for neighbour search"];
|
|
Abort[];
|
|
]
|
|
]
|
|
GapSearch[cells_List, cands_List] :=
|
|
Module[{givensid, givens, neighbours},
|
|
givensid = Flatten[Position[cands, {_}]];
|
|
givens = {cells[[givensid]], givensid,
|
|
Flatten[cands[[givensid]]]}\[Transpose];
|
|
If[Length[givens] > 0,
|
|
givens = SortBy[givens, Last];
|
|
givens = Split[givens, Last[#2] == Last[#1] + 1 &];
|
|
givens = If[Length[#] <= 2, #, #[[{1, -1}]]] & /@ givens;
|
|
If[Length[givens] > 0,
|
|
givens = Join @@ givens;
|
|
If[Length[givens] > 0,
|
|
neighbours = Outer[NeighbourQ, cells, cells, 1];
|
|
neighbours =
|
|
Association[
|
|
MapIndexed[First[#2] -> Flatten[Position[#1, True]] &,
|
|
neighbours]];
|
|
givens = givens[[All, 2]];
|
|
Fold[ReachDelete[cells, #1, neighbours, #2] &, cands, givens]
|
|
,
|
|
cands
|
|
]
|
|
,
|
|
cands
|
|
]
|
|
,
|
|
cands
|
|
]
|
|
]
|
|
HidatoSolve[cells_List, cands_List] :=
|
|
Module[{newcands = cands, old},
|
|
Print@VisualizeHidato[cells, newcands];
|
|
If[ValidPuzzle[cells, cands] \[Or] 1 == 1,
|
|
old = -1;
|
|
newcands = GapSearch[cells, newcands];
|
|
While[old =!= newcands,
|
|
old = newcands;
|
|
newcands = GapSearch[cells, newcands];
|
|
If[old === newcands,
|
|
newcands = HiddenSingle[newcands];
|
|
If[old === newcands,
|
|
newcands = NakedN[newcands, 2];
|
|
newcands = HiddenN[newcands, 2];
|
|
If[old === newcands,
|
|
newcands = NakedN[newcands, 3];
|
|
newcands = HiddenN[newcands, 3];
|
|
If[old === newcands,
|
|
newcands = Cornering[cells, newcands];
|
|
If[old === newcands,
|
|
newcands = NakedN[newcands, 4];
|
|
newcands = HiddenN[newcands, 4];
|
|
If[old === newcands \[And] 2 == 3,
|
|
newcands = NakedN[newcands, 5];
|
|
newcands = HiddenN[newcands, 5];
|
|
If[old === newcands,
|
|
newcands = NakedN[newcands, 6];
|
|
newcands = HiddenN[newcands, 6];
|
|
If[old === newcands,
|
|
newcands = NakedN[newcands, 7];
|
|
newcands = HiddenN[newcands, 7];
|
|
If[old === newcands,
|
|
newcands = NakedN[newcands, 8];
|
|
newcands = HiddenN[newcands, 8];
|
|
]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
];
|
|
If[Length[Flatten[newcands]] > Length[newcands], (*
|
|
if not solved do a depth-first brute force search*)
|
|
|
|
newcands = ChainSearch[cells, newcands];
|
|
];
|
|
Print@VisualizeHidato[cells, newcands];
|
|
newcands
|
|
,
|
|
Print[
|
|
"There seems to be something wrong with your Hidato puzzle. Check \
|
|
if the begin and endpoints are given, the cells and candidates have \
|
|
the same length, all the numbers are among the \
|
|
candidates\[Ellipsis]"]
|
|
]
|
|
]
|
|
|
|
puzz = "0 0 0 0 0 0 0 0 0
|
|
0 0 46 45 0 55 74 0 0
|
|
0 38 0 0 43 0 0 78 0
|
|
0 35 0 0 0 0 0 71 0
|
|
0 0 33 0 0 0 59 0 0
|
|
0 17 0 0 0 0 0 67 0
|
|
0 18 0 0 11 0 0 64 0
|
|
0 0 24 21 0 1 2 0 0
|
|
0 0 0 0 0 0 0 0 0";
|
|
puzz = StringSplit[#, " "] & /@
|
|
StringSplit[StringReplace[puzz, " " -> " "], "\n"];
|
|
puzz = Map[StringTrim /* ToExpression, puzz, {2}];
|
|
puzz //= Transpose;
|
|
puzz //= Map[Reverse];
|
|
pos = Position[puzz, Except[0], {2}, Heads -> False];
|
|
clues = Thread[{pos, List /@ Extract[puzz, pos]}];
|
|
cells = Tuples[Range[9], 2];
|
|
candidates = ConstantArray[Range@Length[cells], Length[cells]];
|
|
indices = Flatten[Position[cells, #] & /@ clues[[All, 1]]];
|
|
candidates[[indices]] = clues[[All, 2]];
|
|
out = HidatoSolve[cells, candidates];
|
|
|
|
puzz = " 0 0 0 0 0 0 0 0 0
|
|
0 11 12 15 18 21 62 61 0
|
|
0 6 0 0 0 0 0 60 0
|
|
0 33 0 0 0 0 0 57 0
|
|
0 32 0 0 0 0 0 56 0
|
|
0 37 0 1 0 0 0 73 0
|
|
0 38 0 0 0 0 0 72 0
|
|
0 43 44 47 48 51 76 77 0
|
|
0 0 0 0 0 0 0 0 0";
|
|
puzz = StringSplit[#, " "] & /@
|
|
StringSplit[StringReplace[puzz, " " -> " "], "\n"];
|
|
puzz = Map[StringTrim /* ToExpression, puzz, {2}];
|
|
puzz //= Transpose;
|
|
puzz //= Map[Reverse];
|
|
pos = Position[puzz, Except[0], {2}, Heads -> False];
|
|
clues = Thread[{pos, List /@ Extract[puzz, pos]}];
|
|
cells = Tuples[Range[9], 2];
|
|
candidates = ConstantArray[Range@Length[cells], Length[cells]];
|
|
indices = Flatten[Position[cells, #] & /@ clues[[All, 1]]];
|
|
candidates[[indices]] = clues[[All, 2]];
|
|
out = HidatoSolve[cells, candidates];
|