aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

52
Task/Dominoes/Mathematica/dominoes-1.math Normal file
View file

@ -0,0 +1,52 @@
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]

16
Task/Dominoes/Mathematica/dominoes-2.math Normal file
View file

@ -0,0 +1,16 @@
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]