Message Boards Message Boards

YouTube quizzes: Share your Wolfram Language solution!

Let's share our Wolfram Language solutions of any arbitrary quiz/maths challenge which we found on the tube! I am not subscribed to such channels but once in a while, I would see a maths quiz video on my YouTube Recommendations page, for example, MindYourDecisions.

So how about this recent one: What Is The Area? "You Should Be Able To Solve This" enter image description here

I am not interested in his analytical solution, tbh never watched the full video. I stopped the video right after the problem statement! I just want Mathematica to spit out the numerical (exact or approximate) solution. I've come so far:

In[1]:= r1 = Region@Polygon[{{0, 0}, {a/2, 0}, {x, y}, {0, a/2}}];
        r2 = Region@Polygon[{{0, a/2}, {x, y}, {a/2, a}, {0, a}}];
        r3 = Region@Polygon[{{a/2, a}, {x, y}, {a, a/2}, {a, a}}];
        r4 = Region@Polygon[{{a/2, 0}, {a, 0}, {a, a/2}, {x, y}}];
        eqs =
          {Area[r1] == 16,
           Area[r2] == 20,
           Area[r3] == 32,
           Area[r4] == a^2 - (16 + 20 + 32),
           11 > x > 0, (* looking at the picture, I chose an estimated upper bound of 11 *)
           11 > y > 0, (* bounding the variables should help the convergence of the numerical solver *)
           11 > a > 0 (* but it is not always necessary to provide upper bounds *)

Then I've tried NSolve[ ], NMinimize[ ], FindInstance[ ], FindMinimum[ ] and only one of them worked. I must admit that I don't have much experience with these three functions and my PC's memory is limited too.

        sol = FindMinimum[{0, eqs}, {x, y, a}, Reals] (* FAIL *)
        sol = NSolve[eqs, {x, y, a}, Reals] (* FAIL *)
        sol = FindInstance[eqs, {x, y, a}, Reals] (* FAIL *)
In[6]:= sol = Last@NMinimize[{0, eqs}, {x, y, a}, Reals] (* {x -> 2.44949, y -> 4.08248, a -> 9.79796}} *)
Out[6]= {x -> 2.44949, y -> 4.08248, a -> 9.79796}
In[7]:= Area[r4] /. sol
Out[7]= 28.

Whenever you come across a youtube quiz and solved it as a recreational task, please share it here, it's much fun!

POSTED BY: Raspi Rascal
11 Replies

Thanks xzczd for the pointer! So what about this one where i failed to even code the problem statement:

VERY HARD South Korean Geometry Problem (CSAT Exam) enter image description here

The first step is to identify the three distinct points. Point C be the tip of the cone. The coordinate system's origin be at the center of the cone base:

pA = {20, 0, 0};
pB = {Bx, 0, Bz}; (* y-coordinate of B is zero *)
pC = {0, 0, Cz};
Cz = Sqrt[60^2 - 20^2]; (* Phythagoras for the cone height *)
(20 - Bx)^2 + Bz^2 == 10^2; (* Phythagoras for z-height of B *)
Bx > 0;(* x-coordinate of B *)
Bz > 0; (* z-coordinate of B *)
20/Bx == 60/(60-10); (* intercept theorem *)
Bx = 50/3; (* In[10]:= Solve[{(20-Bx)^2+Bz^2==10^2,Bx>0,Bz>0,20/Bx==60/(60-10)}] *)
Bz = 20 Sqrt[2]/3; (* Out[11]= {{Bx -> 50/3, Bz -> (20 Sqrt[2])/3}} *)

The cone is fully defined, the three points are fully known. It is obvious that point A can be connected to point B through millions of space curves S all of which lie in the region boundary of the cone. We would like to find the shortest path (or tour) S which has the minimum arc length from A to B, under the condition that the path does revolve around the cone once. The most direct mathematical description of a curve in 3D-space is through the parametrization with a single parameter t, $\overset{\rightharpoonup }{r}(t)=\{x(t),y(t),z(t)\}$. Once we know the parametrization of $\overset{\rightharpoonup }{r_S}(t)$, i.e. the full description of the path S in dependence of parameter t, it is a piece of cake to calculate any other quantity, such as the length of S and the length of S up to the point where the curve reaches its maximum z-height.

I've tried the Wolfram Language items Cone[ ], Region[ ], RegionBoundary[ ], RegionMember[ ], RegionMeasure[ ], and also ImplicitRegion[ ], RegionDifference[ ] and didn't get any far. I believe we will need FindMinimum[ ] or NMinimize[ ], with ArcLength[ ] being our objective function for minimization or use FindShortestTour[ ], FindCurvePath[ ], but i fail to put the coding pieces together. This problem has imho more to do with maths than with coding, but we should be able to solve it idiomatically getting an analytical solution anyway, shouldn't we?

Anyone with such a solution?

POSTED BY: Raspi Rascal
Posted 6 years ago

As far as I know, the stand way for attacking this type of problem is unfolding the cone to a sector:

enter image description here

In the new coordinate system the coordinate of A and B is

p@A = {60, 0}; p@B = FromPolarCoordinates@{50, (2 π 20)/60};

and apparently the parametric equation for the shortest tour is

eq2D = (p@A - p@B) t + p@B // ToPolarCoordinates

where 0 < t < 1.

Then we just need some coordinate transform to find the equation in original coordinate system:

α = ArcSin[20/60];    
h = 60 Cos@α;
eq3D = Function[{r, θ}, 
    "Cylindrical" -> "Cartesian", {r Sin@α, 60 θ/20, h - r Cos@α}]] @@ 

Graphics3D@{Opacity[0.5], Cone[{{0, 0, 0}, {0, 0, h}}, 20]}~Show~
 ParametricPlot3D[eq3D, {t, 0, 1}, PlotRange -> All]

enter image description here

Not sure if this problem can be attacked in a more straightforward way i.e. directly finding the equation in 3D space.

POSTED BY: xzczd  

Yikes, terrific solution (which i don't fully understand tbh np) thanks for the share with the 3D plot, appreciated! Today i watched the video to the end (and understood it np) and was surprised, not impressed, by the easy solution; most of his suggested solutions are only possible because of the symmetry or primitivity of the involved geometric objects, shapes, and whatnot. What if the cone was not a right cone but a skew cone or an arbitrarily shaped mountain 3-D surface given by $\overset{\rightharpoonup }{r_S}(s,t)$ or by $z_S=f(x,y)$ ? Then the unfolding idea to a 2-D flat plane would fail right away. And then we would need to take the straight-forward mathematical way, i.e. using Calculus and possibly some Minimization method, or a purely numerical method using idiomatic coding of the problem statement with the suggested language items. I just couldn't figure out how nm, moving on.

Thanks again, great stuff there xzczd!!

POSTED BY: Raspi Rascal

Not really a quiz but a provocative youtube title anyway: believe in the math, not wolframalpha

$$\sqrt[3]{7+\sqrt{50}}+\sqrt[3]{7-\sqrt{50}}$$ I wasn't able to solve it with

(7 + Sqrt[50])^(1/3) + (7 - Sqrt[50])^(1/3) // Simplify

But this did the trick:

In[1]:= CubeRoot[7 + Sqrt[50]] + CubeRoot[7 - Sqrt[50]] // FullSimplify
Out[1]= 2?


You got any other solution method with Mathematica?

POSTED BY: Raspi Rascal
Posted 6 years ago

The two expressions are not equivalent. Try

(-1)^(1/3) // N
CubeRoot[-1] // N

For more information, check these posts:

POSTED BY: xzczd  

Hello Neil, thanks so much for the suggested solution, I am learning from your idea behind it, appreciated.

When i formulated the code, i.e. my very first idea of implementing the youtube problem statement in any kind of WL code form, I was not sure that the software could solve it. And indeed, it seems that Solve and NSolve cannot solve this problem when it is formulated like this, imho idiomatically. Maybe with a different coding approach, the two functions can solve it, who knows. But then i remembered Frank's method of solving an intricate set of equations .. simple use an optimization function with a pseudo objective function, taking the intricate set of equations as constraints. I find it more important nowadays to know how to solve a given non-trivial quiz/problem with a preferred software (e.g. Excel, Matlab, Raspberry Pi, Wolfram L, Maple, Python) than to solve it using the school-taught traditional brains-pencil-paper method. I'd rather invest time, brains, and efforts in finding a general coded solution than trying to solve the problem manually on a piece of paper (which i would later toss in a trash can). Both methods can be fun but imho there are more practical skills (like debugging) and experience to be acquired from setting up a working code; and it is easier to store/save/keep the code neatly (e.g. for future reference) because it is not written on a piece of scrap paper. Well, our way of keeping/collecting such code could be by posting them all in this thread haha.

@xzczd , amazing, I feel beaten :D — Thanks for the great solution showing that Solve can solve the problem but only after splitting the areas into triangles!

POSTED BY: Raspi Rascal

I quickly turn Mathematica upside down :P.

Execute this code:

r1 = Polygon[{{0, 0}, {a/2, 0}, {x, y}, {0, a/2}}];
r2 = Polygon[{{0, a/2}, {x, y}, {a/2, a}, {0, a}}];
r3 = Polygon[{{a/2, a}, {x, y}, {a, a/2}, {a, a}}];
r4 = Polygon[{{a/2, 0}, {a, 0}, {a, a/2}, {x, y}}];
eqs = {Area[r1, #] == 16, Area[r2, #] == 20, Area[r3, #] == 32, 
Area[r4, #] == a^2 - (16 + 20 + 32)} & /@ {WorkingPrecision -> 
MachinePrecision};FindMinimum[{0, eqs}, {x, y, a}]
POSTED BY: Mariusz Iwaniuk
Posted 2 years ago

I'm not sure when it's improved, but at least since v12.3.1, we no longer needs to split into triangle!:

area[pts_] := Area[Polygon[pts], Assumptions -> {0 < x < a, 0 < y < a}]

o = {0, 0}; A = {a, 0}; B = {a, a}; F = {0, a};
G = (o + F)/2; H = (o + A)/2; J = (A + B)/2; L = (F + B)/2;
K = {x, y};
a^2 - 16 - 20 - 32 /. 
 Solve@{area[{o, H, K, G}] == 16, 
        area[{G, K, L, F}] == 20, 
        area[{J, K, L, B}] == 32,
        a > 0}
(* {28} *)
POSTED BY: xzczd  
Posted 6 years ago

Seems that Area isn't strong enough, so let's help it a bit:

enter image description here

Then the analytic solution can be found easily:

area[pts_] := Area[Polygon[pts], Assumptions -> {0 < x < a, 0 < y < a}]

o = {0, 0}; A = {a, 0}; B = {a, a}; F = {0, a};
G = (o + F)/2; H = (o + A)/2; J = (A + B)/2; L = (F + B)/2;
K = {x, y};

a^2 - 16 - 20 - 32 /. Solve@{area[{o, H, K}] + area[{o, K, G}] == 16,
   area[{G, K, F}] + area[{F, L, K}] == 20,
   area[{J, K, B}] + area[{L, K, B}] == 32, a > 0}
(* {28} *)
POSTED BY: xzczd  

Oops, I see you already figured that out -- the post has been updated from the email version.

POSTED BY: Neil Singer


I did not think about whether this is the "best" way to solve the problem -- I just looked at fixing what you tried to do. The Region functions (like Area) appear to work numerically so based on that I think you need to take a numerical approach:

areacalc[xi_Real, yi_Real, ai_Real, reg_] :=  Area[reg] /. { x -> xi , y -> yi, a -> ai}

r1 = Region@Polygon[{{0., 0}, {a/2, 0}, {x, y}, {0, a/2}}];
r2 = Region@Polygon[{{0., a/2}, {x, y}, {a/2, a}, {0, a}}];
r3 = Region@Polygon[{{a/2, a}, {x, y}, {a, a/2.}, {a, a}}];
r4 = Region@Polygon[{{a/2, 0.}, {a, 0}, {a, a/2}, {x, y}}];
eqs = {areacalc[x, y, a, r1] == 16., areacalc[x, y, a, r2] == 20, 
   areacalc[x, y, a, r3] == 32, 
   areacalc[x, y, a, r4] == a^2 - (16 + 20 + 32), 11 > x > 0, 
   11 > y > 0, 11 > a > 0};

In[45]:= NMinimize[Prepend[eqs, 1], {x, y, a}]

Out[45]= {1., {x -> 2.44949, y -> 4.08248, a -> 9.79796}}

The key to making this work is "Protecting" the areacalc function from evaluating until it has numerical values for x,y,and a. This is why I used patterns such as xi_Real. The pattern match will only happen when the xi, yi, and ai get numerical values.

I hope this helps,



POSTED BY: Neil Singer
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
or Discard

Group Abstract Group Abstract