# Tag Info

## Hot answers tagged puzzle

40

======= 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 ...

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 ...

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 ...

26

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 ...

23

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" // ...

20

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 ...

18

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 ...

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

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 = ...

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], ...

10

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}; ...

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[%]

7

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]; ...

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] === {} &]; ...

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

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

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, ...

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

Here is a webpage I set up which solves Cheryl's Birthday-like problems in full generality (i.e. you can specify any set of possible dates) using Mathematica CDF. http://cherylsbirthdaysolver.com

3

Sorry, but this afternoon I'm too lazy to think too much. Therefore here is the simple literal translation of the four conditions letting Boole[] do the main job and giving the unique result Select[ Flatten[Table[(10^3 a + 10^2 b + 10 c + d)* Boole[a != b && a != c && a != d && b != c && b != d && c != d ...

3

Select[IntegerDigits@Prime[Range[1, PrimePi[10^4]]], Length@Union@# == 4 && (* 4 different digits *) Equal @@ Times @@@ Partition[#, 2] && (* the product condition *) #[[1]] > 3 & (* #[[1]] >3 *) ] (* {6,3,2,9} *)

2

I wish I'd written the other answers. This is all I could manage: numbers = {"One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven", "Twelve"}; Total[ Cases[ Flatten[ StringSplit[#] & /@ {"One Partridge in a Pear Tree", "Two Turtle Doves", "Three French Hens", "Four Calling Birds", "Five Golden ...

2

So here's a clarification to the Mathematica Journal post that David Carraher has corrected and updated so it works in Mathematica 9 posted here. Now we all have working code for this cool Mathematica solution!

2

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 ...

2

Below is my (unsuccessful) attempt at solving the problem. I think this is an interesting problem that the MMA experts on here could help solve, and in the process will hopefully reveal the capabilities of MMA. 1) I borrowed from the answer in the linked Q&A the fact that the total of all elements in the matrix will be 468. This means that the row ...

2

I originally wrote this to help in guessing a word of known length from a bunch of letters, The word guessing game has 10 letters given so I tried to optimize this for speed. I reworked it here for scrabble: string = "hkxefri"; words = DictionaryLookup[{Apply[Alternatives, Characters[string]]} ..]; joined = StringJoin /@ ...

2

The following is not particularly inspiring. However, cand = {{"May", 15}, {"May", 16}, {"May", 19}, {"June", 17}, {"June", 18}, {"July", 14}, {"July", 16}, {"August", 14}, {"August", 15}, {"August", 17}}; c1[n_] := With[{rem = Cases[Tally[n[[All, 2]]], {x_, _?(# == 1 &)} :> x]}, DeleteCases[ n, {Alternatives @@ (Cases[n, {_, ...

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