https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Discrete Mathematics sorted by most replies. https://community.wolfram.com/groups/-/m/t/3027093 A Wolfram U Daily Study Group on Introduction to Discrete Mathematics begins on **October 16th 2023**. Join me and a group of fellow learners to learn about the mathematics behind the innovations of computer science using the Wolfram Language. Our topics cover the most well-known branches of discrete mathematics, including logic, sets, discrete functions, sequences, combinatorics, algorithms, proofs, recursion and graphs. This study group aims to develop a broad understanding of discrete mathematics, with a focus on concepts useful in computer science, software engineering and programming, and make this rich and useful domain accessible for any college student, professional or interested hobbyist. A basic working knowledge of the Wolfram Language is recommended but not necessary. We are happy to help beginners get up to speed with Wolfram Language using resources already available on Wolfram U. Please feel free to use this thread to collaborate and share ideas, materials and links to other resources with fellow learners. > [**REGISTER HERE**][1] ![2 Dimensional Cellular Automaton rule 907486931][2] ![Wolfram U Banner][3] [1]: https://www.bigmarker.com/series/daily-study-group-discrete-math-wsg46/series_details [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=907486931.gif&userId=2311323 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=banner.jpg&userId=2823613 Marc Vicuna 2023-10-04T19:10:50Z https://community.wolfram.com/groups/-/m/t/2397426 I am very new to Mathematica and have to rethink my 'procedural' ways of programming. That is not always easy. I am making progress, but here I have no clue, besides going down the 'repeat and if' rabbit hole. I create a list of random integers. I have a Dynamic Slider to adjust delta (between 0 and 20). Let's say the Slider is adjusted to value 10. Now I want all the integers in the list that are 10 or less apart, to become the same integer. E.g. myIntegers = {11,28,66,36,94,8,44} After the 'treatment' the list should be : {11,28,66,**28**,94,**11**,44} The 36 is within 10 from 28 and the 8 is also within 10 from 11, so in both cases the integer within the delta range gets to be the value of the first (36 becomes 28). How could I go about this problem in a functional or symbolic way? B. Cornas 2021-10-31T16:38:00Z https://community.wolfram.com/groups/-/m/t/1569707 ![a very prime pencil][1] I just got a set of these pencils, from [Mathsgear][2]. The number printed on it is prime, and will remain so as you sharpen the pencil from the left, all the way down to the last digit, 7. Here is a recursive construction of all such *truncatable primes*. TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[9]))} ]; TruncatablePrimes[p_Integer] := {} The one on the pencil is the largest one, In[7]:= Take[Sort[Flatten[TruncatablePrimes /@ Range[9]]], -5] Out[7]= { 9918918997653319693967, 57686312646216567629137, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137} [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_20181212_120939.jpg&userId=143131 [2]: https://mathsgear.co.uk/products/truncatable-prime-pencil Roman Maeder 2018-12-12T12:01:36Z https://community.wolfram.com/groups/-/m/t/974303 It is fairly straight forward to solve a Sudoku as an integer programming problem, by creating 9 binary variables for each cell, only one of which is one in the solution. The walk-through below and attached notebook illustrates this for the problem shown. ![enter image description here][1] # Implementation Given values, as `{row, column, value}` input = { {1,4,4},{1,5,9},{1,8,5},{2,1,6},{2,5,3},{3,1,4}, {3,2,5},{3,4,6},{3,5,2},{3,7,3},{3,9,7},{4,1,5}, {4,3,2},{4,4,7},{4,7,9},{4,8,8},{5,1,3},{5,3,6}, {5,7,2},{5,9,1},{6,2,9},{6,3,1},{6,6,2},{6,7,6}, {6,9,5},{7,1,2},{7,3,5},{7,5,1},{7,6,4},{7,8,3}, {7,9,8},{8,5,8},{8,9,9},{9,2,1},{9,5,7},{9,6,3}}; Display given values viewmat = Table["", {9}, {9}]; Do[viewmat[[input[[i, 1]], input[[i, 2]]]] = ToString[input[[i, 3]]], {i, Length[input]}] Grid[viewmat, Frame -> All] ![enter image description here][2] Variables, as 9 x 9 x 9 matrix varmat = Table[m[i, j, k], {i, 9}, {j, 9}, {k, 9}]; Variables as a list vars = Flatten[varmat]; Constrain the input cells to their value cons1 = (varmat[[Sequence @@ #]] == 1 &) /@ input ![enter image description here][3] The sum of the binary variables for each cell is 1 cons2 = Flatten @ Table[ (Sum[varmat[[i, j, k]], {k, 9}] == 1), {i, 9}, {j, 9}]; All different constraint for the rows cons3 = Flatten @ Table[ (Sum[varmat[[i, j, k]], {i, 9}] == 1), {j, 9}, {k, 9}]; All different constraint for the columns cons4 = Flatten @ Table[ (Sum[varmat[[i, j, k]], {j, 9}] == 1), {i, 9}, {k, 9}]; All different constraint for the submatrices sm[di_, dj_] := Flatten [Table[{i, j}, {i, 1 + 3*(di - 1), 3*di}, {j, 1 + 3*(dj - 1), 3*dj}],1] cons5 = Flatten @ Table[(Total[m[Sequence @@ #, k] & /@ sm[i, j]] == 1), {i, 3}, {j, 3}, {k, 9}]; Confine the variables to the range 0 to 1 cons6 = Thread[0 <= vars <= 1]; Combine the constraints Length[allcons = Join[cons1, cons2, cons3, cons4, cons5, cons6]] `1089` Solve the problem, specifying that the variables are integers. AbsoluteTiming[sol = FindMinimum[{0, allcons, Element[vars, Integers]}, vars];] `{0.0946335, Null}` Find the values for each cell resmat = Table[Sum[k*m[i, j, k], {k, 9}], {i, 9}, {j, 9}] /. sol[[2]] ![enter image description here][4] Display the input and result {Grid[viewmat, Frame -> All], Grid[resmat, Frame -> All]} ![enter image description here][5] Check the result And @@ Table[Unequal[Sequence @@ resmat[[i]]], {i, 9}] `True` And @@ Table[Unequal[Sequence @@ Transpose[resmat][[i]]], {i, 9}] `True` And @@ Flatten @ Table[Unequal[resmat[[Sequence @@ #]] & /@ sm[i, j]], {i, 3}, {j, 3}] `True` [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sukoku_problem.jpg&userId=29126 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdsdf4qehtrngfsbdvsd.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdafq4356y4trett4egqrafzgber.png&userId=11733 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dfg657q43wregdfsbdg.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=afgdfgtyuiytouuyrter24356.png&userId=11733 Frank Kampas 2016-12-05T14:23:11Z https://community.wolfram.com/groups/-/m/t/148526 1 ) How to use the math functions over graphs that are not in the data graph of Mathematica? 2 ) How to compute Chromatic Poynomials for a graph introduced by myself ? Reinaldo Giudici 2013-11-04T13:57:36Z https://community.wolfram.com/groups/-/m/t/966640 To be more specific, I am working on a code to help me find patterns and solve this problem: Which sets of numbers of size n (starting at one) can be divided into pairs that add up to a perfect square, such that every number has a partner, and there are no repeats? A simple known solution is 8, because the set 8 can be paired (1,8) (2,7) (3,6) and (4,5) with each pair adding to 9. Here is my code that works: Remove["Global`*"] f[n_] := Permutations[Table[i, {i, 1, n}], {2}] listfunction[n_] := Module[ {}, newlist = {}; duplicates = {}; Do[ If[ f[n][[j, 1]] < f[n][[j, 2]], AppendTo[ newlist, f[n][[j]]], AppendTo[duplicates, f[n][[j]]]] , {j, 1, (n!/(n - 2)!)}]; Module[{}, perfectsquares100 = Table[x^2, {x, 1, 100}]; possibles = {}; impossibles = {}; Do[ If[ MemberQ[perfectsquares100, newlist[[k, 1]] + newlist[[k, 2]]], AppendTo[possibles, newlist[[k]]], AppendTo[impossibles, newlist[[k]]]], {k, 1, Length[newlist]}]; Print[possibles]]] Which generates the list for n of all the pairs whose sum is a perfect square. So now, I need to whittle that list down to the numbers 1 to n, so that each digit is only represented once, eliminating extra pairs. This is the code I have come up with to do that, that doesn't work. *The following code will use the immediate output from the above code.* finallist[possibles] = Module[{}, rejects = {}; answer = {}; Do[ If[MemberQ[possibles[[h + 1 ;; Length[possibles]]], possibles[[h, 1]], 2] \[And] MemberQ[possibles[[h + 1 ;; Length[possibles]]], possibles[[h, 2]], 2], AppendTo[rejects, possibles[[h]]], AppendTo[answer, possibles[[h]]]], {h, 1, Length[possibles]}]; Print[answer]] I built the code working from n=8, but when I tried it on n=16, it fails to provide the correct answer. So, any ideas on what commands might work? Ashley Louk 2016-11-19T22:34:47Z https://community.wolfram.com/groups/-/m/t/2214623 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/e083449a-81bf-418b-83e9-c700f4a6938c José Manuel Rodríguez Caballero 2021-03-09T18:09:17Z https://community.wolfram.com/groups/-/m/t/1063480 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/373ccb1d-e97f-40ec-aa0a-0d3001c4728d Mariusz Iwaniuk 2017-04-16T22:38:51Z https://community.wolfram.com/groups/-/m/t/1395404 Hi Guys! I hope all of you are fine :) Maybe someone can tell me here how can I find with Wolfram Alpha or Mathematica the nth's of larger primes? I used "PrimePi", but "PrimePi" works not with large primes (primes like these 1921773217311523519374373 do not work...too large...). Is there a criterion, method and or a script with which I can find the nth's of larger primes? I have also used the "nthprime" function, but i think this is not what i need, but when there is a method with the nth prime function to find the "th's" of larger primes, can someone here show me, how it works? To better understanding what i mean, here an example: - 2 is the 1(<-i need this number).Primenumber - 3 is the 2(<-i need this number).Primenumber - 5 is the 3(<-i need this number).Primenumber - 7 is the 4(<-i need this number).Primenumber and so on...another example: 19 is the 8th (!) Prime, 23 is the 9th (!) Prime, 29 is the 10th (!) Prime... now i need a function to find which prime is 1921773217311523519374373? I need a function to get that out, i hope anybody here has an idea how can i find with WolframAlpha or Mathematica which/what (!) prime is 1921773217311523519374373. I hope anyone can help me here. Kind regards and best wishes. Nural I. 2018-07-31T18:14:09Z https://community.wolfram.com/groups/-/m/t/972050 Hello I have an algorithmus which I like to undestand and solve with Mathematica. It is about cooking. You need at least 18 people for it. Each group (2 people) are cooking either appetizer, main dish or dessert at their place. 2 other groups are visiting them. For the other two courses the group is the invited to another hosts' homes. Each location you meet new people (2 new groups). That means at the end you met 6 groups (12 people). Its a lot of fun. I want to organize this for my birthday party. Goal is it, to maximise the happinies factor. Only this way you can make sure, that in each different location you will see new people that you will not meet in the 2 other locations. ![enter image description here][2] There are some constrains which we have to consider: I like to know how to handle this problem with Mathematica. Where do I start? Which equation do I have to solve here? I don't see what I realy need to do... As I sad, you need minimum 18 people. That means we have 9 teams and 3 major groups. Ok, but I don't know what to do next and how I implement this in Mathematica. I guess it should not be so difficult but I need some help from you! Peter Parker 2016-11-30T23:26:19Z https://community.wolfram.com/groups/-/m/t/1846418 I have a vague memory of having done this some time ago but I don't remember the formula. What I need is all possible combinations of positive integers xi (i=1,..,k) that yield s when they are summed. For instance, for k=2 and s=2 there are the 3 combinations {0,2}, {1,1} and {2,0} the first number in a bracket representing x1 and the second x2. This can be done with the code f[k_, s_] := Module[{c, x}, c = 0; Do[ If[Sum[x[i], {i, 1, k}] == s, c++], Evaluate[Apply[Sequence, Table[{x[i], 0, s}, {i, 1, k}]]]]; Return[c]] But I need a fast function as I will calculate it for very big k and s. So this code is too slow. Do you remember the formula involving factorials? Or is there a Mathematica function that does this? Ulrich Utiger 2019-12-22T18:06:32Z https://community.wolfram.com/groups/-/m/t/1799757 # Introduction: *One problem in chemistry is finding all possible molecules, as there are rotations and reflections. All the possibilities of existence of halomethanes (even unstable ones) are addressed here. This is a question similar to the sequence: Doubly triangular numbers (A002817–OEIS, N. J. A. Sloane, Apr 18, 2017):* *“Number of inequivalent ways to color vertices of a square using <= n colors, allowing rotations and reflections* ...” , a(n)=n*(n+1)*(n^ 2+n+2)/8. *However as described in the sequence A002817–OEIS, only the total result of the possibilities is addressed, while here in this post I visually demonstrate all possibilities, both in list, 2D and 3D graphs and mass list.* # Function Code: With this function below it is possible to find and visualize **all possibilities of halomethanes**, taking into account all rotations and reflections of the molecules. I developed this function with some options (“Mode”) besides the list of terms. Examples of options: "Color", "Visual", "Visual3D", "Mass". Here the function demonstration is done with all halogens (except radioactive halogens, by choice), but any of the possible elements can be used as an argument in the function. Example: {"H"}, {"F", "Br", "I"}, {...} ... {"H", "F", "Cl", "Br", "I" }. Halomethanes[elem_, OptionsPattern[]] := Module[{eleu, z, cc, a, a1, f, rP, ap, n, b}, z = Length@elem; Options[Halomethanes] = {"Mode" -> "Table"}; eleu = elem[[1]]; a = Tuples[elem, 4] /. {"Cl" -> "D", "Br" -> "B"}; n[x_] := {x}; cc = {"C" -> GrayLevel[0.5], "F" -> RGBColor[1, 0.5, 0.5], "Cl" -> RGBColor[0, 0.56, 0], "Br" -> RGBColor[0.6, 0.4, 0.2], "I" -> RGBColor[1, 0, 0], "H" -> RGBColor[0, 1, 1]}; a1 = a[[1]]; f[a_] := Module[{bt, ct, dt, e1, e2, ft, gt, r1}, bt = Table[StringJoin[a[[b]]], {b, 1, Length@a}]; ct = Table[StringJoin@Table[a[[c]], 2], {c, 1, Length@a}]; dt = Table[ StringJoin[a[[d]][[4]], a[[d]][[3]], a[[d]][[2]], a[[d]][[1]]], {d, 1, Length@a}]; e1 = Table[ StringCases[ct[[i]], RegularExpression[bt[[1]]]], {i, 1, Length@ct}]; e2 = Table[ StringCases[ct[[i]], RegularExpression[dt[[1]]]], {i, 1, Length@ct}]; ft = Table[{Length@(e1[[j]]), Length@(e2[[j]])} /. {{2, 2} -> bt[[j]], {2, 0} -> bt[[j]], {0, 2} -> {"copy"}, {0, 0} -> bt[[j]], {2, 1} -> bt[[j]], {1, 2} -> {"copy"}, {1, 0} -> {"copy"}, {0, 1} -> {"copy"}, {1, 1} -> {"copy"}}, {j, 1, Length@ct}]; gt = Table[ StringPartition[DeleteCases[ft, {"copy"}][[o]], 1], {o, 1, Length@DeleteCases[ft, {"copy"}]}]; r1 = If[gt != {}, If[gt[[1]] == a[[1]], gt[[1]], {}], {}]; {rP = DeleteCases[r1, {}], ap = If[r1 != {}, DeleteCases[gt, r1], gt]}]; Do[b = AppendTo[n[a1], {a = f[a][[2]], f[a][[1]]}[[2]]], z*(z + 1)*(z^2 + z + 2)/8 - 1]; OptionValue[ "Mode"] /. {"Table" -> If[z == 1, {{eleu, eleu, eleu, eleu}}, b /. {"D" -> "Cl", "B" -> "Br"}], "Color" -> {TableForm[{{"H", Text[Style["Cyan", RGBColor[0, 1, 1], Medium]]}, {"F", Text[Style["Pink", RGBColor[1, 0.5, 0.5], Medium]]}, {"Cl", Text[Style["Green", RGBColor[0, 0.56, 0], Medium]]}, {"Br", Text[Style["Brown", RGBColor[0.6, 0.4, 0.2], Medium]]}, {"I", Text[Style["Red", RGBColor[1, 0, 0], Medium]]}}, TableHeadings -> {None, {"Atom", "Color"}}], If[z == 1, {Flatten@Table[elem, 4]}, b /. {"D" -> "Cl", "B" -> "Br"}] /. cc}, "Visual" -> If[z == 1, MoleculePlot[ Molecule[{"C", eleu, eleu, eleu, eleu}, {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 100], Table[MoleculePlot[ Molecule[ Join[{"C"}, (b /. {"D" -> "Cl", "B" -> "Br"})[[ h]]], {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 100], {h, 1, Length@b}]], "Visual3D" -> If[z == 1, MoleculePlot3D[ Molecule[{"C", eleu, eleu, eleu, eleu}, {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 100], Table[MoleculePlot3D[ Molecule[ Join[{"C"}, (b /. {"D" -> "Cl", "B" -> "Br"})[[ h]]], {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 80], {h, 1, Length@b}]], "Mass" -> If[z == 1, MoleculeValue[ Molecule[{"C", eleu, eleu, eleu, eleu}, {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], "MolecularMass"], Table[MoleculeValue[ Molecule[ Join[{"C"}, (b /. {"D" -> "Cl", "B" -> "Br"})[[ h]]], {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], "MolecularMass"], {h, 1, Length@b}]]}] # Visualization: - **TERMS TABLE**: In the simplest form, with only one argument, a list of all halomethane molecules is generated. rp = Halomethanes[{"H", "F", "Cl", "Br", "I"}] Length@rp ![im1][1] - **COLOR TABLE**: Optionally, a list of molecules with their respective illustrative colors is generated with the "Mode" -> "Color" option. Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Color"] ![im2][2] - **2D VISUAL TABLE**: Optionally, a list of molecules with 2D structural representations is generated with the "Mode" -> "Visual" option (the 2D model can better represent stereoisomerism than the 3D model). Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Visual"] ![im3][3] - **3D VISUAL TABLE** (interactive): Optionally, a list of molecules with 3D structural representations is generated with the "Mode" -> "Visual3D" option. This list is interactive, and each molecule can be rotated for better viewing (stereoisomerism is not very well represented in these 3D models as the representations are tetrahedral, for example, the isomers {"H","F","H","F"} and {"F","F","H”,”H”} are very similar in this view). Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Visual3D"] ![im4][4] - **MASS TABLE**: Finally, a list of the masses of all halomethanes can be generated with the argument "Mode" -> "Mass" (some of them, although unstable, are mentioned in the list). resp2 = Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Mass"] ![im5][5] Illustrative graph of the mass distributions of all possible halomethanes: ListPlot[resp2, AxesLabel -> {"n", "Mass(u)"}, LabelStyle -> Directive["Subsubsection", RGBColor[0.07, 0.5, 0.5]], PlotLabel -> "Halomethanes Mass", PlotRange -> {{0, 130}, {0, 550}}, PlotStyle -> Directive[RGBColor[0.91, 0.08, 0.5], PointSize[Large]], ImageSize -> Large] ![im6][6] **Link**: (Doubly triangular numbers, A002817–OEIS, sequence): https://oeis.org/A002817 Thanks. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=table1.png&userId=1316061 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=tableColor.png&userId=1316061 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graphtest.png&userId=1316061 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=visual3D.png&userId=1316061 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=tablemass.png&userId=1316061 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph.png&userId=1316061 Claudio Chaib 2019-10-03T03:01:17Z https://community.wolfram.com/groups/-/m/t/1637345 I can't seem to find any information/algorithms on generating matrix representations of the symmetric group. Can someone point me in the right direction? John Garrison 2019-03-22T05:31:30Z https://community.wolfram.com/groups/-/m/t/917888 Hi all! I'm new to the Wolfram Forum community and it is a pleasure to be here. I have a quick question for those who have expertise in the use of Mathematica.... Is Mathematica able to solve the following system of recurrence relations? I'm looking for a "closed-form" formula for w(2n+1). ------------------------------------------------- For n greater than or equal to 3, w(2n+1) = a(n+1), a(n) = 3*a(n-1) + a(n-2) - a(n-3), a(0) = 1, a(1) = 2, a(2) = 7, w(1) = 2, w(3) = 7, and w(5) = 22. Any help is greatly appreciated! Sincerely, Richard M. Low richard.low@sjsu.edu Richard Low 2016-09-02T22:27:52Z https://community.wolfram.com/groups/-/m/t/893713 As part of a larger Problem I have to find natural numbers>0 that are divisible by 37, which is a trival Problem. I write: b1[n_] := Divisible[n, 37] FindInstance[{n > 0, b1[n]}, n, Integers] I get: FindInstance::naqs: n>0&&Divisible[n,37] is not a quantified system of equations and inequalities. >> The same happens wit Solve. What is wrong with that Code? Actually I have to find numbers which respect a lot of logical conditions, some of them quite complex. That is why I put the conditions into seperate functions. But even if I write: FindInstance[{n > 0, Divisible[n, 37]}, n, Integers] I get the same error. Werner Geiger 2016-07-25T12:11:23Z https://community.wolfram.com/groups/-/m/t/617724 Input: "factor 25" (http://www.wolframalpha.com/input/?i=factor+25) ----------------------------------------------------------------- **Incorrect result returned:** ![Incorrect prime factorization of 25][1] We should get **5^2** **Using *Mathematica* we get the correct factorization** ![Prime factorization of 25 using **Mathematica**][2] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Captura.PNG&userId=410040 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Captura2.PNG&userId=410040 Why did Wolfram|Alpha return that result? RorriNator 7 2015-11-19T16:46:50Z https://community.wolfram.com/groups/-/m/t/1850612 This algorithm calculates the probability that S of n biological mtMRCA lineages survive after v generations. In the beginning (generation v=1), there are n mothers that have each randomly between 0 and d daughters. I have a fast analytical solution. But I need to check it with this algorithm. The uncompiled function is slow of course, but it does not need much memory. Unfortunately, memory usage of the compiled version is exponential for d > 2, n > 4 and V > 7 for a reason I don't understand. Can anyone help? ClearAll["Global`*"] Clear[distribution]; distribution = Compile[{{d, _Integer}, {n, _Integer}, {S, _Integer}, {z, _Integer}, \ {V, _Integer}}, Module[{w, r, v, s, c, K}, w = Table[0, {V}]; r = Table[0, {n}]; Do[ v = 1; s = 0; Do[ c = RandomInteger[{0, d}]; If[c != 0, s++; r[[k]] = c], {k, 1, n}]; If[s == S, w[[v]]++]; While[s != 0, v++; If[v == V, Break[]]; K = s; s = 0; Do[ c = Total[RandomInteger[{0, d}, r[[k]]]]; If[c != 0, s++; r[[k]] = c], {k, 1, K}]; If[s == S, w[[v]]++]], {z}]; Return[Table[{v, w[[v]]/z // N}, {v, 1, V - 1}]]], CompilationTarget -> "C"] Ulrich Utiger 2020-01-01T15:37:56Z https://community.wolfram.com/groups/-/m/t/2302672 Sorry, I need to give more info on my problem. I have a large set of primitive Pythagorean triples, generated by the code in the PrimitivePythagoreanTriple.nb: prim=With[{max=100},\[IndentingNewLine]Map[Last,List@@(Reduce[x^2+y^2\[Equal]z^2 && 0< x < y <max&&0<z<max &&GCD[x,y,z]\[Equal]1,{x,y,z},Integers,Backsubstitution->True]/.And:>List),{2}]] I wish to graph this discrete set in the xy-plane using **ListPlot** (after I add Table[ ... ] to the resulting set of pairs). This requires changing the triples {x,y,z} to pairs {x,y}, same first and second coordinates. I can do it on a single triple, obviously, but how do I write a code to make the new list of pairs from the list of triples? Here's a sample of what the outcome should look like (see attached). I've tried everything I can find and/or think of. Any suggestions will be appreciated. Thanks, JP James Parks 2021-06-30T16:32:06Z https://community.wolfram.com/groups/-/m/t/1636014 Hello! Let's say that I am having this sequence: a(n) = 2*a(n-1) - a(n-2) + 2*a(n-3) + a(n-4) + a(n-5) - a(n-7) - a(n-8) with a[1] == 1, a[2] == 1, a[3] == 1, a[4] == 2, a[5] == 6, a[6] == 14, a[7] == 28, a[8] == 56 as the base cases. Now, I want to find the sum of a(1)^3 + a(2)^3 + .... + a(n)^3 SYMBOLICALLY, with respect to the first 8 base cases. There will be of course some cross terms ie. a(1)*a(2), etc, but it should be in terms of only the first 8 base cases. I can use the RecurrenceTable and Total for finding numbers, but how can I do it symbolically and also simplify it to only the first 8 base cases? Thank you very much in advance. Thanos Papas 2019-03-19T15:37:21Z https://community.wolfram.com/groups/-/m/t/975898 Here is the solution I outlined in my comments for this problem: [Solve algorithm for best teams?][1] I do find the original formulation in the discussion opening inconsistent. The constraint formulations below are slightly different from the ones in OP's descriptions. The approach allows relatively easily the constraints to be changed or other constraints to be added. The constraints and objective function were programmed in a way that allows the finding of the number groups for different number of teams and number of courses. For another, detailed explanation of the used approach see [this answer](http://mathematica.stackexchange.com/questions/111725/how-to-fill-a-grid-make-its-total-be-largest/112210#112210) of the Mathematica Stackexchange question ["How to fill a grid make its total be largest"](http://mathematica.stackexchange.com/q/111725/34008). # Original Formulation > The problem is about cooking. You need at least 18 people for it. Each group (2 people) are cooking either appetizer, main dish or dessert at their place. 2 other groups are visiting them. For the other two courses the group is the invited to another hosts' homes. Each location you meet new people (2 new groups). That means at the end you met 6 groups (12 people). ![enter image description here][2] # New Formulation ## Variables #### Number of variables Assuming the number of groups is un-known we can select a large number for `ng` and then include the corresponding variables in the conditions and objective function. Number of teams: nt = 9; Number of groups: ng = 6; Number of courses: nc = 3; #### Variable arrays Clear[t, g, c, vt, vg, vc] Binary variables telling that $i$-th team is going to be used (formed). vt = Array[t, nt]; Binary variables telling that $i$-th group is going to be used (formed). vg = Array[g, ng]; Binary variable for vc = Array[c, nc]; #### Teams in groups Clear[ctg, vctg] Each group has three teams. Each team is assigned to exactly one group per course. Binary variables: vctg = Flatten@Table[ctg[ci, ti, gi], {ci, nc}, {ti, nt}, {gi, ng}]; Length[vctg] (* 162 *) #### Chefs Clear[ch, vch] Each team can be the chef for a given group and course. There is only one chef per group and course pair. Binary variable: vch = Flatten@Table[ch[ci, ti, gi], {ci, nc}, {ti, nt}, {gi, ng}]; Length[vch] (* 162 *) #### Happiness Happiness of team $t_i$ to prepare course $c_j$ Clear[H, vh] vh = Flatten@Table[H[ci, ci], {ci, nc}, {ti, nt}]; Do[H[ci, ti] = RandomInteger[{0, 3}], {ci, nc}, {ti, nt}] ## Constraints #### Each team should have 3 courses Each team should have 3 ($nc$) courses. eachTeamHadFullMeal = Flatten@Table[Sum[ctg[ci, ti, gi], {gi, ng}, {ci, nc}] == nc, {ti, nt}]; Length[eachTeamHadFullMeal] (*eachTeamHadFullMeal[[1;;2]]*) (* 9 *) #### Each team is assigned to one group per course. Each team is assigned to one group per course. oneGroupPerTeamPerCourse = Flatten@Table[ Sum[ctg[ci, ti, gi], {gi, ng}] == 1, {ti, nt}, {ci, nc}]; Length[oneGroupPerTeamPerCourse] oneGroupPerTeamPerCourse[[1 ;; 2]] (* 27 *) (* {ctg[1, 1, 1] + ctg[1, 1, 2] + ctg[1, 1, 3] + ctg[1, 1, 4] + ctg[1, 1, 5] + ctg[1, 1, 6] == 1, ctg[2, 1, 1] + ctg[2, 1, 2] + ctg[2, 1, 3] + ctg[2, 1, 4] + ctg[2, 1, 5] + ctg[2, 1, 6] == 1} *) #### Each group has three teams. Each group has three teams. threeTeamsPerGroupPerCourse = Flatten@Table[ Sum[ctg[ci, ti, gi], {ti, nt}] - 3 g[gi] == 0, {gi, ng}, {ci, nc}]; Length[threeTeamsPerGroupPerCourse] threeTeamsPerGroupPerCourse[[1 ;; 2]] (* 18 *) (* {ctg[1, 1, 1] + ctg[1, 2, 1] + ctg[1, 3, 1] + ctg[1, 4, 1] + ctg[1, 5, 1] + ctg[1, 6, 1] + ctg[1, 7, 1] + ctg[1, 8, 1] + ctg[1, 9, 1] - 3 g[1] == 0, ctg[2, 1, 1] + ctg[2, 2, 1] + ctg[2, 3, 1] + ctg[2, 4, 1] + ctg[2, 5, 1] + ctg[2, 6, 1] + ctg[2, 7, 1] + ctg[2, 8, 1] + ctg[2, 9, 1] - 3 g[1] == 0} *) #### There can be only one chef per group per course. There can be only one chef per group per course. Not every team has to be a chef of a course. oneChefPerGroupPerCourse = Flatten@Table[ Sum[ch[ci, ti, gi], {ti, nt}] - 1 g[gi] == 0, {gi, ng}, {ci, nc}]; Length[oneChefPerGroupPerCourse] oneChefPerGroupPerCourse[[1 ;; 3]] (* 18 *) (* {ch[1, 1, 1] + ch[1, 2, 1] + ch[1, 3, 1] + ch[1, 4, 1] + ch[1, 5, 1] + ch[1, 6, 1] + ch[1, 7, 1] + ch[1, 8, 1] + ch[1, 9, 1] - g[1] == 0, ch[2, 1, 1] + ch[2, 2, 1] + ch[2, 3, 1] + ch[2, 4, 1] + ch[2, 5, 1] + ch[2, 6, 1] + ch[2, 7, 1] + ch[2, 8, 1] + ch[2, 9, 1] - g[1] == 0, ch[3, 1, 1] + ch[3, 2, 1] + ch[3, 3, 1] + ch[3, 4, 1] + ch[3, 5, 1] + ch[3, 6, 1] + ch[3, 7, 1] + ch[3, 8, 1] + ch[3, 9, 1] - g[1] == 0} *) #### Connect the $\text{ch}$ variables with $\text{ctg}$ variables. connectChefTGAndCourseTG = Flatten@Table[-ch[ci, ti, gi] + ctg[ci, ti, gi] >= 0, {ci, nc}, {ti, nt}, {gi, ng}]; Length[connectChefTGAndCourseTG] connectChefTGAndCourseTG[[1 ;; 3]] (* 162 *) (* {-ch[1, 1, 1] + ctg[1, 1, 1] >= 0, -ch[1, 1, 2] + ctg[1, 1, 2] >= 0, -ch[1, 1, 3] + ctg[1, 1, 3] >= 0} *) #### Set any team to be a chef only once. Set any team to be a chef only once. (I think this means *at most once* given the previous constraint verbal formulation.) anyTeamChefAtMostOnce = Table[Sum[ch[ci, ti, gi], {gi, ng}, {ci, nc}] <= 1, {ti, nt}]; Length[anyTeamChefAtMostOnce] anyTeamChefAtMostOnce[[1 ;; 2]] (* 9 *) (* {ch[1, 1, 1] + ch[1, 1, 2] + ch[1, 1, 3] + ch[1, 1, 4] + ch[1, 1, 5] + ch[1, 1, 6] + ch[2, 1, 1] + ch[2, 1, 2] + ch[2, 1, 3] + ch[2, 1, 4] + ch[2, 1, 5] + ch[2, 1, 6] + ch[3, 1, 1] + ch[3, 1, 2] + ch[3, 1, 3] + ch[3, 1, 4] + ch[3, 1, 5] + ch[3, 1, 6] <= 1, ch[1, 2, 1] + ch[1, 2, 2] + ch[1, 2, 3] + ch[1, 2, 4] + ch[1, 2, 5] + ch[1, 2, 6] + ch[2, 2, 1] + ch[2, 2, 2] + ch[2, 2, 3] + ch[2, 2, 4] + ch[2, 2, 5] + ch[2, 2, 6] + ch[3, 2, 1] + ch[3, 2, 2] + ch[3, 2, 3] + ch[3, 2, 4] + ch[3, 2, 5] + ch[3, 2, 6] <= 1} *) #### Team in group cap, less than 4 teamInGroup = Table[Sum[ctg[ci, ti, gi], {ci, nc}, {gi, ng}] <= 4, {ti, nt}]; Length[teamInGroup] teamInGroup[[1 ;; 2]] (* 9 *) (* {ctg[1, 1, 1] + ctg[1, 1, 2] + ctg[1, 1, 3] + ctg[1, 1, 4] + ctg[1, 1, 5] + ctg[1, 1, 6] + ctg[2, 1, 1] + ctg[2, 1, 2] + ctg[2, 1, 3] + ctg[2, 1, 4] + ctg[2, 1, 5] + ctg[2, 1, 6] + ctg[3, 1, 1] + ctg[3, 1, 2] + ctg[3, 1, 3] + ctg[3, 1, 4] + ctg[3, 1, 5] + ctg[3, 1, 6] <= 4, ctg[1, 2, 1] + ctg[1, 2, 2] + ctg[1, 2, 3] + ctg[1, 2, 4] + ctg[1, 2, 5] + ctg[1, 2, 6] + ctg[2, 2, 1] + ctg[2, 2, 2] + ctg[2, 2, 3] + ctg[2, 2, 4] + ctg[2, 2, 5] + ctg[2, 2, 6] + ctg[3, 2, 1] + ctg[3, 2, 2] + ctg[3, 2, 3] + ctg[3, 2, 4] + ctg[3, 2, 5] + ctg[3, 2, 6] <= 4} *) #### All variables are binary All variables are binary constraints. Needed if `Maximize` is used. varConstraints = Map[0 <= # <= 1 &, Join[vctg, vch, vg]]; varConstraints[[1 ;; 4]] (* {0 <= ctg[1, 1, 1] <= 1, 0 <= ctg[1, 1, 2] <= 1, 0 <= ctg[1, 1, 3] <= 1, 0 <= ctg[1, 1, 4] <= 1} *) ### Objective function objFunc = Sum[H[ci, ti] ch[ci, ti, gi], {ti, nt}, {ci, nc}, {gi, ng}]; We can use this objective function in order to minimize the number of groups: objFuncMinNG = Sum[H[ci, ti] ch[ci, ti, gi], {ti, nt}, {ci, nc}, {gi, ng}] - Total[vg]; # Solving with LinearProgramming Using `Maximize` is very slow, so we have to convert the conditions into matrix-vector formulation to be given to `LinearProgramming`. All variables vars = Join[vctg, vch, vg]; Length[vars] (* 330 *) ## Convert conditions to matrices {zeroMat, mat0} = CoefficientArrays[eachTeamHadFullMeal[[All, 1]], vars]; Dimensions[mat0] {zeroMat, mat1} = CoefficientArrays[oneGroupPerTeamPerCourse[[All, 1]], vars]; Dimensions[mat1] {zeroMat, mat2} = CoefficientArrays[threeTeamsPerGroupPerCourse[[All, 1]], vars]; Dimensions[mat2] {zeroMat, mat3} = CoefficientArrays[oneChefPerGroupPerCourse[[All, 1]], vars]; Dimensions[mat3] {zeroMat, mat4} = CoefficientArrays[connectChefTGAndCourseTG[[All, 1]], vars]; Dimensions[mat4] {zeroMat, mat5} = CoefficientArrays[anyTeamChefAtMostOnce[[All, 1]], vars]; Dimensions[mat5] {zeroMat, mat6} = CoefficientArrays[teamInGroup[[All, 1]], vars]; Dimensions[mat6] bVec = Join[ Table[{nc, 0}, {Dimensions[mat0][[1]]}], Table[{1, 0}, {Dimensions[mat1][[1]]}], Table[{0, 0}, {Dimensions[mat2][[1]]}], Table[{0, 0}, {Dimensions[mat3][[1]]}], Table[{0, 1}, {Dimensions[mat4][[1]]}], Table[{1, -1}, {Dimensions[mat5][[1]]}], Table[{4, -1}, {Dimensions[mat6][[1]]}] ]; Length[bVec] condMat = Join[mat0, mat1, mat2, mat3, mat4, mat5, mat6]; MatrixQ[condMat] MatrixPlot[condMat] ![enter image description here][3] objVec = Normal@CoefficientArrays[{objFunc}, vars][[2]][[1]]; Length[objVec] (* 330 *) ## Solving AbsoluteTiming[ nsol = LinearProgramming[-objVec, condMat, bVec, Table[{0, 1}, {Length[vars]}], Integers]; ] (* {0.063444, Null} *) objVec.nsol (* 23 *) sol = Thread[vars -> nsol]; # Tabulate solution ## Find non-zero groups gnzInds = Table[Sum[ctg[ci, ti, gi], {ci, nc}, {ti, nt}] > 0, {gi, ng}] /. sol; gnzInds = Pick[Range[ng], gnzInds] ## Tabulation per group This package is for the function `CrossTabulate`. Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MathematicaForPredictionUtilities.m"] In red are the chef team assigments. Table[ Column[{Row[{"group:", gi}], mf = MatrixForm[ CrossTabulate[ Flatten[Table[{"team:" <> ToString[ti], "course:" <> ToString[ci], ctg[ci, ti, gi]}, {ti, nt}, {ci, nc}] /. sol, 1]]]; Do[If[(ch[ci, ti, gi] /. sol) == 1, mf[[1, ti, ci]] = Style[mf[[1, ti, ci]], Red]], {ti, nt}, {ci, nc}]; mf }], {gi, gnzInds}] ![enter image description here][4] # Visualize the solution Here is a solution visualization with a graph plot: graphEdges = Map[Labeled[("team:" <> ToString[#[[2]]]) -> ("group:" <> ToString[#[[3]]]), "course:" <> ToString[#[[1]]]] &, Cases[sol, HoldPattern[ctg[___] -> 1], \[Infinity]][[All, 1]]]; vertices = Union[Flatten[List @@@ graphEdges[[All, 1]]]]; vcoords = Join[ Block[{t = Flatten@StringCases[vertices, "group:" ~~ ___]}, MapIndexed[# -> 0.3 {Cos[#2[[1]] 2 \[Pi]/Length[t]], Sin[#2[[1]] 2 \[Pi]/Length[t]]} &, t]], Block[{t = Flatten@StringCases[vertices, "team:" ~~ ___]}, MapIndexed[# -> 0.7 {Cos[#2[[1]] 2 \[Pi]/Length[t]], Sin[#2[[1]] 2 \[Pi]/Length[t]]} &, t]] ]; Legended[ GraphPlot[List @@@ graphEdges, MultiedgeStyle -> All, VertexRenderingFunction -> ({If[StringMatchQ[#2, "team:" ~~ __], RGBColor[0.8, 0.8, 1], RGBColor[1, 0.8, 0.8]], EdgeForm[Black], Rectangle[# - {0.1, 0.05}, # + {0.1, 0.05}], Black, Text[#2, #1]} &), VertexCoordinateRules -> vcoords, EdgeRenderingFunction -> (With[{cind = ToExpression[ StringCases[#3, "course:" ~~ x__ :> x][[1]]]}, {{Green, Brown, Pink}[[cind]], Line[#], Black, Inset[cind, Mean[#], Automatic, Automatic, #[[1]] - #[[2]], Background -> White]}] &), ImageSize -> 900], Thread[{Green, Brown, Pink} -> Map["course:" <> ToString[#] &, Range[nc]]]] ![enter image description here][5] [1]: http://community.wolfram.com/groups/-/m/t/972050 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SADFETRHSGBDFV.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Hplnz8cm.png&userId=143837 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-05at10.13.42PM.png&userId=143837 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-09at7.07.44AM.png&userId=143837 Anton Antonov 2016-12-07T21:06:58Z