Episode #125 of the Stack Overflow podcast is here. We talk Tilde Club and mechanical keyboards. Listen now

Tag Info

Hot answers tagged puzzle

44

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

41

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

35

Edit faster version.. n = 10 pt = Flatten[Table[ {(j - i/2 - 1/2), -i (Sqrt/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 &...

31

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

29

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

23

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

21

Just write the problem literally and use Reduce Reduce[ m >= 0 && w >= 0 && b >= 0 && {m, w, b} ∈ Integers && 2 m + 3/2 w + 1/2 b == 20 && m + w + b == 20, {m, w, b}] (* (m == 0 && w == 10 && b == 10) || (m == 2 && w == 7 && b == 11) || (m == 4 && w == 4 &&...

20

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

20

We can do this more efficiently using IntegerPartitions: Counts /@ IntegerPartitions[20, {20}, {1, 3, 4}/2] { <|2 -> 6, 3/2 -> 1, 1/2 -> 13|>, <|2 -> 4, 3/2 -> 4, 1/2 -> 12|>, <|2 -> 2, 3/2 -> 7, 1/2 -> 11|>, <|3/2 -> 10, 1/2 -> 10|> } Also as requested code for only one solution: Counts /@ ...

19

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

18

Another solution: Select[FrobeniusSolve[{20, 15, 5}, 200], Total[#] == 20 &] {{0, 10, 10}, {2, 7, 11}, {4, 4, 12}, {6, 1, 13}} The first element in each list is the number of men, the second element is the number of women, and the third element is the number of babies.

17

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

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 = Dilation[#, 1]...

16

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, {3}], Norm[#[] - #[]] == ...

14

Mathematica's FindIndependentVertexSet can find maximal independent set (size 14 =2n-2) by default. The following finds "12". I have not explored symmetries as I am about to sit down for family Christmas Lunch. Happy Holidays to All! tu = Tuples[Range, 2] fun[{a_, b_}, v_] := Module[{}, UndirectedEdge[{a, b}, #] & /@ NestWhileList[# + v &, {...

13

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

12

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}; unify[const_?... 12 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], Prime[o]},... 12 # /. Solve[{ 10^2 d + 10 e + f + 10^2 f + 10 e + f == 10^2 g + 10 h + h, 2 (10^2 k + 10 l + m) == 10^2 n + 10 k + l, 3 (10^2 a + 10 b + c) == 10^2 b + 10 b + b} ~ Join ~ Thread[0 <= # <= 9 &@#], #, Integers]& @ {a, b, c, d, e, f, g, h, k, l, m, n} // Short[#, 6] & {{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ... 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

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 // RightComposition[ Permutations, SelectFirst[ testFunc @@ # & ] ] {1, 7, 4, 6, 8, 2, 5, 9,...

10

a solution to the puzzle: consider each of the 4 wheels as a 16x4 matrix with zeros for all of the "open" or "always covered" areas: wheel1 = { {2, 15, 23, 19, 3, 2, 3, 27, 20, 11, 27, 10, 19, 10, 13, 10}, {22, 9, 5, 10, 5, 1, 24, 2, 10, 9, 7, 3, 12, 24, 10, 9}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...

10

YAW: Yet Another Way. FindInstance seems created for such tasks: Let m = number of men, w = number of women, b = number of babies. FindInstance[{2 m + (3/2) w + (1/2) b == 20, m + w + b == 20, m >= 0, w >= 0, b >= 0}, {m, w, b}, Integers, 10] (*{{m -> 0, w -> 10, b -> 10}, {m -> 2, w -> 7, b -> 11}, {m -> 4, w -> 4, b -&...

9

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

9

Range // Permutations // Select[(10 #[] + #[])*#[] == 10 #[] + #[] &] // SelectFirst[ 10 #[] + #[] + 10 #[] + #[] == 10 #[] + #[] &] So,17*4=68；68+25=93。 好玩吧

8

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

8

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

8

EDIT: Verification function: ValidMatrixQ[m_] := With[{labelling = Flatten@m}, AllTrue[Range, 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, 2}...

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