Re: Aufgabe::Gib mir Hundert

["Udo und Susanne Krause" <su.krause@XXXXXXX.ch>]

Liebe Freundinnen und Freunde der Unterhaltungsarithmetik,

die Lösung dieser Aufgabe

> man gebe alle Kombinationen aus den neun Ziffern 1, 2, 3, 4, 5, 6, 7, 8,  
> 9
> und den vier Grundrechenarten (Addition, Multiplikation, Subtraktion,  
> Division) an, die unter folgenden Bedingungen 100 ergeben:
>
> (i)     jede Ziffer kommt höchstens einmal vor
> (ii)    die Operatoren können mehrfach vorkommen in einer Lösung
> (iii)   Klammern werden nicht gesetzt
> (iv)    nicht alle Operatoren kommen in jeder Lösung vor,

aus dem vorvergangenen Jahr wurde noch nicht mitgeteilt, et voilà

Clear[subSets, combinator, cmb, fractor, filter]
subSets[l_List, p_List] := If[Length[p] > 0, Subsets[l, p], {}]

cmb[l_List, m_List] := Block[{r = {}, t},
    For[o = 1, o <= Length[l], o++,
     t = If[VectorQ[Flatten[l[[o]]], AtomQ], 2, 3];
     For[oo = 1, oo <= Length[m], oo++,
      If[(Flatten[l[[o]]] \[Intersection] Flatten[m[[oo]]]) == {},
       AppendTo[r,
        If[Depth[l[[o]]] > t,
         Append[l[[o]], m[[oo]]], {l[[o]], m[[oo]]}]]
       ]
      ]
     ];
    DeleteDuplicates[r, (Sort[#1] == Sort[#2]) &]
    ]

combinator[l_List, p_List] :=
   Fold[cmb[#1, #2] &, subSets[l, {First[p], First[p]}],
    subSets[l, {#, #}] & /@ Rest[p]]

fractor[l_List] :=
   Flatten[combinator[l, #] & /@ IntegerPartitions[Length[l]],
     1] /. {l -> {l}}

filter[r_Integer, n_List  (* numerators *), d_List (*
    denominators *), s_ (* signs *)] :=
   Block[{nn, nnL,  dd, rr = {}, q, o, oo},
    For[o = 1, o <= Length[n], o++,
     nn = n[[o]];
     nnL = Length[nn];
     For[oo = 1, oo <= Min[nnL, Max[Length /@ d]], oo++,
      dd = If[
        q = DeleteDuplicates[
          Flatten[Permutations /@ (Join[#,
                Table[1, {nnL - Length[#]}]] & /@
              Select[d, Length[#] <= oo &]), 1]]; s,
        Flatten[Outer[Times, Tuples[{-1, 1}, nnL], q, 1], 1],
        q
        ];
      AppendTo[rr, Select[Divide[nn, #] & /@ dd, (Plus @@ # == r) &]]
      ]
     ];
    DeleteDuplicates[Flatten[rr, 1]]
    ]

Remove[summands, allSummands]
summands::memnint = "The set `1` contains non-integer elements!";
summands::memdup = "The set `1` containds duplicated elements!";
summands::signs = "The third variable must be True or False!";
summands::denoc = "The denominator may contain at most `1` elements!";
summands::nonom =
  "No numerators available to represent `1` with `2` elements!";
summands[r_Integer (* represented number *),
  n_List?VectorQ (* number set *),
  denoC_Integer?NonNegative (* count of numbers in denominator *),
  signs_: True (* use subtraction *)] :=
 Module[{denos, numes, numeC = Length[n] - denoC, deno, nume, fN, fD,
   o},
  (* check input *)
  If[! VectorQ[n, IntegerQ], Message[summands::memnint, n];
   Return[$Failed]];
  If[n =!= DeleteDuplicates[n], Message[summands::memdup, n];
   Return[$Failed]];
  If[! (MatchQ[signs, True] || MatchQ[signs, False]),
   Message[summands::signs]; Return[$Failed]];
  If[denoC > Length[n] - 1, Message[summands::denoc, Length[n] - 1];
   Return[$Failed]];
  (* make rationals *)
  numes =
   Select[Complement[n, #] & /@ Subsets[n, {denoC}],
    Times @@ # >= r &];
  If[Length[numes] == 0, Message[summands::nonom, r, numeC];
   Return[$Failed]];
  denos = Complement[n, #] & /@ numes;
  fD = If[denoC > 0, fractor[Table[Subscript[x, i], {i, denoC}]],
    Null];
  fN = fractor[Table[Subscript[x, i], {i, numeC}]];
  For[o = 1, o <=  Length[numes], o++,
   nume =
    Select[Apply[Times, #, 1] & /@ (fN /.
        Thread[Rule[Table[Subscript[x, i], {i, numeC}],
          numes[[o]]]]), (Plus @@ # >= r) &];
   If[denoC > 0,
    deno =
     Apply[Times, #, 1] & /@ (fD /.
        Thread[Rule[Table[Subscript[x, i], {i, denoC}], denos[[o]]]]);
    Print["Zähler: ", numes[[o]], " Nenner: ", denos[[o]]],
    deno = {{1}};
    Print["Zähler: ", numes[[o]], " formal Nenner: {1}"]
    ];
   Print["Resultat: ", filter[r, nume, deno, signs]]
   ]
  ]

allSummands[r_Integer, n_List?VectorQ] := Block[{s, i, j},
  For[i = 2, i <= Length[Subsets[n]], i++,
   s = Subsets[n][[i]];
   For[j = 0, j <= Length[s] - 1, j++, summands[r, s, j]]]]

allSummands[] geht über alle nichtleeren Untermengen s der zur Verfügung
stehenden Zahlenmenge n und ruft summands[r, s, j] auf. In summands werden
alle Ausdrücke gesucht, bei denen j Elemente der aktuellen Untermenge s im
Nenner stehen. Dabei verteilt die Funktion fractor[] die Zahlen einer
Untermenge (sei es im Zähler oder im Nenner) auf die Summanden. Natürlich
kann ein Summand aus mehreren Faktoren bestehen. Die Funktion filter[]
ergänzt die Menge der Nenneraggregate, damit die Listenteilbarkeit gegeben
ist und findet die korrekten Zusammenstellungen.

Aus Speichergründen sind die Funktionen prozedural und geben zur
Verteilung der Zahlen auf Zähler und Nenner das jeweilige Teilresultat.
Aus Lebendigkeitsgründen wurden die Teilresultate nicht sortiert und nicht
mit Union[] gemapped, so dass einige Dubletten stehengeblieben sind.

Wie ist die Lösung zu lesen? Zum Beispiel bei

{1, 2, 4, 5, 7, 8, 9}/{3, 6}

wird {280/3, -1, -4/3, 9} angegeben, das ist

2 5 7 8/6 - 1 - 4/3 + 9 = 100.

Frohes Neues Jahr!
Udo.

<<attachment: engelskirchenHundertSln.nb>>