https://community.wolfram.com RSS Feed for Wolfram Community showing ideas tagged with Discrete Mathematics sorted by most viewed. https://community.wolfram.com/groups/-/m/t/235291 [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] Some time ago one of my friends asked me whether it is possible to design a cellular automaton which can generate realistic snowflakes. I recall my crystallography and thermodynamics knowledge and came up a very simple yet impressive model. [size=5][b]The Regular Triangular Lattice[/b][/size] First of all, we are trying to simulate snowflake, which is a kind of hexagonal crystal. So it should be best to construct our CA on a regular hexagonal grid, i.e. regular triangular lattice. We all know [b]CellularAutomaton[/b] inherently works on rectangle lattices ("4-lattice" for short), so how can we deduce a triangular lattice ("3-lattice" for short) on it? Well, the differences between rect-lattice and triangular one is just a geometric transformation. To demonstrate that, have a look at the following 4-lattice, with a blue square highlighting the range-1 [url=http://mathworld.wolfram.com/MooreNeighborhood.html]Moore neighborhood[/url]: [img=width: 388px; height: 396px;]/c/portal/getImageAttachment?filename=fig1.gif&userId=93201[/img] Clearly there is always a hexagon (the green area) in this kind of neighborhood. So forming a regular 3-lattice is as straightforward as doing a simple affine transformation (basically a shearing and a scaling): [img=width: 484px; height: 304px;]/c/portal/getImageAttachment?filename=fig2.gif&userId=93201[/img] So to take advantage of all the power of [b]CellularAutomaton[/b], all we have to do, is to use a following special 6-neighborhood stencil on rectangle lattices, meanwhile our model can be discussed and constructed on regular triangular lattice convieniently: [img=width: 118px; height: 57px;]/c/portal/getImageAttachment?filename=fig3.png&userId=93201[/img] And after the calculation, we can perform the affine transformation with following functions to get a nice hexagonal grid picture. [mcode]Clear[vertexFunc] vertexFunc = Compile[{{para, _Real, 1}}, Module[{center, ratio}, center = para[[1 ;; 2]]; ratio = para[[3]]; {Re[#], Im[#]} + {{1, -(1/2)}, {0, Sqrt[3]/2}}.Reverse[{-1, 1} center + {3, 0}] & /@ (ratio 1/ Sqrt[3] E^(I ?/6) E^(I Range[6] ?/3))], RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" (*,CompilationTarget?"C"*)]; Clear[displayfunc] displayfunc[array_, ratio_] := Graphics[{FaceForm[{ColorData["DeepSeaColors"][3]}], EdgeForm[{ColorData["DeepSeaColors"][4]}], Polygon[vertexFunc[Append[#, ratio]] & /@ Position[array, 1]]}, Background -> ColorData["DeepSeaColors"][0]][/mcode] [size=5][b]The Model[/b][/size] To construct the crystallization model, let's consider one of the 6-neighborhood stencil, where each cell represents a minimal crystal unit: [img=width: 261px; height: 236px;]/c/portal/getImageAttachment?filename=fig4.png&userId=93201[/img] A simple model will need only 2 states: [b]0[/b] for "[i]It's empty[/i]", [b]1[/b] for "[i]There is a crystal unit[/i]". So by considering all (except the [b]000000[/b] one, because we are generating ONE snowflake thus don't want a crystall randomly arises from void) [b]6-bit[/b] non-negative numbers, we can have a finite set of possible arrangements of the neighborhood: [mcode]stateSet = Tuples[{0, 1}, 6] // Rest[/mcode] However, from the viewpoint of physics, any two arrangements which can be transformed into each other with only rotation and reflection should be considered as the same arrangement in the sense of their physical effects on the central cell (i.e. cell[size=1]2,2[/size]) are the same: [img=width: 363px; height: 117px;]/c/portal/getImageAttachment?filename=fig5.png&userId=93201[/img] So we should gather [b]stateSet[/b] with above equivalence class: [mcode]gatherTestFunc = Function[lst, Union[Join[ RotateLeft[lst, # - 1] & /@ Flatten[Position[lst, 1]], RotateLeft[Reverse[lst], # - 1] & /@ Flatten[Position[Reverse[lst], 1]] ]]]; stateClsSet = Sort /@ Gather[stateSet, gatherTestFunc[#1] == gatherTestFunc[#2] &]; stateClsSetHomogeneous = ArrayPad[#, {{0, 12 - Length@#}, {0, 0}}] & /@ stateClsSet;[/mcode] Which turned out to be [b]12[/b] classes in total: [img=width: 710px; height: 127px;]/c/portal/getImageAttachment?filename=fig6.png&userId=93201[/img] Now from the viewpoint of cellular automaton, we need to establish a set of rules on how should any 6-neighborhood arrangement, i.e. those 12 kinds of equivalence classes, determine the state of the central cell. There are 4 kinds of possible transformations on cell[size=1]2,2[/size]: [b]0 --> 1[/b] is called [b]frozen[/b], [b]0 --> 0[/b] is [b]remaining empty[/b], [b]1 --> 1[/b] is [b]remaining frozen[/b], and [b]1 --> 0[/b] is called [b]melten[/b]. To make things more interesting and to explore more possibilities, we can introduce probability here, so certain arrangement will give certain probabilities corresponding to the 4 kinds of transformations. But notice that because of the unitarity of probability, we have Prob(frozen) + Prob(0->0) = 1 and Prob(melten) + Prob(1->1) = 1, so only 2 of the 4 probabilities are independent. In the following, we'll choose Prob(frozen) and Prob(melten), and denote them as [b]pFrozen[/b] and [b]pMelten[/b]. [img=width: 800px; height: 367px;]/c/portal/getImageAttachment?filename=fig7.png&userId=93201[/img] Back to physics / thermodynamics, those 24 probabilities, [b]pFrozen[/b] and [b]pMelten[/b], can of corse be determined by serious physical models, or they can be chosen randomly just for fun. For example, an intuitive (and naive) idea would be to believe an empty cell nearby a sharp pointed end or with abundant moisture source will have a high [b]pFrozen[/b]. (People who are interested in the serious physical models should not miss [url=http://psoup.math.wisc.edu/Snowfakes.htm]the Gravner-Griffeath Snowfakes model[/url].) Now we have the grid, the stencil, the neighborhood arrangement set and the transfer probabilities, we're offically ready to construct our cellular automaton rules. Following the above discussion, the construction is straightforward. There are only two points which need to pay attention to. One is to keep in mind that the rule function is applied on the 3x3 stencil, so even cell[size=1]1,1[/size] and cell[size=1]3,3[/size] has nothing to do with our model, don't forget handling them. The second is to use a [b]SeedRandom[/b] function to make sure same arrangement gives same result in same time step, otherwise the 6-fold rotational symmetry and 3 axes of reflection symmetry will both break! [mcode]Clear[ruleFunc] ruleFunc = With[{ stateClsSetHomogeneous = stateClsSetHomogeneous, seedStore = RandomInteger[{0, 1000}, 1000], pFreeze = {1, 0, 0.6, 0, 0.3, 0.15, 0, 0.2, 0, 0.2, 0, 0.8}, pMelt = {0, 0.7, 0.5, 0.7, 0.7, 0.5, 0.3, 0.5, 0.3, 0.2, 0.1, 0 } }, Compile[{{neighborarry, _Integer, 2}, {step, _Integer}}, Module[{cv, neighborlst, cls, rand}, cv = neighborarry[[2, 2]]; neighborlst = {#[[1, 2]], #[[1, 3]], #[[2, 3]], #[[3, 2]], #[[3, 1]], #[[2, 1]]} &[neighborarry]; If[Total[neighborlst] == 0, cv, cls = Position[stateClsSetHomogeneous, neighborlst][[1, 1]]; SeedRandom[seedStore[[step + 1]]]; rand = RandomReal[]; Boole@If[cv == 0, rand < pFreeze[[cls]], rand > pMelt[[cls]]] ]], (*CompilationTarget -> "C",*) RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" ] ];[/mcode] (Note: re-compile the rule function [b]ruleFunc[/b] will give a different set of [b]seedStore[/b] thus a different growth path.) Now everything is ready, let's grow a snowflake from the beginning! :D [mcode]dataSet = Module[{ rule, initM = {{ {0, 0, 0}, {0, 1, 0}, {0, 0, 0} }, 0}, rspec = {1, 1}, tmin = 0, tmax = 100, dt = 1}, rule = {ruleFunc, {}, rspec}; CellularAutomaton[rule, initM, {{tmin, tmax, dt}}] ]; // AbsoluteTiming Animate[ Rotate[displayfunc[dataSet[[k]], .8], 90 °], {k, 1, Length[dataSet], 1}, AnimationDirection -> ForwardBackward, AnimationRunning -> False, DisplayAllSteps -> True ][/mcode] [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] [size=5][b]Possible Improvements[/b][/size] We used a [b]SeedRandom[/b] function in our CA rule function to force the 6-fold rotational symmetry and 3 axes of reflection symmetry, and performed the CA calculation on all cells. However, this so called [url=http://demonstrations.wolfram.com/DihedralGroupNOfOrder2n/][i]D[/i][size=1]6[/size] symmetry[/url] can (and should) be integrated into our model, which will saving [b]11/12[/b] of the calculation. Also, the randomness of the growth path comes from [b]seedStore[/b], so to generate a new growth path, we have to re-compile the rule function. But with a improved model as described above, this constraint will no longer exist. [img=width: 800px; height: 177px;]/c/portal/getImageAttachment?filename=fig8.png&userId=93201[/img] [b][size=4] [size=5]Open question [/size] [/size][/b] Can we construct a well-organized structure (like the crystals) from a cellular automaton defined on an [b]irregular[/b] grid? While I believe the answer is [i]yes[/i], the next question would be [i]how?[/i] Silvia Hao 2014-04-11T16:03:33Z 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/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/2983903 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SudokuBlog-heroimage.png&userId=2028758 [2]: https://www.wolframcloud.com/obj/b9ea0b6a-1200-4c69-bd69-1e27edaa0a1b Alejandra Ortiz Duran 2023-08-04T23:54:58Z https://community.wolfram.com/groups/-/m/t/1286708 In 1356, Narayana posed a question in his book *Ga?ita Kaumudi*: "A cow gives birth to a calf every year. In turn, the calf gives birth to another calf when it is three years old. What is the number of progeny produced during twenty years by one cow?" This is now known as Narayana's cows sequence. The Narayana's cows sequence constant, **cow**=1.4655712318767680266567312252199391080255775684723, is the limit ratio between neighboring terms. LinearRecurrence[{1, 0, 1}, {2, 3, 4}, 21] NestList[Round[# Root[-1 - #1^2 + #1^3 &, 1]] &, 2, 20] Either gives {2, 3, 4, 6, 9, 13, 19, 28, 41, 60, 88, 129, 189, 277, 406, 595, 872, 1278, 1873, 2745, 4023}. This turns out to be a good constant to use for a Rauzy fractal. The outer fractal triangle can be divided into copies of itself r = Root[-1 - #1^2 + #1^3 &, 3]; iterations = 6; cowed[comp_] := First /@ Split[Flatten[RootReduce[#[[1]] + (#[[2]] - #[[1]]) {0, -r^5, r^5 + 1, 1}] & /@ Partition[comp, 2, 1, 1], 1]]; poly = ReIm[Nest[cowed[#] &, #, iterations]] & /@ Table[N[RootReduce[r^({4, 1, 3, 5} + n) {1, 1, -1, 1}], 50], {n, 1,14}]; Graphics[{EdgeForm[{Black}], Gray, Disk[{0, 0}, .1], MapIndexed[{Hue[#2[[1]]/12], Polygon[#1]} &, poly]}] ![fractal Narayana Cow spiral ][1] The ratio of areas for the triangles turns out to be **cow**. Try Area[Polygon[poly[[1]]]]/Area[Polygon[poly[[2]]]] and you'll see. If you want to laser cut that, it's handy to get a single path. cowpath[comp_] := First /@ Split[Flatten[RootReduce[#[[1]] + (#[[2]] - #[[1]]) {0, -r^5, r^5 + 1, 1}] & /@ Partition[comp, 2, 1], 1]]; path = ReIm[Nest[cowpath[#] &, N[Drop[Flatten[Table[r^({4, 1, 3} + n) {1, 1, -1}, {n, 1, 16}]], -1], 50], iterations]]; Graphics[{Line[path]}] What else can be done with **cow**? With some trickier code I put together the pieces this way. Notice how order 5 spokes appear. ![Narayana cow fractal egg][2] The opening gave an order 3 infinite spiral. Is there an order 5 infinite spiral? It turns out there is. Behold the **cow-nautilus**! ![cow-nautilus][3] It can be made with the following code: r=Root[-1-#1^2+#1^3&,3]; iterate=3; cowed[comp_]:= First/@Split[Flatten[RootReduce[#[[1]]+(#[[2]]-#[[1]]){0,-r^5,r^5+1,1}]&/@Partition[comp,2,1,1],1]]; base={{r^10,r^7,-r^9,r^11},{-r^12,-r^9,r^11,-r^13},{r^8,r^5,-r^7,r^9},{-r^7,-r^4,r^6,-r^8}}+{-r^10,r^11,-r^6,r^4+r^8}; naut=RootReduce[Join[Table[base[[1]] (-r)^n,{n,0,-4,-1}],Flatten[Table[Drop[base,1](-r)^n,{n,-8,0}],1]]]; poly=ReIm[Nest[cowed[#]&,#,iterate]]&/@N[naut,50]; Graphics[{EdgeForm[{Black}],MapIndexed[{ColorData["BrightBands"][N[Norm[Mean[#1]]/2]],Polygon[#1]}&,poly]},ImageSize-> 800] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fractalcowspiral.jpg&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cowegg.jpg&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cownautilus.jpg&userId=21530 Ed Pegg 2018-02-16T22:52:01Z 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/500948 There is a [Button][1] on the site Reddit, which resets a sixty second countdown. As long as the countdown never finishes, the button remains. The site's users, of which there are [more than three million][3], may each press the button once. Since April 1st, they have pressed the button nearly one million times, perpetuating it for more than a month and a half. Each user permanently bears the time they reset the countdown from; users compete, compare, and argue over pushing at various times. In the beginning times less than 50s were impossible, whilst today almost a third of times are single digit. Users are also colour coded into tens (and thus teams), 50's are purple, single digits red. This has produced some [awesome][4] visualisations, and a host of difficult questions, spanning game theory, community psychology, and statistics. A keen Mathematica user, I felt I could bring more visualisations (and some analysis) to the table I start by bringing a large raw data set (April 3rd to May 20th, available [here][5]) into Mathematica, and finding the times where the timer increases (implying it has been reset.) Data = Import["C:\\Users\\Me\\Desktop\\button.csv"]; Positives = First /@ Position[Sign[Differences[Data[[2 ;;, 2]]]], 1]; Then I cut the data into lists of reset times for each hour. For each hour (as a rolling average), the odds that each second will be reset (once begun) are calculated. I graph these in tens: single digits have red axes, tens, twenties, thirties, forties, and fifties, orange, yellow, green, blue and purple respectively. Within each graph Red is the first number (eg 59) and blue the last (eg 52). Thus each graph describes the population growth of each coloured team, and its devaluation as increasing proportions move through to the next colour. X axis hours since April 3rd. Hours = (Data[[2 ;;, 3]] /. {0 -> 60}) & /@ (GatherBy[Positives, Ceiling[#/3600] &]); Volumes = BinCounts[#, {0, 60, 1}] & /@ Hours; Passrates = Table[Quiet[Prepend[1 - (Volumes[[i]][[#]]/Total[Volumes[[i]][[1 ;; #]]] // N) & /@ Range[2, 60], 0]] /. Indeterminate -> 0, {i, Length[Volumes]}]; temp = Transpose[MovingAverage[Passrates, 24]]; Partition[Table[ListPlot[temp[[10 a + 1 ;; 10 a + 10]], PlotRange -> All, Joined -> True, PlotStyle -> "TemperatureMap", ImageSize -> Medium, AxesStyle -> {Purple, Blue, Green, Yellow, Orange, Red}[[6 - a]]], {a, 5, 0, -1}], 3] // Grid ![Passrates][6] Viewing the data all at once, four or five distinct cliffs can be seen, where people are prompt to select the rarer colours from low timers. As these numbers become more commonplace, the distinctions reduce. ListPointPlot3D[MovingAverage[SecondPassrates, 24]] ![Passrates3D][7] I wanted to find a simple formulation for this noisy ongoing change. I conjecture that peoples choices are primarily dependent on current rarity: at first a 40 was rare, and thus contested, as more 40's are taken, the value ascribed to a 40 decreases, and so lower numbers are reached. To this end I took the hourly volumes for each number and calculated log rarity (log 1 / probability of event) for each second, and plot against the observed rarity. This measure of the value of 'being ahead' proves extremely consistent! PassingProportion = #/Total[#] & /@ N[MovingAverage[BinCounts[#, {0, 60, 1}] & /@ Hours, 24]]; tempdat = Drop[#, 1] & /@ Table[{Total[First /@ #], #[[1, 2]], i} & /@ SplitBy[Transpose[{PassingProportion[[i]], -Log[1 - (Total[PassingProportion[[i]][[# ;; -1]]] & /@ Range[60])]}], Last], {i, Length[PassingProportion]}] /. {Indeterminate -> 0, ComplexInfinity -> 0, 52 - 4 I -> 56}; ListPointPlot3D[tempdat, ColorFunction -> "TemperatureMap", Background -> Black, BoxRatios -> {1, 1, 1}, ImagePadding -> 50] ![Rarity][8] Nonlinear model fitting quickly reduces this to an equation with only one time dependent term. This fudge factor likely contains various disregarded elements such as people with specific numeric targets. TimeFunction[t_] := E^(-0.0052123 t) LogCoefficient[t_] := 0.0634394 + 0.3266820 TimeFunction[t] LogLogCoefficient[t_] := -0.1382703 - 0.8857738 TimeFunction[t] AppealDistribution[x_, t_] := -0.0104844 + LogCoefficient[t] Log[1 + 1 x] + LogLogCoefficient[t] Log[Log[2 + 1 x]] Plot3D[AppealDistribution[x, t], {x, 0, 16}, {t, 0, 1100}, PlotRange -> {0, 0.35}, BoxRatios -> {1, 1, 1}] ![ProjectedRarity][9] The parameterisation allows prediction of future number proportions from current ones, whilst simply defined and a nice average, the model is too simple for any long term predictions. Pictured, the transition from the end of the data to my projection: ![Projection][10] Suffice to say Reddit has come up with a unique experiment! I'm told nice clean server side data will be published when the button finally ends. [1]: http://www.reddit.com/r/thebutton [2]: http://www.reddit.com/r/thebutton/%22button%22 [3]: http://www.reddit.com/about/ [4]: http://treyp.github.io/thebutton/ [5]: http://tcial.org/the-button/button_clicks.csv [6]: /c/portal/getImageAttachment?filename=2446Passrates.PNG&userId=445606 [7]: /c/portal/getImageAttachment?filename=Passrates3D.PNG&userId=445606 [8]: /c/portal/getImageAttachment?filename=Rarity.PNG&userId=445606 [9]: /c/portal/getImageAttachment?filename=ProjectedRarity.PNG&userId=445606 [10]: /c/portal/getImageAttachment?filename=Projection.PNG&userId=445606 **Moderation Team Note**: *We think you meant this link to [**Button**][1] - is it right? The one in your post below returns "page not found".* David Gathercole 2015-05-21T15:06:46Z 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/790393 And here it is: ![solid of constant width on 76 points][1] A [curve of constant width](http://demonstrations.wolfram.com/ArbitraryCurvesOfConstantWidth/), such as the [Reuleaux triangles](http://demonstrations.wolfram.com/CurvesAndSurfacesOfConstantWidth/), can be generated from any polygon. From any point there is another point at distance 1 with no points at a greater distance. In 3D, the problem is much harder. The sphere is a solid of constant width. If spherical curves are added to a tetrahedron, midpoints of opposing edges are at a distance greater than 1 apart. This flaw can be fixed with the special curve-smoothing techniques of the [Meissner tetrahedra](http://demonstrations.wolfram.com/MeissnerTetrahedra/). Several curves of constant width can be the basis of a [solid of revolution](http://demonstrations.wolfram.com/SolidOfRevolution/) to produce a solid of constant width. According to the paper ["On Curves and Surfaces of Constant Width"](http://arxiv.org/abs/1504.06733) by Howard L. Resnikoff, that's pretty much it. His paper introduces a few new possible surfaces, such as this one. SphericalPlot3D[1 + 1/10 Cos[3 t] Sin[3 u] Sin[u]^2, {u, -Pi, Pi}, {t, -Pi, Pi}, Boxed -> False, SphericalRegion -> True, ViewAngle -> Pi/10, ImageSize -> {600, 600}, Mesh -> None, Axes -> False, PlotPoints -> 200] ![Resnikoff surface][2] Is that really a solid of constant width? Let's make a function to find farthest points. FarthestPoints[pts_List, singlepoint_, num_] := SortBy[Complement[pts, Nearest[pts, singlepoint, Length[pts] - num ]], -MyEuclidean[singlepoint, #] &]; Then we generate many points on this surface, and find the point that is farthest away. resni = Flatten[Table[FromSphericalCoordinates[{(1 + 1/10 Cos[3 t] Sin[3 u] Sin[u]^2), u, t}], {u, .001, 3.14, .05}, {t, -3.14, 3.14, .1}], 1]; dists = Monitor[Table[EuclideanDistance[resni[[k]],FarthestPoints[resni,resni[[k]],1][[1]]],{k,1,Length[resni]}],k]; MinMax[dists] {1.99925, 2.07099} Not the desired result. It's close to being a solid of constant width, but not nearly close enough. Eleven months ago, I opened up the discussion [Biggest Little Polyhedra](http://community.wolfram.com/groups/-/m/t/463699), which led to a blog article on [biggest little polyhedra](http://blog.wolfram.com/2015/05/20/biggest-little-polyhedronnew-solutions-in-combinatorial-geometry/), and eventually I improved results and made a Demonstration for [biggest little polyhedra](http://demonstrations.wolfram.com/BiggestLittlePolyhedron/). I've had 1-3 computers steadily improving the results for nearly a year now. In short, you have $n$ points in 3 space, no two more than 1 apart. What is the greatest volume that can be bounded with the $n$ points with unit diameter? The classic solution, widely published, is to use the [Thomson problem](http://demonstrations.wolfram.com/ThomsonProblemSolutions/) solutions, but they are far from optimal. For example, with Thomson, 121 points are needed to bound a volume of 1/2. It turns out that 84 points with diameter 1 will suffice. One feature of the biggest little polyhedra is that they have lots and lots of unit length diagonals. Can they be used to make solids of constant width? With most of my smallest solutions there are problems similar to the trouble the tetrahedron has. There may be Meissner-like methods for fixing the flaws, but I haven't explored that yet. During the long search, I came across the page [Greater Self-Dual Solids](http://dmccooey.com/polyhedra/GreaterSelfDual.html). I especially liked the Self-Dual Icosioctahedron #4, and found that I could make a [caltrop](http://math.stackexchange.com/questions/1602770/any-other-caltrops) out of it, where every vertex was a unit distance from all corners of the opposing face. But it wasn't the optimal way to bound space with 28 points. Extending it to a solid of constant width caused the same sorts of flaws as the tetrahedron. ![28 vertex caltrop][3] I extended that self dual polyhedron to one on 76 points with tetrahedral symmetry. Points 1, 13, 25, 29, 41, and 53 are as follows: {{0.0833`, 0.0833`, 0.4930122817942774`}, (*{C1, C1, C4}*) {0.32530527130128584`, -0.20709494964790603`, 0.32530527130128584`}, (*{C3, -C0, C3}*) {0.28875291001058745`, 0.28875291001058745`, 0.28875291001058745`}, (*{C2, C2, C2}*) {-0.2142`, 0.40369721678726284`, -0.2142`}, (*{-C6, C5, -C6}*) {-0.07272969962634213`, 0.35355339059327373`, -0.35355339059327373`}, (*{-C7, C8, -C8}*) {0.07587339432355446`, 0.44185`, -0.23402687345687453`}} (*{C9, C10, -C11}*) The full vertices are as follows. There is something more elegant using the tetrahedral group, but I haven't gotten to that yet. cal76 ={{C1,C1,C4},{C1,-C1,-C4},{-C1,-C1,C4},{-C1,C1,-C4},{C4,C1,C1},{C4,-C1,-C1},{-C4,-C1,C1},{-C4,C1,-C1},{C1,C4,C1},{C1,-C4,-C1},{-C1,-C4,C1},{-C1,C4,-C1}, {C3,-C0,C3},{C3,C0,-C3},{-C3,C0,C3},{-C3,-C0,-C3},{C3,-C3,C0},{C3,C3,-C0},{-C3,C3,C0},{-C3,-C3,-C0},{C0,-C3,C3},{C0,C3,-C3},{-C0,C3,C3},{-C0,-C3,-C3}, {C2,C2,C2},{C2,-C2,-C2},{-C2,-C2,C2},{-C2,C2,-C2}, {-C6,C5,-C6},{-C6,C6,-C5},{-C5,C6,-C6},{-C6,-C5,C6},{-C6,-C6,C5},{-C5,-C6,C6},{C6,-C5,-C6},{C6,-C6,-C5},{C5,-C6,-C6},{C6,C5,C6},{C6,C6,C5},{C5,C6,C6}, {-C7,C8,-C8},{-C8,C8,-C7},{-C8,C7,-C8},{-C7,-C8,C8},{-C8,-C8,C7},{-C8,-C7,C8},{C7,-C8,-C8},{C8,-C8,-C7},{C8,-C7,-C8},{C7,C8,C8},{C8,C8,C7},{C8,C7,C8}, {C9,C10,-C11},{C9,C11,-C10},{-C10,C11,C9},{-C11,C10,C9},{-C11,-C9,-C10},{-C10,-C9,-C11},{C9,-C10,C11},{C9,-C11,C10},{-C10,-C11,-C9},{-C11,-C10,-C9},{-C11,C9,C10},{-C10,C9,C11},{-C9,-C10,-C11},{-C9,-C11,-C10},{C10,-C11,C9},{C11,-C10,C9},{C11,C9,-C10},{C10,C9,-C11},{-C9,C10,C11},{-C9,C11,C10},{C10,C11,-C9},{C11,C10,-C9},{C11,-C9,C10},{C10,-C9,C11}}; Here's what it looks like with all 150 unit diagonals added. ![caltrop 76 with unit diagonals][4] With the Farthest Point function from earlier, random points at unit distance can be added. For each random point on a sphere, we move it closer or farther from the origin so that the farthest point is at distance 1. The polar opposite is also generated. randomUnitDistancePointPolar[pointset_] := Module[{k},With[{randomspherepoint = .54 coord[{RandomReal[{0,2Pi}],RandomReal[{-1,1}],1}]},{randomspherepoint(k/.Quiet[Solve[{MyEuclidean[k randomspherepoint, FarthestPoints[pointset,randomspherepoint,1][[1]]]==1,0<k<2}]][[1,1]]),(-randomspherepoint)(k/.Quiet[Solve[{MyEuclidean[k (-randomspherepoint), FarthestPoints[pointset,(-randomspherepoint),1][[1]]]==1,0<k<2}]][[1,1]])}]]; Using the 76 points, a lot more points can be added. is76scw = Table[randomUnitDistancePointPolar[cal76], {10000}]; The crucial check -- are any two polar opposites more than 1 apart? Select[is76scw, EuclideanDistance[#[[1]], #[[2]]] > 1 &] There are no flaws. So far as I know, this is the first solid of constant width that has been found with tetrahedral symmetry. To generate the image at the top, use Graphics3D[ConvexHullMesh[Join[cal76,Flatten[is76scw,1]]]["GraphicsComplex"], Boxed-> False, ViewAngle-> Pi/10, ImageSize->{600,600} ] And there you have it, a new solid of constant width. It's also the best known way to bound space with 76 points. Mathematica just needed to make a few trillion calculations, optimizations, and improvements over an eleven month period to find it. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solid76.jpg&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ResnikoffSurface.jpg&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=caltrop.gif&userId=21530 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=caltrop76unitdiagonals.jpg&userId=21530 Ed Pegg 2016-02-09T21:54:47Z https://community.wolfram.com/groups/-/m/t/1320004 On April 8, Aubrey de Grey posted the paper "[The chromatic number of the plane is at least 5](https://arxiv.org/abs/1804.02385)" on arxiv.org. This tackles the long unsolved [Hadwiger-Nelson Problem](http://mathworld.wolfram.com/Hadwiger-NelsonProblem.html), where the plane is colored with the minimum colors so that no two points are a unit distance apart. There are many unit distance 4-chromatic graphs known, such as the [Golomb Graph](http://mathworld.wolfram.com/GolombGraph.html) (below), [Moser Spindle](http://mathworld.wolfram.com/MoserSpindle.html), and [Braced square](http://mathworld.wolfram.com/BracedPolygon.html). With these graphs you need at least 4 colors to avoid vertices of the same color being joined by an edge. With these, the *chromatic number of the plane* is at least 4. ![Golomb graph][1] The hexagonal grid can color the plane with 7 colors so that no two points are distance 1 apart. For decades, the chromatic number has been known to be one of the values 4, 5, 6, or 7. A few months ago, Aubrey contacted me due to my Demonstration [Moser Spindles, Golomb Graphs and Root 33](http://demonstrations.wolfram.com/MoserSpindlesGolombGraphsAndRoot33/), where I built up a large dense graph filled with many overlapping 4-chromatic graphs. I've also found a new graphs on my own. Here's one I call the Nested-7 graph, which might be the smallest unit-distance 4-chromatic graph without a 4-cycle. points=Flatten[Table[RootReduce[#.RotationMatrix[{0,-1,1}[[n]]Pi/21]&/@(CirclePoints[7]/ EuclideanDistance[{0,1},CirclePoints[7][[4+n]]])],{n,1,3}],1]; unitlines=Select[Subsets[Range[21],{2}],Chop[N[1-Quiet@EuclideanDistance@@points[[#]]]]==0&]; Graphics[{EdgeForm[{Black,Thick}],Line[points[[#]]]&/@unitlines,White, Disk[#,.05]&/@points,Black, Table[Style[Text[n,points[[n]]],10],{n,1,Length[points]}]}, ImageSize-> 500] ![Nested 7 graph][2] Aubrey had a Mathematica program for coloring a graph, and wondered if I could help him in his search. A few weeks ago, he found a unit-distance graph that seemed to need 5 colors. See the attached notebook. Length /@ {v, e} The graph has 1585 vertices and 7909 edges. It's a big one. Here are a few set up items, and then a graphic. We could definitely just draw the graph, but that many points and lines is hard to visually analyze. hexgrids = {{1, 2, 3, 10, 45, 74, 75, 111, 140, 141, 148, 206, 207, 214, 249, 278, 279, 338, 339}, {1, 398, 399, 406, 441, 470, 471, 507, 536, 537, 544, 602, 603, 610, 645, 674, 675, 734, 735}, {3, 794, 795, 802, 837, 866, 867, 903, 932, 933, 940, 998, 999, 1006, 1041, 1070, 1071, 1130, 1131}, {794, 1190, 1191, 1198, 1233,1262, 1263, 1299, 1328, 1329, 1336, 1394, 1395, 1402, 1437, 1466,1467, 1526, 1527}}; importantedges = {{3, 399}, {3, 1191}, {75, 471}, {141, 537}, {207, 603}, {207, 999}, {279, 675}, {339, 735}, {867, 1263}, {933, 1329}, {999, 1395}, {1071, 1467}, {1131, 1527}}; importantvertices = {1, 3, 794}; colors = {Red, Green, Blue, Cyan, Gray}; Graphics[{Point[v],EdgeForm[Black],Thick, Table[{colors[[n]],Line[v[[#]]]&/@Select[e,Length[Intersection[hexgrids[[n]],#]]==2&], Disk[v[[#]],.02]&/@hexgrids[[n]]},{n,1,4}], colors[[5]],Line[v[[#]]]&/@importantedges,Black,Disk[v[[#]],.04]&/@importantvertices}] ![Aubrey graph][3] Basically, there are four triangle grids, which I've colored red, blue, green, and cyan. There are 13 important edges, which I've colored in gray, and three important vertices where the triangle grids overlap. Of the important edges, six connect cyan and blue, six connect red and green, and one at the bottom connects blue and red. If these 73 vertices are removed, the remaining 1512 vertices split into four 378-vertex graphs that connect solely to one of the four triangular grids. The purpose of all these other vertices is to restrict the number of colorings If vertex 3 and edge {207, 999} are removed, the graph splits in half. Add vertex 3 back in and the graph looks like the following. Graphics[Line[v[[#]]] & /@ Intersection[e, Subsets[Sort[Append[First[ConnectedComponents[ Graph[#[[1]] \[UndirectedEdge] #[[2]] & /@ Complement[Select[e, Not[MemberQ[#, 3]] &], {{207, 999}}]]]], 3]], {2}]]] ![Half of Aubrey graph][4] In this half graph, the 12 outer vertices have the property that any 4-coloring forces the opposing vertices to have the same color. If the graph had a 4-coloring, the two bottom vertices would have the same color as the vertex at the top. But these two vertices are connected, so they cannot have the same color. Therefore, a 4-coloring doesn't exist. There is now a polymath project for finding the [smallest 5-chromatic unit-distance graph](https://polymathprojects.org/2018/04/10/polymath-proposal-finding-simpler-unit-distance-graphs-of-chromatic-number-5/). [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=GolombGraph_800.gif&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=nested7.jpg&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=AubreyGraph.jpg&userId=21530 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Aubreyhalf.jpg&userId=21530 Ed Pegg 2018-04-13T18:12:49Z 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 https://community.wolfram.com/groups/-/m/t/1733073 ![enter image description here][1] #Abstract# In this post, I will describe my process in examining the repetitive character of diagonal cells in the rule 45 elementary cellular automaton (CA). It is clear that along the left edge of the automaton, a pattern exists as the cells progress diagonally downward. By moving further to the right and studying subsequent diagonals, the patterns detected exhibit increasing periods. This phenomenon is seen in the rule 30 cellular automaton as periods appear to generally increase exponentially with increasing depth. Such period doubling is truly an interesting occurrence, and I studied the existence of similar repetitive behavior in rule 45. To analyze the patterns for especially longer sequences of cells, I devised an efficient algorithm for detecting patterns and their periods in the diagonals. After extracting long sequences of diagonal cells with increasing depth, I employed an algorithmic approach to evaluate the changes in period and examined this data to detect order in the increasing pattern periods. ## Properties of the Rule 45 Elementary CA ## ---------- Below is the rule plot for the Rule 45 CA. The neighborhoods are defined as sets of three cells, namely the left, middle, and right cells from the previous generation. As seen in the rule set, each configuration of three cells maps to a black or white cell in the next generation. Although these rules allows us to predict local behavior, it is important to keep in mind that they are not informative of how the automaton will look globally. ![The rule plot for the CA. ][2] Here are 1000 generations of the CA. The initial condition is one black cell in a background of white cells, and future generations are computed using the rule set above. ArrayPlot[CellularAutomaton[45, {{1}, 0}, 1000]] ![1000 generations of the CA][3] #I. Initialize Cellular Automaton# ---------- ###Initialize Cellular Automaton### The first step is to initialize our CA. numgen = 30000; ca = CellularAutomaton[45, {{1}, 0}, numgen]; The code above generates 30,000 generations of the Rule 45 CA. I needed enough data to extract diagonals long enough to analyze patterns. In other words, the diagonals have to contain multiple instances of repetitive sequences for accurate pattern recognition. ###Accessing Data from CA### The function [CellularAutomaton][4] generates a grid, or array of 1s and 0s to denote black and white cells. Therefore, we can treat the CA as an array of integers. CellularAutomaton[45, {{1}, 0}, 20][[3]] The code snippet above will retrieve the third generation from our CA. ##II. Extracting Diagonals## ---------- ###Traversing a Diagonal### In order to pick out diagonals from the CA array, I simply traversed a diagonal of slope two in the CA and created a 1-dimensional list of cells out of the diagonal. tbl = Table[ ca[[x + diagnumber - 1]][[ initpos + diagnumber - 1 - Ceiling[x/2] + 1]], {x, 1, ndiagonal}] As seen in the code, [Table][5] is used to traverse through the diagonal. The variable `initpos` stores the column of the one black cell in the first generation and `diagnumber` sets an "offset" to the starting position based on which diagonal is to be traversed (`diagnumber` refers to the depth of the diagonal from the left-hand diagonal edge of the automaton). Finally, the variable `ndiagonal` refers to the number of cells per diagonal. ###Structure of Diagonal (Visual)### In the image below, I marked the cells of the first diagonal with a red "X". Diagonals are defined as moving two cells south and one cell southwest. *This is important because the way we process our diagonals can change our pattern data*. ![enter image description here][6] ##III. Pattern Detection## ---------- ###Using `FindTransientRepeat`### The next step is to find patterns within the diagonals. However, I realized that some diagonals had some disorder at the beginning, and a repetitive structure (the pattern) only developed later on, so certain short sequences which interfered with the patterns had to be eliminated. Hence, I used the built-in function [FindTransientRepeat][7] to identify only the major repetitive sequence within the data. repseq = FindTransientRepeat[tbl, 2][[2]] In the code snippet above, `repseq` will contain a list with elements that occur successively in `tbl`, which contains the diagonal. ###Calculate Pattern Periodicity### To find the period of the data, I simply took the length of `repseq`. period = Length[repseq] Using this process, we can calculate the periodicity of the largest observed pattern in a given diagonal. ###Defining the `DiagonalPatternPeriod` Function### We can wrap the above process in a neat function that will take one argument (the diagonal depth, or number) and return the period of the pattern detected in that diagonal. DiagonalPatternPeriod[diagnumber_] := Length[FindTransientRepeat[ Table[ca[[x + diagnumber - 1]][[ initpos + diagnumber - 1 - Ceiling[x/2] + 1]], {x, 1, ndiagonal}], 2][[2]]] Here is an example call to the function: In[1]:= DiagonalPatternPeriod[34] Out[1]= 16 ##IV. Generating Data for a Range of Diagonals## ---------- ###Naive Approach | O(m*n) ### My function `DiagonalPatternPeriod` retrieves the period for one diagonal, but my aim was to examine period data for a range of diagonals starting from the left diagonal edge of the automaton. Initially, I defined a function named `prdlist` which would generate a list of periodicity data by running `DiagonalPatternPeriod` for every diagonal from 1...n. prdlist[n_] := Table[DiagonalPatternPeriod[d], {d, 1, n, 1}] Although short and sweet, the above approach was quite inefficient. For n diagonals each of length m, this approach would take O(m*n) time on average, and it therefore ran very slowly for large values of n. ###`BreakpointSearch` - More Efficient Approach | O(m*Log(n)) ### A key observation I made while examining the pattern periodicity data was that the periods grew quite slowly. I discovered that there were multiple subsequent diagonals that all shared the same pattern periodicity. Because the data contained long stretches of the same value, it seemed inefficient to display huge stretches of data all with the same number. Furthermore, I noticed that the periods were increasing in magnitude, meaning they were naturally in sorted order. These observations motivated an approach where I employed `DiagonalPatternPeriod` to identify points in the data where the periodicity changes, and I built the list based off of these "breakpoints." I used a modified binary search to calculate these breakpoints which in turn allowed me to generate the list of periods in a more efficient manner. `BreakpointSearch` is a function that finds the bounds of the leftmost stretch of one unique element in the interval st...end. Modeled off a binary search, the function can identify breakpoints in approximately log(n) comparisons, which is more efficient in terms of time than the naive approach. Additionally, this algorithm does not compute a long and nasty list full of numbers, but rather provides a condensed version of the list by omitting repeated periodicity values. BreakpointSearch[st_, stval_, end_, endval_, f_] := If[stval == endval, {end + 1, -1}, If[st == end - 1, {st + 1, f[st + 1]}, With[{mid = Floor[(st + end)/2], midval = f[Floor[(st + end)/2]]}, If[ endval == midval, BreakpointSearch[st, stval, mid, midval, f], If[stval == midval, BreakpointSearch[mid, midval, end, endval, f], BreakpointSearch[st, stval, mid, midval, f]]]]]] bpoints = {{1, DiagonalPatternPeriod[1]}}; temp = DiagonalPatternPeriod[n]; While[Last[bpoints][[1]] != n + 1, AppendTo[bpoints, BreakpointSearch[Last[bpoints][[1]], DiagonalPatternPeriod[Last[bpoints][[1]]], n, temp, DiagonalPatternPeriod]]] condensedprddata = Table[{bpoints[[x]][[1]] - bpoints[[x - 1]][[1]], bpoints[[x - 1]][[2]]}, {x, 2, Length[bpoints]}]; The sequence of commands above generate a condensed list of period data for a range of diagonals. After the search function is defined, a while loop runs to find the successive breakpoints from the left towards the right, and these values are stored in `bpoints`. 'condensedprddata' contains the condensed version of my periodicity data. ##V. Analysis of Period Data## ---------- Displaying `condensedprddata` yields the following result: {{1, 1}, {2, 4}, {23, 8}, {12, 16}, {7, 32}, {2106, 96}, {1849, 192}} The data translates to: one diagonal of period 1, then two diagonals of period 4, then twenty three diagonals of period 8, then twelve diagonals of period 16... Clearly, the data exhibits period doubling. The periodicity doubles from 4 to 8, 8 to 16, 16 to 32, and 96 to 192. This behavior is notable because the diagonals in rule 30 also show period doubling. Additionally, what I found very interesting was the random period *tripling* when the periodicity changes from 32 to 96. This seemed odd especially because the period tripling abruptly interrupted a sequence of period doubling. I speculate that such period tripling will occur again at a deeper diagonal within the automaton, and perhaps the sequence of period doubling and tripling form a pattern in itself. The cause of this tripling behavior is currently unknown, but I hope to further investigate relationships between the diagonals and their periodicity in the Rule 45 CA. ##VI. Visualization of Period Progression## ---------- Below, I created a visualization to display my investigation for the first few diagonals. The GIF highlights the first few diagonals and provides data regarding its periodicity. Below the diagram, there is an array showing the pattern (or repeating sequence) and the periodicity of the pattern. When a given diagonal is highlighted, red cells denote the white cells in the automaton, and blue cells denote the black cells in the automaton. Observe the rate, increments, and regions of the automaton in which there exist changes in periodicity. ![enter image description here][8] ##Future Work## In the future, perhaps I can expand this project by delving deeper into the automaton. Using a machine with more processing power, I hope to generate more generations in my CA and analyze diagonals with higher depths and longer lengths. I want to investigate applications of nonlinear-feedback shift registers to my pattern data and possibly develop a formula or feedback function that can generate data about deeper diagonal patterns in polynomial time. ##Github## https://github.com/AniruddhS24/WSS-Template/tree/master/Final%20Project/Final%20Submission ##Acknowledgements## Sincere thanks to Nikki Sigurdson for sharing her knowledge of computer science with me and guiding me through this project. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Image2MinPres.JPG&userId=1725215 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ruleplot.JPG&userId=1725215 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cathousandgen.JPG&userId=1725215 [4]: https://reference.wolfram.com/language/ref/CellularAutomaton.html [5]: https://reference.wolfram.com/language/ref/Table.html [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=diagonalX.JPG&userId=1725215 [7]: https://reference.wolfram.com/language/ref/FindTransientRepeat.html [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=test942.gif&userId=1725215 Aniruddh Sriram 2019-07-12T01:57:42Z https://community.wolfram.com/groups/-/m/t/1150337 The area of a unit-edge triangle is $\sqrt3/4$. The volume of a unit-edge tetrahedron is $1/(6\sqrt2)$. What happens beyond that? At the entry [simplex](http://mathworld.wolfram.com/Simplex.html) we can find the [Cayley-Menger Determinant](http://mathworld.wolfram.com/Cayley-MengerDeterminant.html). Since all those $d$ values will be 1, we end up taking the determinant of the inverse of the [identity matrix](http://mathworld.wolfram.com/IdentityMatrix.html). So we end up with reciprocals of the following for dimensions 2 to 6. 1/Table[Sqrt[(-1)^(n + 1)/(2^n (n!)^2) MatrixForm[(1 - IdentityMatrix[n + 2])]], {n, 2, 6}] ![enter image description here][1] The bottom (actually top) part winds up being $\sqrt{3},\sqrt{4},\sqrt{5},\sqrt{6},\sqrt{7}$ for dimensions 2 to 6, or dimension+1. The top (actually bottom) part is $\sqrt{2^n} n!$. The volume of the $n$-simplex turns out to be ${\large \frac{\sqrt{2^n} n!}{\sqrt{n+1}}}$. Table[Sqrt[n + 1]/(Sqrt[2]^n n!), {n, 2, 12}] ![area/volumes of triangle, tetrahedron, 4-simplex, ...][2] It seems that the reciprocals of dimensions 7 and 8 seem to be integers. The code below finds the sequence [A155946](http://oeis.org/A155946): 7, 8, 17, 24, 31, 48, 49, 71, 80, 97, ... . First /@ Select[Table[{n, (Sqrt[2]^n n!)/Sqrt[n + 1]}, {n, 2, 1000}], IntegerQ[Last[#]] &] For another check, (16) at [Triangle Area](http://mathworld.wolfram.com/TriangleArea.html) and (1) at [Tetrahedron](http://mathworld.wolfram.com/Tetrahedron.html) suggests a sequence of matrices that appends 1 to each coordinate and takes the determinant. If all but one of the coordinates is some permutation of $\left(0,0,0, ..., \frac{1}{\sqrt{2}} \right)$, those $n-1$ edges will all be distance 1 from each other. For the last coordinate point, we can find a point $\left( a,a,a, ..., a \right)$ at distance 1 from the other points. FullSimplify[(a /. Solve[Sqrt[(n - 1) a^2 + (a - 1/Sqrt[2])^2] == 1, a]) ] That gives us $a$ values of $ \frac{1-\sqrt{n+1}}{n\sqrt{2}}$ or $\frac{1+ \sqrt{n+1}}{n\sqrt{2}} $. For dimension 4, the former value is $\frac{1-\sqrt{5}}{4 \sqrt{2}} = \frac{\sqrt{3-\sqrt{5}}}{-4} = \frac{1-\phi }{\sqrt8}$, where $\phi$ is the [golden ratio](http://mathworld.wolfram.com/GoldenRatio.html). That leads to the following matrix which happens to give the predicted volume. $${\small V = \frac{\sqrt5 }{96} = \frac{1}{4!} \left| \begin{matrix} 0 & 0 & 0 & \frac{1}{\sqrt{2}} & 1 \\\\ 0 & 0 & \frac{1}{\sqrt{2}} & 0 & 1 \\\\ 0 & \frac{1}{\sqrt{2}} & 0 & 0 & 1 \\\\ \frac{1}{\sqrt{2}} & 0 & 0 & 0 & 1 \\\\ \frac{1-\phi }{\sqrt8} & \frac{1-\phi }{\sqrt8} & \frac{1-\phi }{\sqrt8} & \frac{1-\phi }{\sqrt8} & 1 \\\\ \end{matrix} \right| }$$ The square, cube, hypercube and so on are easier to calculate. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=matrix.jpg&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=volumes.jpg&userId=21530 Ed Pegg 2017-07-20T18:21:32Z https://community.wolfram.com/groups/-/m/t/1280901 Happy *e* day! As with pi, *e* is an irrational number (as well as [transcendental][1]), and repeats forever in a seemingly bizarre pattern of digits. It shows up in tons of places inside and outside of mathematics. I've always been a sucker for strange patterns, and love investigating them. The Wolfram Language has some of the best pattern matching capabilities available, so I wanted to make use of them to visualize the digits of *e*. I'm no number theorist or visualization expert by any means—just an enthusiastic user who likes puzzles—but was still able to come across some cool observations. ## Partitioning Digits of *e* ## The first thing that needed to be done to visualize how the digits of *e* behave is to essentially pick out those digits up to a certain placement. I chose the first 200 digits because, well, why not? First, I generated the digits: e = N[E,200] (*2.71828182845904523536028747135266249775724709369995957496696762772407663035354759457138217852516642742746639193200309921817413596629043572 9003342952605956307381323286279434907632338298807531952510190*) Next, I figured the easiest way to split the digits into single elements of a list was to turn the whole thing into a string, then split it, then turn it back into an expression: ToString[e] // StringSplit[#, ""] & // Drop[#, 2] & (*drops both the 2 and the decimal point so I just get digits after the decimal*)// ToExpression[#] & // (eList = #) & Finally, I decided to do a `ListLinePlot` just to see what I was working with: ListLinePlot[eList] ![enter image description here][2] So first thing I thought was, "huh, that looks like a time series", which informed the rest of what I did; I decided to do a Fourier transform as well, just to check out what the power spectrum would look like: fourierList = Rest[Abs@Fourier[eList]]; ListLinePlot[fourierList] ![enter image description here][3] ## Filtering and Comparison ## This thing definitely required some smoothing, so I used a basic `LowpassFilter` and varied the parameters a bit until my eyeballs thought it looked roughly ok. I did this both for the original sequence of digits: fit = LowpassFilter[eList, 0.1]; ListPlot[{eList, fit}, Joined -> True] ![enter image description here][4] As well as the transformed sequence of digits: fourierFit = LowpassFilter[fourierList, 0.1]; ListPlot[{fourierList, fourierFit}, Joined -> True] ![enter image description here][5] Finally, I wanted to get a sense of how well their relative "smoothness" compared, and if there was something more to investigate: ListLinePlot[{fit, fourierFit}, Filling -> Axis, PlotLegends -> {"Original", "Transformed"}] ![enter image description here][6] So to me, it looks like there's a pretty clear and consistent gap between digits of *e* before and after transformation. Could this distance be visualized? I wanted to try it; if nothing special came out of it, then, well, might at least look pretty. ## Distance Visualization ## First, I wanted to get a idea of the distance between consecutive digits of *e*—both the original sequence: MatrixPlot[DistanceMatrix[eList], PlotLabel -> "Distance matrix for first 200 digits of e", FrameTicks -> {Automatic, Automatic}] ![enter image description here][7] and the transformed sequence: MatrixPlot[DistanceMatrix[fourierList], PlotLabel -> "Distance matrix for first 200 transformed digits of e", FrameTicks -> {Automatic, Automatic}] ![enter image description here][8] Ok, those are pretty neat looking, and compared to the `MatrixPlot` of the first 200 digits in the `PrimePi` function, it is way less smooth (I'll leave it to y'all to explore that reference visual). Going back to my earlier desire of wanting to investigate the distance between the original sequence of digits and its corresponding transformed sequence, I was able to do that just as easily as these other two plots: DistanceMatrix[eList, fourierList] // MatrixPlot[#, PlotLabel -> "Distance matrix between sequences", FrameTicks -> {Automatic, Automatic}] & ![enter image description here][9] Interpreting this `MatrixPlot` is not something I know how to do, but as a visualization within the digit space of *e*, it's pretty cool to examine. Some other cool visuals for distance metrics I'd like to investigate for these sequences are force-directed graphs or a Voronoi diagram; maybe y'all can discuss those visualization techniques in this thread; would definitely be interested to see what gets produced! Enjoy this transcendental occasion! [1]: http://mathworld.wolfram.com/TranscendentalNumber.html [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=eList_plot.png&userId=515558 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fourierList_plot.png&userId=515558 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=eList_approx.png&userId=515558 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fourierList_approx.png&userId=515558 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-02-07at12.20.52PM.png&userId=515558 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=eList_distance.png&userId=515558 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fourierList_distance.png&userId=515558 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=distance_different.png&userId=515558 Jesse Dohmann 2018-02-07T18:43:33Z https://community.wolfram.com/groups/-/m/t/1747131 What is the smallest set so that differences of members of the set give all values from $1$ to $n$? This is a famous problem worked on by [Paul Erd?s](https://en.wikipedia.org/wiki/Paul_Erd%C5%91s), [Marcel J. E. Golay](https://en.wikipedia.org/wiki/Marcel_J._E._Golay), [John Leech](https://en.wikipedia.org/wiki/Leech_lattice), [Alfréd Rényi](https://en.wikipedia.org/wiki/Alfr%C3%A9d_R%C3%A9nyi), [László Rédei](https://en.wikipedia.org/wiki/L%C3%A1szl%C3%B3_R%C3%A9dei), [Solomon W. Golomb](https://en.wikipedia.org/wiki/Solomon_W._Golomb), [Alfred Brauer](https://en.wikipedia.org/wiki/Alfred_Brauer) and [C. Brian Haselgrove](https://en.wikipedia.org/wiki/C._Brian_Haselgrove), among many others. For example, {0, 1, 6, 9, 11, 13} covers 1 to 13. 1-0, 13-11, 9-6, 13-9, 6-1, 6-0, 13-6, 9-1, 9-0, 11-1, 11-0, 13-1, 13-0. For 13, the smallest set is 6. John Leech ("On the "Representation of 1,2,...,n by Differences", J. of London Math Soc, April 1956) gave the definitive answer: a lower bound of $\sqrt{2.434 n}$ (blue) and an "asymptotic" upper bound of $\sqrt{3.348 n}$ (green). The 63 year Leech bounds are still widely cited and used. Even today the Wikipedia article on [sparse rulers](https://en.wikipedia.org/wiki/Sparse_ruler) cites the bound as a disproof for the [Optimal Ruler Conjecture](http://oeis.org/wiki/User:Peter_Luschny/PerfectRulers#The_optimal_ruler_conjecture) of Peter Luschny. The Leech bound is cited by thousands of papers, some published just a few weeks ago. We can compare the Leech bounds to best known actual values (yellow) to 1750. ListPlot[{Table[Sqrt[2.434 n] - ( Sqrt[3 n + 9/4]), {n, 1, 1750}], Table[minimalSparse[[n]] - ( Sqrt[3 n + 9/4]), {n, 1, 1750}], Table[ Sqrt[3.348 n] - ( Sqrt[3 n + 9/4]), {n, 1, 1750}]}, AspectRatio -> 1/5] ![enter image description here][1] See all those lines of yellow dots? There is a deeper pattern to those lines. Now that I've extended results to 1750 and collected thousands of Wichmann-like ruler constructions, it seems the Leech bounds are wrong. This seems to be a *computational* problem rather than an *analysis* problem. I can also strengthen Peter's conjecture. >Sparse Ruler Conjecture. If a minimal sparse ruler of length $n$ has $m$ marks, easy (true to at least 1790): $m-\lceil \sqrt{3*n +9/4} \rfloor \in (0,1)$. hard (true to at least 473): $m+\frac{1}{2} \ge \sqrt{3 \times n +9/4} \ge m-1$. At [Sparse Rulers](http://demonstrations.wolfram.com/SparseRulers/) I have a Wolfram Demonstration on [sparse rulers](https://en.wikipedia.org/wiki/Sparse_ruler) up to length 1750. ![sparse ruler demo][2] A sparse ruler of length $n$ has $\lceil \sqrt{3*n +9/4} \rfloor + k$ marks, with $\lceil x \rfloor$ intended as the [round](http://mathworld.wolfram.com/NearestIntegerFunction.html) function and $k $ as the excess. The excess $k$ is 0 until 51, 59, 69, ... ( [A308766](http://oeis.org/A308766)) where $k=1$, the black square values in the pattern below to 1750. Minimal marks $m$ are listed in [A046693](http://oeis.org/A046693) and verified to length 213. Values increment down, then across. Bottom row values are Wichmann rulers [A289761](http://oeis.org/A289761). The columns correspond to lines in the pattern above. This grid with 1750 Tooltips is part of the [Sparse Rulers](http://demonstrations.wolfram.com/SparseRulers/) Demonstration. [![sparse rulers to 1750][3]][4] With more optimal sparse rulers the $(0,1)$ pattern for $m - \lceil \sqrt{3 \times n +9/4} \rfloor$ might look like the following if the hard form of the conjecture is true. Some of the 0-excess sparse rulers are really hard to find. It took trillions of computations to get to these patterns. [![predicted excess pattern][5]][6] These sparse rulers are vital for finding various high-valence [graceful graphs](https://math.stackexchange.com/questions/3246000/graceful-graphs-with-valence-k), such as the one below. [![octic graceful graph][7]][8] I was greatly helped by counts and code from [Parallel Computation of Sparse Rulers](https://software.intel.com/en-us/articles/parallel-computation-of-sparse-rulers) by Arch Robison. I asked him if he still had his data, but he hadn't kept a copy of it. The data is lost. But Tomas Sirgedas was able to recreate some of the data to value 150. You can compare the 63-year old mathematical bound to the data listed in the [Sparse Rulers](http://demonstrations.wolfram.com/SparseRulers/) Wolfram Demonstration. On 1st of August I identified about two thousand Wichmann-like ruler constructions that are infinite and built a few more algorithms to extend the pattern of [A046693](https://oeis.org/A046693)(n) - [A309407](https://oeis.org/A309407)(n) to n=4443. A lot of the black and green squares are likely white and black instead, but there's a definite weird pattern to this. "Dark Satanic Mills on a cloudy day" -- NJA Sloane. ![Dark Satanic Mills][11] With another overnight run I cleaned up the pattern more. ![Dark Mills Aug 1][12] Those green areas have excess 2 and are at positions {1792, 2096, 2097, 2098, 2099, 2429, 2782, 2783, 3161}. The attached file (sparsedata.nb) has my sparse ruler collection as of Thu 1 Aug 2019. Can anyone find sparse rulers with fewer marks for a given length? I have nine improvements so far that aren't included in the notebook. {0, 1966, {{1,14,27,55,28,55,28,1},{13,1,13,11,1,10,14,13}}} {0, 2286, {{1,15,29,59,30,59,30,1},{14,1,14,12,1,11,15,14}}} {0, 2630, {{1,16,31,63,32,63,32,1},{15,1,15,13,1,12,16,15}}} {0, 2931, {{1,17,33,67,34,67,34,1},{16,1,16,13,1,13,17,16}}} {0, 3319, {{1,18,35,71,36,71,36,1},{17,1,17,14,1,14,18,17}}} {0, 3390, {{1,18,35,71,36,71,36,1},{17,1,17,15,1,14,18,17}}} {0, 3806, {{1,19,37,75,38,75,38,1},{18,1,18,16,1,15,19,18}}} {0, 4167, {{1,20,39,79,40,79,40,1},{19,1,19,16,1,16,20,19}}} {0, 4246, {{1,20,39,79,40,79,40,1},{19,1,19,17,1,16,20,19}}} If anyone has trouble using the notebook (sparsedata.nb) in the above post, let me know. The [SparseRuleDemo](http://demonstrations.wolfram.com/SparseRulers/) might also be handy. I submitted a new Wolfram Demonstration on Wichmann-like rulers (see attached WichmannLikeRulers.nb). You can get a sneak peak of it here. ![Wichmann-like rulers][21] The 2216 Wichmann rules presented each produces an infinite number of sparse rulers. For lengths under 4444, I have about half a million sparse rulers at the moment. A full third of them comes from this set of Wichmann-like rules. If you'd like to produce sparse rulers with any integer length, this set of variants will provide a good start. Are there any infinite rules I'm missing here? The attached notebook, FindWichmann.nb, takes advantage of the 886 infinite Wichmann-like sparse ruler constructions given in the Wolfram Demonstration above. For any positive integer it will find the best sparse ruler that can be made from these Wichmann-like constructions within a few seconds. For example, let's make a sparse ruler of length 10 million. FindWichmann[10000000] {{{500, 22, {835, 2151}}, {501, 22, {835, 2151}}}, {{828, 24, {832, 2165}}, {829, 24, {832, 2165}}, {830, 24, {832, 2163}}}} WichmannRulerPlain[wichmannrules[[500]], {835, 2151}] ![wichmannruler for 10000000][31] A sparseness value of 22 is really awful compared to what I usually see. Sparseness is marks - round(sqrt(3 length +9/4)). The Leech bound is floor(sqrt(3.348 length) - round(sqrt(3 length +9/4)) ). So how bad is a sparseness of 22 compared to the Leech bound? LeechBound[10000000] 309 My instant direct construction is considerably better than the upper bound given by Leech. Let's try a higher value, 24! (620448401733239439360000). LeechBound[24!] 76959449642 FindWichmann[24!] {{{605, 852645032, {235567620692, 422893418966}}, .... WichmannRulerPlain[wichmannrules[[605]], {235567620692, 422893418966}] ![wichmann 24!][32] That is a sparse ruler with an excess of 852645032, considerably better than the Leech bound of 76959449642. That very likely isn't the optimal sparse ruler for length 24!, but it's reasonably minimal for a fast construction. Does this construction method ever exceed the Leech bound? It's not so good up to 117, where it exceed the Leech bound at lengths {1, 2, 3, 4, 5, 6, 13, 17, 23, 27, 34, 40, 41, 48, 51, 58, 59, 66, \ 69, 75, 76, 77, 86, 87, 88, 95, 96, 97, 98, 99, 109, 110, 113, 117}. I've found one case so far after that, 4211 has a Leech bound sparseness of 6 and an instantaneous construction sparseness of 8. ListPlot[{Table[values[[n]], {n, 1, 5813}], Table[ Sqrt[3.348 n] - ( Sqrt[3 n + 9/4]), {n, 1, 5813}]}, AspectRatio -> 1/5] ![Leech Bounds versus construction][33] LeechBound[4211] 6 FindWichmann[4211] {{46, 8, {13, 12}}, {258, 8, {11, 66}}, {272, 8, {11, 65}}, ... Through much, much slower methods I have 10 sparse rulers of length 4211 with an excess of 1. ![rulers 4211][34] With instant constructions here's what a sparseness diagram looks like to length 5763, with gray=0, black=1, red=2, orange=3, yellow=4, green=5, green=6, purple=8. ![instant sparseness diagram][35] For tedious slow constructions, here are the best known sparseness values to length 4443. Doing things the hard way gives much cleaner results. Some of the more optimal sparse rulers took months for me to find. No sparse rulers past length 213 have been proven optimal. ![slow sparseness diagram][36] Looks like I need more of these infinite Wichmann-like ruler constructions and perhaps some hard-coded rulers for under 120. Still, it is handy to have near instant constructions. Unsolved: 1. Does the FindWichmann construction ever exceed the Leech bound past 4211? 2. What are other Wichmann-like constructions that work infinitely for all input values? EDIT: I was told I was lemon-picking, finding the worst possible outcomes. Here's some cherry-picking for likely optimal sparse rulers of some arbitrary large values. FindWichmann[#][[1, 1]] & /@ {7^7, 2^27, 3^27} {{166, 1, {268, 490}}, {1, 0, {3326, 6759}}, {255, 1, {398580, 1594322}}} Row[{WichmannDisplay[wichmannrules[[166]], {268, 490}], WichmannDisplay[wichmannrules[[1]], {3326, 6759}], WichmannDisplay[wichmannrules[[255]], {398580, 1594322}]}, " "] ![rulers of powers][37] A046693[n]-A309407[n] -- Dark Mills pattern, 10501 terms. Gray=0 , Black = 1, Red = 2. Bottom row n values are https://oeis.org/A289761 . On August 13. I managed to clean up a lot of dust on this sequence. Some of the 1's and 2's might be 1 lower. Got to take a look at a three day run on another computer. Values for length 1313, 1358, 1448, 1583, 1673 are +1 dust in the image below due to the following sparse rulers: {{{1,11,1,21,1,21,22,45,23,1},{10,1,1,1,1,1,9,18,10,10}}, {{1,11,1,21,1,21,22,45,23,1},{10,1,1,1,1,1,9,19,10,10}}, {{1,11,1,21,1,21,22,45,23,1},{10,1,1,1,1,1,9,21,10,10}}, {{1,11,1,21,1,21,22,45,23,1},{10,1,1,1,1,1,9,24,10,10}}, {{1,11,1,21,1,21,22,45,23,1},{10,1,1,1,1,1,9,26,10,10}}} ![Dark Mills Sequence][41] [41]: https://community.wolfram.com//c/portal/getImageAttachment?filename=darkmillsAug12.jpg&userId=21530 [31]: https://community.wolfram.com//c/portal/getImageAttachment?filename=w10000000.png&userId=21530 [32]: https://community.wolfram.com//c/portal/getImageAttachment?filename=w24!.png&userId=21530 [33]: https://community.wolfram.com//c/portal/getImageAttachment?filename=leechbounds.png&userId=21530 [34]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ruler4211.png&userId=21530 [35]: https://community.wolfram.com//c/portal/getImageAttachment?filename=instantsparseness5763.png&userId=21530 [36]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sparseness4443.png&userId=21530 [37]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7power7.png&userId=21530 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Wichmann-like.png&userId=21530 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=DarkSatanicMills.jpg&userId=21530 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=darkmillsAug1.jpg&userId=21530 [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10456LeechBounds.jpg&userId=21530 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sparse.jpg&userId=21530 [3]: https://i.stack.imgur.com/Qlzqg.jpg [4]: https://i.stack.imgur.com/Qlzqg.jpg [5]: https://i.stack.imgur.com/wG2o4.jpg [6]: https://i.stack.imgur.com/wG2o4.jpg [7]: https://i.stack.imgur.com/9aDvG.jpg [8]: https://i.stack.imgur.com/9aDvG.jpg Ed Pegg 2019-07-28T01:11:23Z https://community.wolfram.com/groups/-/m/t/1869000 # Introduction: Dattatreya Ramchandra Kaprekar (1905–1986) created a mathematical routine, the Kaprekar´s routine, which is an iterative algorithm that takes a natural number and creates two new numbers, sorting the digits of the initial number in descending and ascending order, and then subtracts the second of the first to provide the natural number for the next iteration. Consequently, he found that 3-digit numbers always arrive at a constant (Kaprekar constant) equal to 495 and 4-digit numbers always converge at a constant (Kaprekar constant) equal to 6174. Another number of digits can only generate cycles or cycles with also other Kaprekar´s constant in a given smaller proportion. # Objective: The goal is to test the results of Kaprekar´s routines using numbers with 5, 6, 7 and 8 digits, creating a graphic impression of the cycles. The results should provide information such as: number of iterations until the cycles are found, number of terms in the cycles, if any number converges to a Kaprekar´s constant for a number of digits greater than 4, specific graphic impressions of the cycles for a specific number of digits and the proportions of each result. # Test of the Method (with 3 and 4 digit numbers): In this work, I used all the numbers with a certain number of digits sequentially as a sample, covering all the numbers (with 3, 4, 5, 6 and 7 digits). The exception is the final impression with all the 8 digit numbers that I had to use a random distributed sample to run the test as explained later. In some results of the Kaprekar´s routine, the numbers converge to 0, in cases such as: equal digits (1111), other numbers (2111), etc. In all tests in this work, I excluded the results that converge to 0, as for example, if I used 9000 numbers in the sample (4 digits), the result may have used only 8923 (that is, the difference is the excluded ones that converge to 0). To test the code, I intended to arrive at the same result for the Kaprekar´s constants, with 3 digits being 495 and 4 digits being 6174. For example, below, a code to generate random numbers and a code to make the successive iterations of the routine until reaching the converence: d = 4; b = 10; z = RandomInteger[{FromDigits@PadRight[{1}, d], FromDigits@Table[9, d]}] ![i1][1] Do[Do[z = FromDigits@Sort[IntegerDigits[z, b], Greater] - FromDigits@Sort@IntegerDigits[z, b], 1]; Print[z], 10] ![i2][2] Confirming the Kaprekar constants for all numbers with 3 and 4 digits (all 900 and 9000 numbers respectively): d = {3, 4}; b = 10; n = {900, 9000}; k = DeleteCases[ Table[z = Range[FromDigits@PadRight[{1}, d[[1]]], FromDigits@Table[9, d[[1]]]][[ss1]]; Do[z = FromDigits@Sort[IntegerDigits[z, b], Greater] - FromDigits@Sort@IntegerDigits[z, b], 15]; z, {ss1, 1, n[[1]]}], 0]; kb = DeleteCases[ Table[zb = Range[FromDigits@PadRight[{1}, d[[2]]], FromDigits@Table[9, d[[2]]]][[ss2]]; Do[zb = FromDigits@Sort[IntegerDigits[zb, b], Greater] - FromDigits@Sort@IntegerDigits[zb, b], 15]; zb, {ss2, 1, n[[2]]}], 0]; Do[Print[{{Text[Style[d[[1]], Bold, Large]], Counts@Sort@k, ListLinePlot[Tooltip@SortBy[Tally@k, First], LabelingFunction -> (Callout[#1, Automatic] &), PlotRange -> All, ImageSize -> Small]}, {Text[ Style[d[[2]], Bold, Large]], Counts@Sort@kb, ListLinePlot[Tooltip@SortBy[Tally@kb, First], LabelingFunction -> (Callout[#1, Automatic] &), PlotRange -> All, ImageSize -> Small]}}[[fs]]], {fs, 1, 2}] ![i3][3] Thus, samples were generated to be able to calculate all numbers with specific numbers of digits. In the example below, it was done with 3 and 4 digits simultaneously: d1 = {3, 4}; b1 = 10; it1 = 15; it2 = 20; z1 = {Range[FromDigits@PadRight[{1}, d1[[1]]], FromDigits@Table[9, d1[[1]]]], Range[FromDigits@PadRight[{1}, d1[[2]]], FromDigits@Table[9, d1[[2]]]]}; Using the following code, we obtained the number of iterations necessary to reach the Kaprekar´s constants with 3 and 4 digits: u1 = Sort@ Normal@Counts@ Table[z2 = z1[[1, t]]; e1 = Tally@ Table[Do[ z2 = FromDigits@Sort[IntegerDigits[z2, b1], Greater] - FromDigits@Sort@IntegerDigits[z2, b1], 1]; z2, it1]; e10 = DeleteCases[ If[MemberQ[ Table[If[ ContainsOnly[ IntegerDigits[ e1[[x, 1]]], {IntegerDigits[e1[[x, 1]]][[1]]}] == True, {}, e1[[x]]], {x, 1, Length@e1}], {}] == True, {}, e1], {}]; e2 = CountsBy[e10, Last]; e3 = If[e2 == <||>, 0, If[MemberQ[Keys@e2, 1] == False, 1, (1 /. e2) + 1]]; e3, {t, 1, Length@(z1[[1]])}]; u1b = Sort@Normal@Counts@Table[z2b = z1[[2, t]]; e1b = Tally@Table[ Do[z2b = FromDigits@Sort[IntegerDigits[z2b, b1], Greater] - FromDigits@Sort@IntegerDigits[z2b, b1], 1]; z2b, it2]; e10b = DeleteCases[ If[MemberQ[ Table[If[ ContainsOnly[ IntegerDigits[ e1b[[x, 1]]], {IntegerDigits[e1b[[x, 1]]][[1]]}] == True, {}, e1b[[x]]], {x, 1, Length@e1b}], {}] == True, {}, e1b], {}]; e2b = CountsBy[e10b, Last]; e3b = If[e2b == <||>, 0, If[MemberQ[Keys@e2b, 1] == False, 1, (1 /. e2b) + 1]]; e3b, {t, 1, Length@(z1[[2]])}]; v1 = AssociationThread[ DeleteCases[Keys[u1], 0] -> (DeleteCases[Keys[u1], 0] /. u1)]; v1b = AssociationThread[ DeleteCases[Keys[u1b], 0] -> (DeleteCases[Keys[u1b], 0] /. u1b)]; Do[Print[{ListLinePlot[Tooltip@v1, LabelingFunction -> (Callout[#1, Automatic, Scaled[1.5]] &), PlotLabel -> {Text[Style[d1[[1]], Large, Bold, Red]], Text[Style[v1, Small]]}, PlotTheme -> "Marketing", PlotRange -> All, ImageSize -> Large], Grid[Join[{{Style["3 digits", Red, Bold]}, {Style["Steps", Bold], Style["%Total", Bold]}}, Thread[{Range@5, N[100*(Range@5 /. v1)/Total@(Range@5 /. v1), 4]}]], Frame -> All], ListLinePlot[Tooltip@v1b, LabelingFunction -> (Callout[#1, Automatic, Scaled[1.5]] &), PlotLabel -> {Text[Style[d1[[2]], Large, Bold, Red]], Text[Style[v1b, Small]]}, PlotTheme -> "Marketing", PlotRange -> All, ImageSize -> Large], Grid[Join[{{Style["4 digits", Red, Bold]}, {Style["Steps", Bold], Style["%Total", Bold]}}, Thread[{Range@7, N[100*(Range@7 /. v1b)/Total@(Range@7 /. v1b), 4]}]], Frame -> All]}], 1] ![i4][4] - Test result of the method: The Kaprekar constants for 3 and 4 digits were confirmed and, for 3 digits, the maximum number of iterations to converge is 5, while for 4 digits the maximum number of iterations to converge is 7. All proportions were shown in the result. # Analysis for 5 and 6 digits: Natural numbers with the number of digits equal to 5 and 6 form cycles as a result of the Kaprekar´s routine. Below is an example of a 5 digit random number showing its cycle (in this case, it took 5 iterations to start the cycle and the cycle has 4 terms): ![i5][5] Do[Do[z = FromDigits@Sort[IntegerDigits[z, b], Greater] - FromDigits@Sort@IntegerDigits[z, b], 1]; Print[z], 15] ![i6][6] Generating lists of all natural numbers with 5 and 6 digits (all 90000 and 900000 respectively), we find the result for the number of necessary iterations until the cycles start: ![i7][7] The maximum number of iterations to start a cycle with the 5-digit numbers is 6 and the maximum number of iterations to start a cycle with the 6-digit numbers is 13. The result, as a percentage, of the number of iterations for all 5 and 6 digit numbers: ![i8][8] Using the following code, we have the number (and percentage) of terms that make up a cycle for all 5-digit numbers: d1 = 5; b1 = 10; z1 = Range[FromDigits@PadRight[{1}, d1], FromDigits@Table[9, d1]]; u1 = Table[it = 20; z2 = z1[[t]]; e1 = Tally@ Table[Do[ z2 = FromDigits@Sort[IntegerDigits[z2, b1], Greater] - FromDigits@Sort@IntegerDigits[z2, b1], 1]; z2, it]; e10 = DeleteCases[ If[MemberQ[ Table[If[ ContainsOnly[ IntegerDigits[ e1[[x, 1]]], {IntegerDigits[e1[[x, 1]]][[1]]}] == True, {}, e1[[x]]], {x, 1, Length@e1}], {}] == True, {}, e1], {}]; Length@DeleteCases[e10, {_, 1}], {t, 1, Length@z1}]; x1 = Counts@Table[u1[[f]], {f, 1, Length@u1}]; kk1 = AssociationThread[ DeleteCases[Keys[x1], 0] -> (DeleteCases[Keys[x1], 0] /. x1)]; Grid[Join[{{Style["5 digits", Bold, Red]}, {Style["Steps in Cycle", Bold], Style["Value", Bold], Style["%Total", Bold]}}, Thread[{Keys@kk1, (Keys@kk1 /. kk1), N[100*(Keys@kk1 /. kk1)/Total[Keys@kk1 /. kk1], 4]}]], Frame -> All] ![i9][9] For d1 = 6 (6-digit numbers), we have the number of terms in a cycle for 6-digit numbers. Where there is 1 term per cycle, it is where it converged in constants and this occurred in some of these numbers, that is, some numbers converged. The proportion of these numbers is also shown: ![i10][10] Finally, to create the impression for 5 digits, I defined some iteration intervals (sections), multiples of 4 and 2, because they are the number of terms in 5-digit cycles (in this case, I used sections with 4 different iteration numbers: {20,21,22,23}) and each with all 90000 numbers with 5 digits. d = 5; b = 10; n = 90000; Do[k = DeleteCases[ Table[z = Range[FromDigits@PadRight[{1}, d], FromDigits@Table[9, d]][[ss]]; Do[z = FromDigits@Sort[IntegerDigits[z, b], Greater] - FromDigits@Sort@IntegerDigits[z, b], f]; z, {ss, 1, n}], 0]; Print[{Text[Style[d, Bold, Large]], Text[Style[f, Bold, Red]], SortBy[Tally@k, First]}], {f, {20, 21, 22, 23}}] ![i11][11] Combining the values, we can cover the entire result for all the numbers in each term position in a cycle, finally showing the impression of the cycles generated from the 5-digit number. r1 = {{53955, 844}, {59994, 2158}, {61974, 12680}, {62964, 11514}, {63954, 10946}, {71973, 5852}, {74943, 18194}, {75933, 10368}, {82962, 9776}, {83952, 7574}}; r2 = {{53955, 2158}, {59994, 844}, {61974, 10946}, {62964, 18194}, {63954, 10368}, {71973, 11514}, {74943, 7574}, {75933, 9776}, {82962, 12680}, {83952, 5852}}; r3 = {{53955, 844}, {59994, 2158}, {61974, 10368}, {62964, 7574}, {63954, 9776}, {71973, 18194}, {74943, 5852}, {75933, 12680}, {82962, 10946}, {83952, 11514}}; r4 = {{53955, 2158}, {59994, 844}, {61974, 9776}, {62964, 5852}, {63954, 12680}, {71973, 7574}, {74943, 11514}, {75933, 10946}, {82962, 10368}, {83952, 18194}}; vv = GatherBy[Flatten[{r1, r2, r3, r4}, 1], First]; uu = Table[{vv[[j]][[1, 1]], Sum[vv[[j]][[i, 2]], {i, 1, Length@(vv[[j]])}]}, {j, 1, Length@vv}]; ww = Table[uu[[g, 1]] -> uu[[g, 2]], {g, 1, Length@uu}]; Grid[Join[{{Style["5 digits", Bold, Red]}, {Style["Number", Bold], Style["Quantity", Bold], Style["%Total", Bold]}}, Thread[{Keys@ww, (Keys@ww /. ww), N[100*(Keys@ww /. ww)/Total[Keys@ww /. ww], 4]}]], Frame -> All] ListLinePlot[Style[Tooltip@uu, Purple], LabelingFunction -> (Callout[#1, Automatic, Scaled[1.5]] &), Mesh -> Full, Filling -> Automatic, AxesStyle -> Directive[Red, 12], PlotRange -> All, ImageSize -> Large] ![i12][12] If we choose a random number with 5 digits and iterate until we form cycles, the chance of the result being in this proportion above is extremely high. Likewise, to have the impression of cycles for numbers with 6 digits (d = 6, n = 900000, f(iter) = {30,31,32,33,34,35,36}), a number of sections multiple of 7 and 1 was generated for the iterations (I used 7 and each with all 900000 6-digit numbers, to cover all possible terms within a cycle). After using a code similar to the 5-digit code, the result below was generated for 6 digits and shows the impression of the cycles for that specific number of digits: ![i13][13] # 7-digit analysis: Below, we can see that, for numbers with 7 digits, the maximum number of iterations to form cycles using the Kaprekar´s routine is 13 steps (iterations) and the number of terms in the 7-digit cycle is always 8. The list of numbers was generated with the code similar to the ones already used. ![i14][14] - Result (as a percentage) for all 7-digit numbers (note that there is no convergence to any Kaprekar constant using all 7-digit numbers): ![i15][15] To generate the impression of cycles coming from numbers with 7 digits, I used a number of sections multiple of 8 (I used 8), because it is the number of terms in a cycle formed by this number of digits. Below is the impression (note that, for 7-digit numbers, the chance is perfectly equal to finding a term number for the cycle when executing the Kaprekar´s routine): ![i16][16] # 8 digits: There are 90000000 numbers with 8 digits. For my machine to be able to perform a task with this quantity of numbers (each number has 35 iterations in the code), I divided this total quantity into the 7 parts below: d1 = 8; b1 = 10; z0 = NumericArray[Range[10000000, 39999999], "UnsignedInteger32"]; z1 = NumericArray[Range[40000000, 49999999], "UnsignedInteger32"]; z1b = NumericArray[Range[50000000, 59999999], "UnsignedInteger32"]; z1c = NumericArray[Range[60000000, 69999999], "UnsignedInteger32"]; z1d = NumericArray[Range[70000000, 79999999], "UnsignedInteger32"]; z1e = NumericArray[Range[80000000, 89999999], "UnsignedInteger32"]; z1f = NumericArray[Range[90000000, 99999999], "UnsignedInteger32"]; I was able to calculate all numbers (with 8 digits) and the result was added below to provide how many iterations to reach a cycle, the number of terms in each cycle and the Kaprekar constants with 8 digits, using a code similar to the one already used. That´s the result: ![i17][17] But, to have the impression of the cycle with numbers of 8 digits, it was not possible to do it in the same way as the previous ones, because it lacked computational power. I had to do 21 sections with a certain number of iterations because the number of terms per cycle can be 3, 7 or 1, the smallest possible multiple of those numbers is 21. So, it would be 21 x 90000000. To get around this, I generated a sample well distributed using 21 x 1000000 random numbers with 8 digits as follows (f(iter) = {35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55}): d = 8; b = 10; Do[k = DeleteCases[ Table[z = RandomInteger[{FromDigits@PadRight[{1}, d], FromDigits@Table[9, d]}]; Do[z = FromDigits@Sort[IntegerDigits[z, b], Greater] - FromDigits@Sort@IntegerDigits[z, b], f]; z, 1000000], 0]; Print[{Text[Style[d, Bold, Large]], Text[Style[f, Bold, Red]], SortBy[Tally@k, First]}], {f, {35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55}}] Combining the result from the 21 sections of iteration, I could see an outline of what the cycle impression would look like with 8 digit numbers. The values in the result are not exact because I used only 1.11% of the 90000000 at random in each of the 21 sections. Just so we can get an idea of what that impression looks like: vv = GatherBy[ Flatten[{r35, r36, r37, r38, r39, r40, r41, r42, r43, r44, r45, r46, r47, r48, r49, r50, r51, r52, r53, r54, r55}, 1], First]; uu = Table[{vv[[j]][[1, 1]], Sum[vv[[j]][[i, 2]], {i, 1, Length@(vv[[j]])}]}, {j, 1, Length@vv}]; ww = Table[uu[[g, 1]] -> uu[[g, 2]], {g, 1, Length@uu}]; Grid[Join[{{Style["8 digits(sample)", Bold, Red]}, {Style["Number", Bold], Style["Quantity", Bold], Style["%Total", Bold]}}, Thread[{Keys@ww, (Keys@ww /. ww), N[100*(Keys@ww /. ww)/Total[Keys@ww /. ww], 4]}]], Frame -> All] ListLinePlot[{Style[{{4.0*10^7, 3.36*10^6}, {10*10^7, 3.36*10^6}}, Dashed, Red], Style[{{4.0*10^7, 1.47*10^6}, {10*10^7, 1.47*10^6}}, Dashed, Red], Style[Tooltip@uu, Green]}, Filling -> Automatic, AxesStyle -> Directive[Red, 12], PlotRange -> All, PlotLabel -> {"8 digits, random sample: 21 x 1000000 (1.11% Total, \ each iter section)"}, ImageSize -> Large] ![i18][18] # Overall result: The confirmation of the method of this work for the Kaprekar constants with 3 and 4 digits was true. The 5, 6 and 7 digit study was a considered a success, as all numbers with this number of digits were used as sample, showing the probabilities after choosing a random number and after the Kaprekar´s routine arrives in a cycle. It was confirmed that only a few 6-digit numbers generate two different Kaprekar constants and data on their proportions and chances were also found. A satisfactory result was to have found two Kaprekar constants for some numbers with 8 digits, despite the great majority of the numbers having generated cycles. The proportions of iterations up to one cycle (max 19), the number of terms in one cycle and the proportions of the Kaprekar constant for 8 digits were successful, as all 90000000 numbers were used for these measurements. The graphic impression for the cycle for this number of digits was a partial success, as only a sample of numbers was used and not all as already discussed. Therefore, there are no precise values of their proportions in the final impression, just a graphic sketch of how it should be. Perhaps one day with greater computational power, improved code, etc., I will be able to do this work with a greater number of digits (9, 10, etc.) and with greater precision in a large number of digits. Thanks. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3732i1.png&userId=1316061 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9422i2.png&userId=1316061 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2072i3.png&userId=1316061 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6793i4.png&userId=1316061 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5393i5.png&userId=1316061 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3185i6.png&userId=1316061 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5604i7.png&userId=1316061 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1283i8.png&userId=1316061 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7805i9.png&userId=1316061 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3276i10.png&userId=1316061 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1169i11.png&userId=1316061 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8861i12.png&userId=1316061 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9640i13.png&userId=1316061 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3833i14.png&userId=1316061 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9658i15.png&userId=1316061 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8926i16.png&userId=1316061 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2569i17.png&userId=1316061 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10132i18.png&userId=1316061 Claudio Chaib 2020-01-29T16:11:03Z https://community.wolfram.com/groups/-/m/t/1356464 I made a [compound of 5 tetrahedra](http://mathworld.wolfram.com/Tetrahedron5-Compound.html). It's surprisingly sturdy. ![noodle spikey][1] This was built with [pool noodles](https://www.amazon.com/dp/B01BY1S2US/). Noodles are 55" (about 4.5 feet) long with a 2 3/8" diameter. Cut in half these give a Length/Diameter ratio of 11.5789. How close is that to a perfect Length/Diameter ratio? ![pool noodles][2] First, lets build up a dodecahedron with simple vertices and an edge length of 1.23607 or $\sqrt5-1$. From that dodecahedron, find the ten tetrahedra with edge length $2 \sqrt2 $ . Then find five disjoint tetrahedra. The following code works. tup=Tuples[{1,-1},{3}]; gold=Table[RotateRight[{0, \[Phi], 1/\[Phi]},n],{n,0,2}]; dodec=RootReduce[Union[Join[tup,Flatten[Table[gold[[n]] tup[[m]],{n,1,3},{m,1,8}],1]]]/.\[Phi]-> GoldenRatio]; tetra=FindClique[Graph[#[[1]]\[UndirectedEdge]#[[2]]&/@Select[Subsets[dodec,{2}],Chop[2 Sqrt[2]-EuclideanDistance@@N[#]]==0&]],{4},All]; compounds=FindClique[Graph[#[[1]]\[UndirectedEdge]#[[2]]&/@Select[Subsets[tetra,{2}],Length[Intersection[#[[1]],#[[2]]]]==0&]],{5},All]; Manipulate[Graphics3D[{ Table[{{Yellow,Red,Green,Purple,Blue}[[n]],Tube[#,thickness]&/@Subsets[compounds[[1,n]],{2}]},{n,1,k}], Table[{{Yellow,Red,Green,Purple,Blue}[[n]],Sphere[#,thickness 2 ]&/@compounds[[1,n]]},{n,1,k}]}, Boxed-> False, SphericalRegion->True, ViewAngle-> Pi/10, ImageSize-> 650], Row[{Control@{{k,5, "number shown"},1,5,1, ControlType->Setter },Spacer[15], Control@{{thickness,.11, "thickness"},.08,.20,.01, Appearance-> "Labeled" }}], SaveDefinitions->True] ![Manipulate 5 tetrahedra][3] The "perfect" Length/Diameter ratio for rigid tubes seems to be 11.8565. The half-noodle ratio is 11.5789. Since foam is forgiving, I figured that would give a tighter figure, and that turned out to be correct. For a regular dodecahedron with edge length 1, the inradius and circumradius are 1.11351 and 1.40125. For an edge length of 1.23607, the inradius and circumradius are 1.37638 and 1.73204. Based on the sizes of the tetrahedra, we can find the scaling factor of 11.4021. Height in inches is about 31 inches tall. Distance between vertices is about 14 inches. The notebook also has a color template. And that's how to build a spikey from pool noodles. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=noodle5tetra.png&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=noodles.png&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=manipulate5tetra.png&userId=21530 Ed Pegg 2018-06-15T19:42:04Z https://community.wolfram.com/groups/-/m/t/1250283 Hey Wolfram Community. I'm always continually enthused by how concise mathematica code can be. I was looking over my collection of 1-liners and found this old gem. I would like to see any other language do this is as many characters: ![enter image description here][1] Here's the code: w = {-{3, 1}, {1, 1}}; Dynamic[w = ScalingTransform[.96 {1, 1}, {-1.56, 0}]@w; ImageAdjust@MandelbrotSetPlot[Complex @@@ w, Frame -> None]] **Challenge:** can you tweak the parameters to make it loop around? And here's code to export the above gif: w = {-{3, 1}, {1, 1}}; AbsoluteTiming[ f = Table[Do[w = ScalingTransform[.98 {1, 1}, {-1.56, 0}]@w;, 4]; MandelbrotSetPlot[Complex @@@ w, Frame -> None, PlotRangePadding -> 0, ImageResolution -> 1000, MaxIterations -> 100, EscapeRadius -> 10000, ColorFunction -> ColorData["SunsetColors"], PerformanceGoal -> "Quality"], {300}];] Export["mz.gif", f, "DisplayDurations" -> Table[.05, Length@f], ImageResolution -> 500] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=mz_loop.gif&userId=900170 Michael Sollami 2017-12-19T18:47:13Z https://community.wolfram.com/groups/-/m/t/1368091 Divide a cuboid into two cuboids similar to the original shape. The answer involves the cube root of 2, otherwise known as the [Delian constant](http://mathworld.wolfram.com/DelianConstant.html). I've called this object the Delian Brick. It's a 3D 2-reptile. A stack of three bricks can be made using the cube root of 3, and so on. With[{r=2^(1/3)}, Graphics3D[{Opacity[.5], Cuboid[{0 r^0,0 r^1,0r^2},{1 r^0,1r^1,1r^2}], Cuboid[{1 r^0,0 r^1,0r^2},{2 r^0,1 r^1,1r^2}]},SphericalRegion-> True, Boxed-> False]] ![Delian Brick][1] I'd self-discovered the Delian Brick myself, as did at least ten other recreational mathematicians I've exchanged correspondence with. It may have been known to the ancient greeks. The first publication I've found is by Dale Walton and the game company Thinkfun, who expanded it into a 3D 4-irreptile they called the Fifth Chair puzzle. With[{r=2^(1/3)}, Graphics3D[{Opacity[.5], {Red,Cuboid[{0 r^0,0 r^1,0r^2},{2 r^0,r^1,r^2}], Cuboid[{1 r^0,1 r^1,0r^2},{2 r^0,2 r^1,1r^2}]}, {Blue,Cuboid[{0 r^0,1 r^1,0r^2},{1 r^0,3r^1,1r^2}], Cuboid[{1 r^0,2 r^1,0r^2},{2 r^0,3 r^1,1r^2}]}, {Green,Cuboid[{0 r^0,3 r^1,0r^2},{2 r^0,4r^1,2r^2}], Cuboid[{0 r^0,2 r^1,1r^2},{2 r^0,3 r^1,2r^2}]}, {Yellow, Cuboid[{2 r^0,0 r^1,0r^2},{4 r^0,2r^1,2r^2}], Cuboid[{0 r^0,0 r^1,1r^2},{2 r^0,2 r^1,2r^2}]}}, SphericalRegion-> True, Boxed-> False]] ![fifth chair][2] There are also [five space-filling tetrahedra](http://demonstrations.wolfram.com/SpaceFillingTetrahedra/), and at least two of them are 8-reptiles Row[{Graphics3D[{Opacity[.5],Polygon/@Union[Sort/@ Flatten[Subsets[#,{3}]&/@(IntegerDigits/@({{020,111,121,022},{022,111,112,222},{022,111,121,222},{022,113,112,222},{022,113,123,024},{022,113,123,222},{111,202,212,113},{111,222,212,113}}+111)-1),1]]}, Boxed-> False, SphericalRegion->True], Graphics3D[{Opacity[.5],Polygon/@Union[Sort/@ Flatten[Subsets[#,{3}]&/@(IntegerDigits/@({{002,022,111,113},{022,042,131,133},{022,222,111,113},{022,222,111,131},{022,222,113,133},{022,222,131,133},{111,131,220,222},{113,133,222,224}}+111)),1]]}, Boxed-> False, SphericalRegion->True]}] ![tetrahedron reptiles][3] More of these self-similar 3D dissections are listed at [3D Rep-Tiles and Irreptiles](http://demonstrations.wolfram.com/3DRepTilesAndIrreptiles/). The ones I list here need to be added there. Most of the 3D rep-tiles are based on either a 2D reptile or a polycube. The four items in this discussion fit in neither of those categories. Are there others? [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=DelianBrick.png&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=FifthChair.png&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=tetrahedronreptiles.png&userId=21530 Ed Pegg 2018-07-03T16:02:03Z https://community.wolfram.com/groups/-/m/t/2226424 I used Mathematica to create the following puzzle. [A playable version is here][1]. Normal sudoku rules apply. Digits cannot repeat along diagonals except when they appear on an arrow. In which case, they must repeat but only in the cell indicated by the arrow and digit (ie giving the direction and distance of the repeated cell). All of the numbers 1 to 8 must appear on (at least) one arrow. ![Duplicate Bridge][2] This was selected by Youtube channel [Cracking the Cryptic][3]. [![enter image description here][5]][4] One of the top comments: ![How the Hell?][6] I just asked Mathematica to come up with it for me, and blam, there it was. So, first a few functions. sudokucheck[perm_] := With[{p = Transpose[{Range[9], perm}]}, Length[Union[Ceiling[p/3]]] == 9]; diagcheckline[perm_] := Module[{p, bad}, p = Transpose[{Range[Length[perm]], perm}]; Select[#, Length[#] > 1 &] & /@ {GatherBy[p, #[[1]] - #[[2]] &], (GatherBy[p, #[[1]] + #[[2]] &])}]; diagdist[perm_] := Sort[Abs[#[[1, 1]] - #[[2, 1]]] & /@ Flatten[Subsets[#, {2}] & /@ Flatten[diagcheckline[perm], 1], 1]] A set of values in a sudoku can be considered a permutation. We can find all the permutations that would pass the boxes test. Then we can find all the permutations that would satisfy a queen's position, and then find all 7 cliques. FindClique[queengraph, {8}, All] reveals that no 8-cliques exist. pp = Permutations[Range[9]]; pass = Select[pp, sudokucheck[#] &]; queenprep = Select[pass, Length[Union[diagdist[#]]] == 0 &]; gatherqueen = Sort[GatherBy[queenprep, canonicalpermutation]]; canonqueen = First /@ gatherqueen; queen = Join[canonqueen, Flatten[Drop[#, 1] & /@ gatherqueen, 1]]; queengraph = Graph[UndirectedEdge @@@ Select[Subsets[Range[144], {2}], Count[Differences[queen[[#]]][[1]], 0] == 0 &]]; queencliques = First /@ GatherBy[Sort[Sort /@ FindClique[queengraph, {7}, All]], Sort[Position[gatherqueen, #][[1, 1]] & /@ queen[[#]]] &]; There are four basic ways to make a 7-clique with queens: Row[Graphics[{EdgeForm[{Black}],White,Rectangle/@Tuples[Range[9],{2}],Table[{Hue[k/7],Rectangle/@Transpose[{queen[[#[[k]]]],Range[9]}]},{k,1,7}], Thickness[.015],Black,Table[{Line[{{k,1},{k,10}}],Line[{{1,k},{10,k}}]},{k,1,10,3}]},ImageSize->250]&/@queencliques] ![7-cliques][7] There are 19 basic ways to avoid diagonals. Grid[Partition[Graphics[{EdgeForm[Black],White,Rectangle/@Tuples[Range[9],{2}],LightGray,Rectangle/@Select[Tuples[Range[9],{2}],EvenQ[Total[#]]&],Black,Rectangle/@Transpose[{#,Range[9]}]},ImageSize->90]&/@canonqueen,UpTo[10]]] ![9 queens][8] That's as far as I got for awhile. I don't recall making any good sudoku puzzles from the 7-cliques, though there may be a method I missed. I looked at the 6-cliques without anything amazing occuring to me. A few weeks ago I came back to the problem and pondered making a Super-X sudoku, where the 5 main diagonals each way would not have repeats. I don't think I found a solution. Then I tried reversing it -- what if all the repeats were just on a few diagonals. I found a position where only 4 diagonals had repeats, and created the following puzzle. Diagonal duplicates appear only in the marked diagonals. In the DUPE column, the numbers that duplicate are shown. In the MISS column, the digits that are missing from a diagonal are shown. ![Dupe or Miss][9] Not a terrible puzzle, but certainly not elegant. But it seemed there might be something. What could I call the puzzles of this type? Dupe .. Duplicate.... Duplicate Bridge! What if all the repeats were set up as bridges? A number on an arrow would give the distance and direction to the duplicate number. After a search, that led to the following puzzle. ![Original Duplicate Bridge][10] That's more elegant. Unfortunately, when restricted to just one duplication per number, there were only three basic configurations to choose from. Two of them were used in the puzzle immediately above. Then it occured to me that I could allow more than a single 1-bridge. A 9-bridge would be impossible, but there could be solutions with an 8-bridge and all smaller. If I could find a configuration that had 1 to 8 bridges, then a puzzle with no givens might be possible. If any were missed, say 8, then there would be no way to distinguish 8 and 9 on the grid without some extra information being given. So, create all the valid sudoku permutations that have 1, 2, 3, ..., 8 bridges, and then put the canonical queen positions at the end for the 9's. glass = Select[pass, Length[Union[diagdist[#]]] == 1 &]; glaze = Join[SplitBy[SortBy[glass, {Union[diagdist[#]], -Length[diagdist[#]]} &], Union[diagdist[#]] &], {canonqueen}]; Length /@ glaze {656, 1032, 224, 536, 400, 80, 48, 8, 19} The 6 to 9 configs are highly restricted, so lets find all that might work. part69=Select[Union[Tuples[Take[glaze,-4]]], Count[#[[1]]-#[[2]],0]==0&&Count[#[[1]]-#[[3]],0]==0&&Count[#[[2]]-#[[3]],0]==0&& Count[#[[1]]-#[[4]],0]==0&&Count[#[[2]]-#[[4]],0]==0&&Count[#[[3]]-#[[4]],0]==0&]; There are 2819 possibilities. So now, we find all the full configurations that might work. first5big = Take[glaze, 5]; pass69=Monitor[Table[ case1=(Select[#,Count[#-part69[[n,1]],0]==0&&Count[#-part69[[n,2]],0]==0&&Count[#-part69[[n,3]],0]==0&&Count[#-part69[[n,4]],0]==0&]&/@first5big); If[Min[Length/@case1]>0, tt=Select[Tuples[case1],Max[Count[#[[1]]-#[[2]],0]&/@ Subsets[#,{2}]]==0&]; Join[#,part69[[n]]]&/@tt,Sequence@@{}],{n,1,Length[part69]}],n]; Running the code, it turns out there there is only a single configuration that works! It's unique. So from there, it then needs to be set up as a puzzle, and hopefully it's human solvable. We have a computer solvable puzzle already. It's unique! Go find it, computer. But that's not a fun solving experience for a human. There are 2^12 = 4096 ways the arrows could be set up, so I decided to go for an easy arrow configuration to see if I could solve it. After a few tweaks I came up with a configuration that had a fairly good set of solving logic. Done! Many thanks to Philipp Blume for help, and to Cracking the Cryptic and Siman Anthony for accepting it. [1]: https://app.crackingthecryptic.com/sudoku/8GM2gn2H6M [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=DuplicateBridgeBest.png&userId=21530 [3]: https://www.youtube.com/watch?v=WEWn_P5Y3HQ [4]: https://www.youtube.com/watch?v=WEWn_P5Y3HQ [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cracking.png&userId=21530 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=howthehell.png&userId=21530 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7clique.png&userId=21530 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9queens.png&userId=21530 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=DUPEorMISS.png&userId=21530 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=DuplicateBridge.png&userId=21530 Ed Pegg 2021-03-22T17:58:50Z