Dominoes: Difference between revisions
→{{header|Perl}}
m (→Extra credit: added much faster version (trans Wren)) |
|||
Line 236:
Possible permuted arrangements with flips: 105797996085635281181632579889767907328000000
</pre>
=={{header|Mathematica}}/{{header|Wolfram Language}}==
<lang Mathematica>ClearAll[VisualizeState]
VisualizeState[sol_List, tab_List] := Module[{rects},
rects = Apply[Rectangle[#1 - {1, 1} 0.5, #2 + {1, 1} 0.5] &, sol[[All, 2]], {1}];
Graphics[{FaceForm[], EdgeForm[Black], rects, MapIndexed[Text[Style[#1, 14, Black], #2] &, tab, {2}]}]
]
ClearAll[FindSolutions]
FindSolutions[tab_] := Module[{poss, possshort, possshorti, posssets, posss, sols},
poss = Catenate[MapIndexed[#2 &, tab, {2}]];
possshort = Thread[poss -> Range[Length[poss]]];
possshorti = Thread[Range[Length[poss]] -> poss];
posssets =
Select[Subsets[poss, {2}], Apply[ManhattanDistance]/*EqualTo[1]];
posssets = {# /. possshort, Sort[Extract[tab, #]]} & /@ posssets;
posss = GatherBy[posssets, Last];
posss = #[[1, 2]] -> #[[All, 1]] & /@ posss;
posss //= SortBy[Last/*Length];
sols = {};
ClearAll[RecursePlaceDomino];
RecursePlaceDomino[placed_List, left_List] :=
Module[{newplaced, sortedleft, newleft, next},
If[Length[left] == 0,
AppendTo[sols, placed];
,
sortedleft = SortBy[left, Last/*Length];
next = sortedleft[[1]];
Do[
newplaced = Append[placed, next[[1]] -> n];
newleft = Drop[sortedleft, 1];
newleft[[All, 2]] =
newleft[[All, 2]] /. {___, Alternatives @@ n, ___} :>
Sequence[];
If[AnyTrue[newleft[[All, 2]], Length/*EqualTo[0]], Continue[]];
RecursePlaceDomino[newplaced, newleft]
,
{n, next[[2]]}
];
]
];
RecursePlaceDomino[{}, posss];
sols[[All, All, 2]] = sols[[All, All, 2]] /. possshorti;
sols
]
tab = {{6, 2, 1, 0, 4, 0, 0}, {4, 1, 1, 6, 3, 5, 5}, {5, 4, 3, 2, 0,
5, 1}, {1, 3, 0, 3, 3, 0, 3}, {5, 3, 0, 5, 6, 5, 2}, {4, 4, 2, 1,
6, 2, 2}, {1, 6, 4, 2, 2, 4, 3}, {4, 6, 5, 6, 0, 6, 1}};
sols = FindSolutions[tab];
Length[sols]
VisualizeState[sols[[1]], tab]
tab = {{6, 4, 4, 1, 2, 1, 6}, {6, 4, 2, 3, 1, 6, 4}, {5, 2, 6, 5, 0,
2, 2}, {2, 0, 0, 0, 2, 3, 2}, {5, 5, 4, 5, 3, 4, 0}, {3, 3, 0, 6,
5, 1, 6}, {3, 6, 1, 1, 5, 4, 5}, {4, 3, 1, 0, 1, 3, 0}};
sols = FindSolutions[tab];
Length[sols]
VisualizeState[sols[[1]], tab]
ClearAll[DominoTilingCount]
DominoTilingCount[m_, n_] := Module[{},
Round[Product[
4 Cos[(Pi j)/(m + 1)]^2 + 4 Cos[(Pi k)/(n + 1)]^2, {j,
Ceiling[m/2]}, {k, Ceiling[n/2]}]]
]
arrangements = DominoTilingCount[7, 8] // Round;
permutations = 28!;
flips = 2^28;
Print["Arrangements ignoring values: ", arrangements]
Print["Permutations of 28 dominos: ", permutations]
Print["Permuted arrangements ignoring flipping dominos: ", arrangements*permutations]
Print["Possible flip configurations: ", flips]
Print["Possible permuted arrangements with flips: ", flips*arrangements*permutations]</lang>
{{out}}
<pre>
1
[Graphical output of the solution]
2025
[Graphical output of the first solution]
Arrangements ignoring values: 1292697
Permutations of 28 dominos: 304888344611713860501504000000
Permuted arrangements ignoring flipping dominos: 394128248414528672328712716288000000
Possible flip configurations: 268435456
Possible permuted arrangements with flips: 105797996085635281181632579889767907328000000</pre>
=={{header|Perl}}==
| |||