Hot answers tagged

41

======= Update ========= Great question! It inspired this Wolfram Blog article and includes most of the code below plus some apps and fractal layouts like this: I think it make sense to keep the older code blow for archival and historic purposes. ======= Older implementation ========= Excellent motivating creativity question. This is a bit big for a ...


35

How about: list = Select[Tuples@Range[0, {8, 5, 3}], Total[#] == 8 &]; f[x_, y_] := Count[y ({8, 5, 3} - y) (x - y), 0] >= 2 sp = FindShortestPath[RelationGraph[f, list], {8, 0, 0}, {4, 4, 0}] (* {{8, 0, 0}, {3, 5, 0}, {3, 2, 3}, {6, 2, 0}, {6, 0, 2}, {1, 5, 2}, {1, 4, 3}, {4, 4, 0}} *) Explanation for f The transfer is from one bottle to one ...


30

With some diffidence (because there appears to be a Mathematica bug: see below), I would like to offer an answer in the spirit of the OP's original attempt to solve the problem algebraically. Solution This problem can be formulated as a binary integer linear program. The reformulation represents the square (or more generally, a rectangle as implemented ...


30

In this article the author solves the problem of tiling a rectangle by using pieces taken from a set of polyominoes, which are plane geometric figures formed by joining one or more equal squares edge to edge. For example, these are the pentaminoes, polyominoes formed by joining 5 squares: Of course this problem is more difficult than the one you asked ...


27

Edit faster version.. n = 10 pt = Flatten[Table[ {(j - i/2 - 1/2), -i (Sqrt[3]/2)}, { i, n}, {j, i} ], 1]; isegs = GatherBy[ Select[ Subsets[pt, {2}] , IntegerQ[(3/Pi) ArcTan @@ (Subtract @@ #)] & ], Norm[Subtract @@ #] & ]; all = Flatten[ Union@Select[Union@Flatten[#, 1] & /@ Subsets[#, {2}] , Length[#] == 3 ...


27

You can use LinearProgramming or more simply Minimize to solve this problem. The idea is to minimize an objective function of some decision variables subject to some constraints. The objective function doesn't matter, can be a constant function, the only relevant thing is the constraint satisfaction. First, setup the parameters, sets and clues (in an ...


24

The math in this one is too simple, which takes the fun out of it. However, if we could write some New Kind of Sentient Code™, it might look like this: WolframAlpha[StringJoin@ Riffle[ First@WolframAlpha["12 days of Christmas", {{"Result", 1}, "ComputableData"}] /. {_, _, gift_} :> First@StringSplit@gift /. "a" -> "one" // ...


19

The first part of the problem is partitioning a shape into smaller parts of a roughly equal area. Then we can add little "tongues" on the pieces to make them interlock. One idea for partitioning is using either a Delaunay triangulation of a set of points (for triangular pieces) or a Voronoi tessellation (for many-sided polygons). Let's take for example ...


19

A non brute-force approach is the following, similar to my answer for the Zebra Puzzle. Both puzzles are examples of constrainst satisfaction problems, that can be solved with Reduce/Minimize/Maximize or, more efficiently, with LinearProgramming. The good about this approach is that you can easily extend and apply to many similar problems. The common ...


16

I tried this but it didn't seem to work: 12 Do Run Most TrimmedMean; 11 Pi Plus Pi Pink; 10 Log Selection; 9 LatticeData; 8 Mode Sum Missing; 7 Sow On Assuming; 6 Glaisher Line In; 5 GoldenRatio; 4 Column Band; 3 For In Share N; 2 Total Div; And Apart Range Inner Part Re


16

Below is given a solution derived with ILP combinatorial optimization: The total of the assigned values to the $5 \times 5$ table is $61$. I called in the comments this approach to be "brute force" because of the generation of a larger number of variables and conditions and pushing them to Maximize or LinearProgramming. Same approach was used for my answer ...


15

I don't really know what kind of answer you expect here. Your answer is obviously the smart way. Brute force is always an option though: trianglePoints[n_] := Module[{p = {}, s = 1}, Do[Do[AppendTo[p, {a + b/2, Sqrt[0.75] b}], {b, 0, n + 1 - s}]; s++;, {a, 1, n + 1}]; p] res = Select[Subsets[trianglePoints[28], {3}], Norm[#[[1]] - #[[2]]] == ...


13

MorphologicalBranchPoints By "less trivial" I mean everything related to the problem. Let me give an example. One can consider this problem as an image-processing problem and calculate the number of triangles directly from the picture (the cropped one). thin = Thinning@ColorNegate@Binarize@Import@"http://i.stack.imgur.com/vhqI9.png" points = ...


11

I wrote an unification-based program as used in Prolog language. First, I setup a simple unification functions: Clear[unify]; unify[var1_Symbol, var2_Symbol] := If[var1 === var2, {}, {var1 -> var2}]; unify[const1_?StringQ, const2_?StringQ] := If[const1 == const2, {}, $Failed]; unify[var_Symbol, const_?StringQ] := {var -> const}; ...


11

Can't think out a better method than brute force, it'll be conciser in Mathematica of course: g = 10 # + #2 &; Pick[#, g[#, #2] #3 == g[#4, #5] == g[#8, #9] - g[#6, #7] & @@@ #] &@Permutations@Range@9 {{1, 7, 4, 6, 8, 2, 5, 9, 3}}


10

In the spirit of the question, Christmas (and triangular numbers)...done at short notice (apologies for imperfection) and perhaps to motivate more creative people. Seasons greetings and peace to all. Notebook with images is here. Sadly a large file but has images. As rm-rf observes $N=\frac{12\times13 }{6}=78$ is a little uninspiring...I am using the ...


10

Another possibility, at least for relatively small matrices, is to take the determinant (strictly speaking it is the permanent that is required, I suppose). For example, for an $11 \times 11$ matrix (o=5), I find there are 7 solutions. primePositions5 = Position[With[{o = 5}, Table[If[PrimeQ[n], 1, 0], {m, 0, Prime[o]^2 - Prime[o], ...


8

You can use the built-in functionality PolyhedronData["Icosahedron", "VertexCoordinates"] {{0, 0, -(5/Sqrt[50 - 10 Sqrt[5]])}, ... } or this short generator {0,##2}~RotateLeft~#&@@@Tuples@{{1,2,3},s={-1,1},s(1+√5)/2} ConvexHullMesh[%]


8

EDIT This edit (I hope corrects the problem identified by Mr. Wizard: (i) there was a typographical error "Kools", should have been "Kool", and the styling of desired targets has now been left to the end). I post this not as elegant but I spent some time and particularly like "unlikely"'s answer. The puzzle: Setting up: housenumber = Range[5]; ...


8

Range[9] // Permutations // Select[(10 #[[1]] + #[[2]])*#[[3]] == 10 #[[4]] + #[[5]] &] // SelectFirst[ 10 #[[4]] + #[[5]] + 10 #[[6]] + #[[7]] == 10 #[[8]] + #[[9]] &] So,17*4=68;68+25=93。 好玩吧


8

To make the brute force solution a bit more pleasant for the eye of the observer: testFunc = And[ FromDigits @ {#1, #2} #3 == FromDigits @ {#4, #5}, FromDigits @ {#4, #5} + FromDigits @ {#6, #7} == FromDigits @ {#8, #9} ]& ; sol = Range[9] // RightComposition[ Permutations, SelectFirst[ testFunc @@ # & ] ] {1, 7, 4, 6, 8, 2, 5, ...


7

Would this do the trick? selectWords[chars_, min_, max_] := Module[{charsset = Union[chars], charstally = Tally[chars], baselist, baselistchars, baselistpicks}, baselist = ToLowerCase[DictionaryLookup[x__ /; min <= StringLength[x] <= max]]]; baselistchars = Select[Characters /@ baselist, Complement[#, charsset] === {} &]; ...


7

EDIT: Verification function: ValidMatrixQ[m_] := With[{labelling = Flatten@m}, AllTrue[Range[25], ContainsAll[labelling[[AdjacencyList[GridGraph[{5, 5}], #]]], Range[labelling[[#]] - 1]] &] ] Is this a valid example? EDIT, Take 3: Grid courtesy of garej m = { {3, 2, 1, 2, 3}, {1, 4, 2, 4, 1}, {2, 3, 1, 3, ...


6

Another option, sort of like pattern matching on training wheels. First apply criteria for individual houses. ClearAll@"Global`*"; colors = {red, blue, yellow, ivory, green}; nations = {norway, ukraine, england, spain, japan}; drinks = {water, tea, milk, oj, coffee}; smokes = {kools, chesterfields, golds, luckys, parliaments}; pets = {fox, horse, snails, ...


6

A very simple one, not very elegant : f[o_] := Module[{mat, sol, vars, const, output}, mat = Table[If[PrimeQ[n], Unique["p"], 0], {m, 0, Prime[o]^2 - Prime[o], Prime[o]}, {n, m + 1, m + Prime[o]}]; vars = Cases[Flatten[mat], _?(Not[NumericQ[#]] &)] ; const = Join[{Last[First[mat]] == 1}, Total[#] == 1 & /@ mat, Total[#] == 1 & ...


5

My attempt: First we define the existing row, using dots to represent empty squares, and our hand of 7 letters. row="...t.t...r..e.."; letters="aodalip"; Next define a function to count how many times each of our letters appears in a given string. Also run this function on our letters, to count how many of each we have. ...


5

This is neither elegant nor smart nor memory efficient. It is a brute force method to get all solutions of a given size isGood[m_] := Sort@m === reye@Length@m; i : reye[l_] := i = Reverse@IdentityMatrix@l; getAllSolutions[n_?PrimeQ] := With[{id = IdentityMatrix@n}, Pick[id, #, 1] & /@ Boole@PrimeQ@Partition[Range[n^2], n] // ...


5

Another approach is to use LinearProgramming to find a configuration that satisfy the constraints. I wrote several answer illustrating some basic ideas of the method, and the use of binary decision variables ($0-1$) so I do not think it is necessary to dwell further on this topic. If necessary, you can check Daniel Lichtblau's answer for the "related" ...


4

You can try this: V = Table[RotateRight[{0, (-1)^j, (-1)^Floor[j/2] GoldenRatio}, Floor[(j - 1)/4]], {j, 12}]; You can plot it using ConvexHullMesh: ConvexHullMesh[V]


4

I have to post a separate answer because my approach in this one is very different from my other answer's. It is based largely on the method that Frank Kampus used here to solve a sudoku, using Backtrack from the Combinatorica package in one method, and Outer/Select in the other method. Warning: it's a long answer. I managed to solve the puzzle but only ...



Only top voted, non community-wiki answers of a minimum length are eligible