Eine Zahl und ein Witz,
ohne die Teilbarkeitsbedingung für 7 zu verwenden, die rekursiv ist,
ergeben sich auf den Untermengen vor, hinter und mit 5 gerade 10
Kandidaten
Clear[conwayQ]
conwayQ[o_Integer?Positive] := Block[{l = IntegerDigits[o]},
(DeleteDuplicates[l] == l) && Union[Mod[FromDigits[Take[l, #]], #]
& /@ Range[10]] == {0}
] /; Length[IntegerDigits[o]] == 10
Clear[check1, check2, check3, check4, check6]
check1[o_Integer?Positive] := Block[{l = IntegerDigits[o]},
DisjointQ[{0, 5}, l] && DeleteDuplicates[l] == l
]
check2[{o1_Integer?Positive, o2_Integer?Positive}] :=
DisjointQ[IntegerDigits[o1], IntegerDigits[o2]]
check3[o_Integer?Positive] := EvenQ[First[IntegerDigits[o]]]
check4[{o1_Integer?Positive, o2_Integer?Positive}] :=
Count[Join[IntegerDigits[o1], IntegerDigits[o2]], u_ /; EvenQ[u]] < 4
check6[{o1_Integer?Positive,
o2_Integer?Positive}] := (Mod[Last[IntegerDigits[o1]] + 5 +
First[IntegerDigits[o2]], 3] == 0)
Clear[filter, candidates]
filter[l_List] :=
Block[{l1 = First[l], l4 = IntegerDigits[l[[2, 1]]],
l8 = IntegerDigits[l[[2, 2]]], pe, po, q},
pe = First[Select[l1, EvenQ]]; (* exactly one by construction *)
po = Select[l1, OddQ];
q = First[l4];
{If[Mod[FromDigits[{po[[1]], pe, q}], 3] == 0,
FromDigits[{po[[1]], pe, Splice[l4], 5, Splice[l8], po[[2]], 0}],
Nothing],
If[Mod[FromDigits[{po[[2]], pe, q}], 3] == 0,
FromDigits[{po[[2]], pe, Splice[l4], 5, Splice[l8], po[[1]], 0}],
Nothing]}
]
candidates[] := Block[{l4, l8, l48, l3},
(* cd|4 *)
l4 = Select[Range[12, 96, 4], check1];
(* fgh|8, f gerade wg. abcdef|6 *)
l8 = Select[Range[200, 896, 8], (check1[#] && check3[#]) &];
(* passende cd und fgh Stellen:
höchstens 3 gerade Zahlen dürfen enthalten sein (check4), weil ab|2;
Mod[d + e + f, 3] \[Equal] 0 weil abc|3 und abcdef|6 *)
l48 = Select[Flatten[Outer[List, l4, l8], 1], (check2[#] &&
check4[#] && check6[#]) &];
(* abc|3 *)
l3 = Transpose[{Complement[
Drop[
Range[9], {5}], #] & /@ (Union @@@ ((IntegerDigits /@ #) & /@
l48)), l48}];
Flatten[filter /@ l3]
]
In[22]:= (* machine solution, not having used the 7 divisibility rule *)
candidates[]
Out[22]= {7412589630, 9816543270, 3816547290, 9816547230, 1836547290, \
1472589630, 9876543210, 1896543270, 7896543210, 1896547230}
In[23]:= If[conwayQ[#], #, 0] & /@ candidates[]
Out[23]= {0, 0, 3816547290, 0, 0, 0, 0, 0, 0, 0}
deren einer der Witz ist
In[24]:= Take[candidates[], {7}]
Out[24]= {9876543210}
Grüsse
Udo.
Am 18.10.2020 um 10:42 schrieb Susanne & Udo Krause via demug:
Moin moin
im Quantamagazine steht eine Aufgabe von J. H. Conway
------------------------------------------------------------------------
https://www.quantamagazine.org/three-math-puzzles-inspired-by-john-horton-conway-20201015/
------------------------------------------------------------------------
There is a mysterious 10 - digit decimal number, abcdefghij.
Each of the digits is different, and they have the following
properties :
* a is divisible by 1
* ab is divisible by 2
* abc is divisible by 3
* abcd is divisible by 4
* abcde is divisible by 5
* abcdef is divisible by 6
* abcdefg is divisible by 7
* abcdefgh is divisible by 8
* abcdefghi is divisible by 9
* abcdefghij is divisible by 10
What' s the number?
------------------------------------------------------------------------
Ein Kandidat kann mit
Clear[conwayQ]
conwayQ[o_Integer?Positive] := Block[{l = IntegerDigits[o]},
(DeleteDuplicates[l] == l) && Union[Mod[FromDigits[Take[l, #]], #]
& /@ Range[10]] == {0}
] /; Length[IntegerDigits[o]] == 10
geprüft werden, z.B. dieses x:
In[200]:= IntegerQ[x] && Positive[x]
Out[200]= True
In[201]:= conwayQ[x]
Out[201]= True
das iss'es doch.
Grüsse
Udo.
_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html
_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html