DMUG-Archiv 2020

Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

Re: [Dmug] Aufgabe::Digital Perfection

Wenn die Teilbarkeit durch 7 schliesslich geprüft wird


Clear[divisor7Q]
divisor7Q[o_Integer] := True /; o == 0
divisor7Q[o_Integer] := Block[{l = IntegerDigits[Abs[o]], v},
   While[Last[l] == 0, l = Most[l]];
   v = Most[l]; l = Last[l];
   If[Length[v] == 0,
    Abs[l] == 7, (* else *)
    divisor7Q[FromDigits[v] - 2 l]
    ]
   ] /; o != 0


fällt der Witz im natürlichen Lauf der Dinge dahin


Clear[candidates]
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[216, 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}];   Select[Flatten[filter /@ l3], divisor7Q[FromDigits[Take[IntegerDigits[#], 7]]] &]
  ]


In[122]:= (* machine solution, all rules used *)
candidates[]

Out[122]= {3816547290}


und filter[] bleibt gerade so hässlich wie es ist.


grüsse

Udo.


Am 24.10.2020 um 10:03 schrieb Susanne & Udo Krause via demug:
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
_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html

Antworten:
Verweise:
Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

DMUG DMUG-Archiv, http://www.mathematica.ch/archiv.html