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

Initial data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 72d218235f
commit f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

114
Task/Zebra-puzzle/Mathematica/zebra-puzzle.math Normal file
View file

@ -0,0 +1,114 @@
ClearAll[EliminatePoss, FilterPuzzle]
EliminatePoss[ct_, key1_, key2_] := Module[{t = ct, poss1, poss2, poss, notposs},
poss1 = Position[t, key1];
poss2 = Position[t, key2];
poss = Intersection[Last /@ poss1, Last /@ poss2];
notposs = Complement[Range[5], poss];
poss1 = Select[poss1, MemberQ[notposs, Last[#]] &];
poss2 = Select[poss2, MemberQ[notposs, Last[#]] &];
t = ReplacePart[t, poss1 -> Null];
t = ReplacePart[t, poss2 -> Null];
t
]
FilterPuzzle[tbl_] := Module[{t = tbl, poss1, poss2, poss, notposs, rows, columns, vals, sets, delpos},
t = EliminatePoss[t, "English", "Red"]; (*2. The English man lives in the red house. *)
t = EliminatePoss[t, "Swede", "Dog"]; (* 3. The Swede has a dog. *)
t = EliminatePoss[t, "Dane", "Tea"]; (* 4. The Dane drinks tea. *)
t = EliminatePoss[t, "Green", "Coffee"]; (* 6. They drink coffee in the green house. *)
t = EliminatePoss[t, "Pall Mall", "Birds"]; (* 7. The man who smokes Pall Mall has birds.*)
t = EliminatePoss[t, "Yellow", "Dunhill"]; (* 8. In the yellow house they smoke Dunhill. *)
t = EliminatePoss[t, "Blue Master", "Beer"]; (*13. The man who smokes Blue Master drinks beer. *)
t = EliminatePoss[t, "German", "Prince"]; (* 14. The German smokes Prince. *)
(* 9. In the middle house they drink milk. *)
poss = Position[t, "Milk"];
delpos = Select[poss, #[[2]] != 3 &];
t = ReplacePart[t, delpos -> Null];
(* 10. The Norwegian lives in the first house. *)
poss = Position[t, "Norwegian"];
delpos = Select[poss, #[[2]] != 1 &];
t = ReplacePart[t, delpos -> Null];
(* 15. The Norwegian lives next to the blue house.*)
poss1 = Position[t, "Norwegian"];
poss2 = Position[t, "Blue"];
poss = Tuples[{poss1, poss2}];
poss = Select[poss, #[[1, 2]] + 1 == #[[2, 2]] \[Or] #[[1, 2]] - 1 == #[[2, 2]] &]\[Transpose];
delpos = Complement[poss1, poss[[1]]];
t = ReplacePart[t, delpos -> Null];
delpos = Complement[poss2, poss[[2]]];
t = ReplacePart[t, delpos -> Null];
(* 5. The green house is immediately to the left of the white house. *)
poss1 = Position[t, "Green"];
poss2 = Position[t, "White"];
poss = Tuples[{poss1, poss2}];
poss = Select[poss, #[[1, 2]] + 1 == #[[2, 2]] &]\[Transpose];
delpos = Complement[poss1, poss[[1]]];
t = ReplacePart[t, delpos -> Null];
delpos = Complement[poss2, poss[[2]]];
t = ReplacePart[t, delpos -> Null];
(*11. The man who smokes Blend lives in the house next to the house with cats.*)
poss1 = Position[t, "Blend"];
poss2 = Position[t, "Cats"];
poss = Tuples[{poss1, poss2}];
poss = Select[poss, #[[1, 2]] + 1 == #[[2, 2]] \[Or] #[[1, 2]] - 1 == #[[2, 2]] &]\[Transpose];
delpos = Complement[poss1, poss[[1]]];
t = ReplacePart[t, delpos -> Null];
delpos = Complement[poss2, poss[[2]]];
t = ReplacePart[t, delpos -> Null];
(* 12. In a house next to the house where they have a horse, they smoke Dunhill. *)
poss1 = Position[t, "Horse"];
poss2 = Position[t, "Dunhill"];
poss = Tuples[{poss1, poss2}];
poss = Select[poss, #[[1, 2]] + 1 == #[[2, 2]] \[Or] #[[1, 2]] - 1 == #[[2, 2]] &]\[Transpose];
delpos = Complement[poss1, poss[[1]]];
t = ReplacePart[t, delpos -> Null];
delpos = Complement[poss2, poss[[2]]];
t = ReplacePart[t, delpos -> Null];
(* 16. They drink water in a house next to the house where they smoke Blend. *)
poss1 = Position[t, "Water"];
poss2 = Position[t, "Blend"];
poss = Tuples[{poss1, poss2}];
poss = Select[poss, #[[1, 2]] + 1 == #[[2, 2]] \[Or] #[[1, 2]] - 1 == #[[2, 2]] &]\[Transpose];
delpos = Complement[poss1, poss[[1]]];
t = ReplacePart[t, delpos -> Null];
delpos = Complement[poss2, poss[[2]]];
t = ReplacePart[t, delpos -> Null];
(*General rule 1 in a line => cross out vertical and horizontal lines*)
(* 1 in a row*)
vals = Select[t, Count[#, Null] == 4 &];
vals = DeleteCases[Flatten[vals], Null];
poss = Flatten[Position[t, #] & /@ vals, 1];
delpos = With[{r = First[#], c = Last[#]}, {#, c} & /@ (Range[-4, 0] + Ceiling[r, 5])] & /@ poss; (*delete in columns*)
delpos = Flatten[MapThread[DeleteCases, {delpos, poss}], 1];
t = ReplacePart[t, delpos -> Null];
(* 1 in a column*)
sets = Flatten[Table[{i + k*5, j}, {k, 0, 4}, {j, 1, 5}, {i, 1, 5}],1];
sets = {#, Extract[t, #]} & /@ sets;
sets = Select[sets, Count[#[[2]], Null] == 4 &];
sets = Flatten[Transpose /@ sets, 1];
sets = DeleteCases[sets, {{_, _}, Null}];
delpos = sets[[All, 1]];(*delete in rows*)
delpos = With[{r = First[#], c = Last[#]}, {r, #} & /@ (DeleteCases[Range[5], c])] & /@ delpos;
delpos = Flatten[delpos, 1];
t = ReplacePart[t, delpos -> Null];
t
]
colors = {"Blue", "Green", "Red", "White", "Yellow"};
nationality = {"Dane", "English", "German", "Norwegian", "Swede"};
beverage = {"Beer", "Coffee", "Milk", "Tea", "Water"};
animal = {"Birds", "Cats", "Dog", "Horse", "Zebra"};
smoke = {"Blend", "Blue Master", "Dunhill", "Pall Mall", "Prince"};
vals = {colors, nationality, beverage, animal, smoke};
bigtable = Join @@ (ConstantArray[#, 5]\[Transpose] & /@ vals);
bigtable = FixedPoint[FilterPuzzle, bigtable];
TableForm[DeleteCases[bigtable\[Transpose], Null, \[Infinity]], TableHeadings -> {Range[5], None}]