We’re rewarding the question askers & reputations are being recalculated! Read more.
17

Manipulate[MatrixPlot[Table[Mod[i + j, 2], {i, 1, n}, {j, 1, n}], ColorFunction -> "Monochrome"], {{n, 8}, 1, 20}] Nice and simple. To make it a little more terse we can use Array in place of Table: Manipulate[MatrixPlot[Plus ~Array~ {n, n} ~Mod~ 2, ColorFunction -> "Monochrome"], {{n, 8}, 1, 20}] With correct column numbering, thanks to a ...


12

Yes, this is possible with a little faff. What we want to do is get the RegionUnion of all the countries the antipode intersects with, and then intersect the antipode with that region, and get the remaining area. Let's use New Zealand as an example. ant = GeoAntipode[Polygon@Entity["Country", "NewZealand"]] Now, we can get the countries that this ...


11

For even n: MatrixPlot[ ArrayPad[DiagonalMatrix[{1, 1}], 3, "Reflected"], PlotTheme -> "Monochrome"]


8

My answer: cb[n_Integer /; n > 0] := MatrixPlot@SparseArray[{i_, j_} :> Mod[i + j, 2], {n, n}] cb[8] For those who desire a more traditional board: Block[{n = 8}, MatrixPlot[ SparseArray[{i_, j_} :> Mod[1 + i + j, 2], {n, n}], ColorFunction -> GrayLevel, FrameTicks -> { {#, #} &@ Table[{i, n - i + 1}, {i, n}], {#, #} &...


7

This is a direct implementation of this answer https://math.stackexchange.com/a/1967330/92921 m = 308460277; Reap[NestWhile[{#[[1]] - #[[2]] Sow@Floor[Divide @@ #]], Floor[#[[2]]/10]} &, {m, FromDigits@ConstantArray[1, Ceiling@Log[10, m]]} , #[[2]] > 0 &]][[2, 1]] // FromDigits 277614253 note this gives the 'closest' value ...


7

simple = Range[50]; Since the elements of the quads must be positive, eliminate factors containing zero. factors = Select[Flatten[PowersRepresentations[#^2, 3, 2] & /@ simple, 1], FreeQ[#, 0] &]; quads = Append[#, Sqrt[Total[#^2]]] & /@ factors (* {{1, 2, 2, 3}, {2, 4, 4, 6}, {2, 3, 6, 7}, {1, 4, 8, 9}, {3, 6, 6, 9}, {4, 4, 7, 9}, {...


6

A ploddingly procedural implementation: n = 308460277; FromDigits[Reap[Do[{q, n} = QuotientRemainder[n, (10^k - 1)/9]; Sow[q], {k, IntegerLength[n], 1, -1}]][[-1, 1]]] 277614253


6

The behavior of Plot3D is due to the discontinuity processing associated to Round. (Note the pattern here has many of the same holes, but not exactly the same pattern.) The discontinuities occur whenever the argument to Round is a half-integer. Given the complexity of the argument to Round in this example, perhaps not all discontinuities are detected. ...


6

Starting with table as input you can use FindSequenceFunction iteratively to find the function f0[table][x,y] that generates table: ClearAll[f0] f0[tab_][x_, y_] := FindSequenceFunction[FindSequenceFunction[#][y] & /@ tab][x] Example: table // Grid[#, Dividers -> All]& // TeXForm $\begin{array}{|c|c|c|c|c|c|c|c|c|c|} \hline 1 & 2 & ...


5

This is one of those problems that has many solutions: cb[n_] := MatrixPlot[ Range@ConstantArray[n, n] + Range[n], ColorFunction -> (GrayLevel@Mod[1 + #, 2] &), ColorFunctionScaling -> False, PlotRangePadding -> None, FrameTicks -> { {#, #} &@ Table[{i, n - i + 1, 0}, {i, n}], {#, #} &@ Table[{i, FromCharacterCode[...


5

Edit: Since now even I have understood the reasoning of the elf requiring more information because after measuring the tree the solution is not unique, I can give a full implementation too. When n is the magical number 2450, then we can create all possibilities with Union[Sort /@ Select[Tuples[Divisors[n], {3}], Times @@ # === n &]] Now, what's left ...


5

If you play with the PlotPoints option you get more examples of this:


4

func[n_]:= Module[{f=Not@*PrimeQ@*ToExpression,seqs,splits,len , digits=IntegerDigits@n,find,times,power,out}, power[a_,b_]:=ToString@a<>"^"<>ToString@b; times[a_,b_]:=ToString@a<>"*"<>ToString@b; seqs=SequencePosition[digits,_?(PrimeQ@*FromDigits),Overlaps->All]; splits = With[{r = Flatten[ ReplaceList[#, {{{x___}, {...


4

This is verification of answer: I will type code in am: (*the weights*) r = PowerRange[81, 1, 1/3]; (*generate possible positive weighings*) tu[n_] := Cases[Tuples[{-1, 0, 1}, n], {1, ___}] w = PadLeft[Catenate[tu /@ Range[5]]]; (*the weighings and the sum*) ans = {##, Style[{##}.r, Red, Bold]} & @@@ w; (*presentation*) tf = TableForm[#, TableHeadings ...


4

Here is an example of brute forcing this problem through enumeration and numerical optimization. OK, I realize my example was unnecessarily brute; I could at least order and bound the terms. ClearAll[enum, count, a, b, c, d, e]; enum[s_] := Tr /@ Tuples @ Thread[{-s, 0, s}] // Abs // Union mem : count[w__Integer] := mem = LengthWhile[Differences @ enum @ ...


4

For your particular problem: D[IntegerDigits[37, 5] {b^2, b, 1}, b] /. {b -> 5} // Total 12 In general you can create a function: f[num_, base_] := Module[{}, dig = IntegerDigits[num, base]; len = Length[dig]; D[dig Reverse[b^Range[0, len - 1] ], b] /. {b -> base} // Total] So that f[37,5] returns 12 and f[988,4] is 923.


4

You can create cylinders directly from the points. Graphics3D@ Table[Cylinder[{{pts[[i, 1]], 0, 0}, {pts[[i + 1, 1]], 0, 0}}, pts[[i, 2]]], {i, 1, Length@pts - 1}]


4

The right hand $F(x,y)$ has the simple closed form of: f[x_,y_] := 1/2 (x+y-1) (x+y-2) + x; This can be verified by running: Table[f[x,y], {x, 1, 10}, {y, 1, 10}] // MatrixForm The derivation of this form mostly stems from intuition, but it becomes clear if the row-number is subtracted from each element: Table[f[x,y] - x, {x, 1, 10}, {y, 1, 10}] // ...


3

f[n_, b_] := Module[{dig}, dig = IntegerDigits[n, b]; D[dig.Table[x^i, {i, Length@dig - 1, 0, -1}], x] /. x -> b ] Maybe a different example for illustration: f[2016, 28] 128


3

db[n_Integer, b_Integer] := FromDigits[(# Range[Length@#, 1, -1]) &@ Most@IntegerDigits[n, b], b] or db[n_Integer, b_Integer] := Total@MapIndexed[ ( #2[[1]] - 1 ) # b^(#2[[1]] - 2) & , Reverse@IntegerDigits[n, b]] db[37, 5] db[988, 4] 12 923


3

Running the code below, which shows the results for runs of 1000 shots, the rewards as set mean you should always take the 100% shot. With different rewards you could add a condition to take a different shot depending on the level of the increased reward. shot[chance_, reward_, hike_] := Module[{result}, result = If[chance < RandomInteger[{1, 100}], "...


3

Exclusions detection evaluates X3D[n,m] symbolically to analyse it for discontinuities. In your second example this returns the list X: X[[Round[Sqrt[n^2 + m^2]]]][[1]] (* {{0, 0}, {0, 0}, {0, 0}, .... *) That's a meaningless result for discontinuity analysis so it is ignored and the plot continues with no exclusions. But in your first example you get ...


3

int = Interpolation[pts, InterpolationOrder -> 0]; Plot[int[t], {t, 0, 30.1}] dom = {t}~Join~int["Domain"][[1]] {t, 0., 30.1} RevolutionPlot3D[int[t], Evaluate @ dom, RevolutionAxis -> "X", MeshFunctions -> {#1 &}, Mesh -> {pts[[;; , 1]]}, Boxed -> False, Axes -> False, ViewPoint -> {0, -2, 0}, MaxRecursion -> 5]


3

As to making the code slightly more efficient and shorter, I can point you in the right direction: FaroFrac2[p_, q_] := Module[{Q, M, P, G, G1, A, B, C0, L0, PQ, AB}, Q = Table[q, {p}]; M = 1; P = {p}; While[Total[P] > M, Q = Split[Sort[Q]]; M = Length[Q]; P = Length[#] & /@ Q; PQ = Transpose[{P, Q}]; G = GCD[#[[2, 1]], #[[1]]...


3

Short, but barely shorter than halirutan's. And much uglier. And it assumes that Santa is less than 100 years old. But I'm posting it anyway: n = 2450; Cases[IntegerPartitions[#,{3},Divisors@n]~Cases~ {x__/;1x==n}&/@Range@100,x:{_,__}:>x~MinimalBy~Max->Max@x]


3

Perhaps shorter: << Combinatorica` factors = Join @@ ConstantArray @@@ FactorInteger@2450; toWork = {#, Tr@#} & /@ (Sort /@ Apply[Times, KSetPartitions[factors, 3], {2}] // Union) Sort[First[Transpose @@ Select[GatherBy[toWork, Last], Length@# == 2 &]], Max] // First (* {5, 10, 49} *)


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


3

My solution ChessBoard[n_?IntegerQ] := MatrixPlot[ Flatten[ Table[ {Flatten@Table[{1, 0}, {n}], RotateLeft[Flatten@Table[{1, 0}, {n}], 1]}, {n}], 1], ColorFunction -> "Monochrome"] Manipulate[ChessBoard[n], {n, 2, 5, 1}]


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


2

Method 1. 63 chars (and 39 without beautifying to black-white) This considers the system as graph traversal where the number of steps is the sum and each step you wear different suit. Method 2. 87 chars with Array manipulation (63) I remixed Eldo's idea about reflection, better idea is probably to find a command to repeat a pattern like "repeat 10 N ...


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