Skip to main content

plotting - Create a slider to illustrate Fubini theorem


I would like to illustrate the Fubini theorem in Calculus like the following picture (taken from this page):



enter image description here


This is what I tried:


a := 1;
B4 := ParametricPlot3D[{a, y, z}, {y, 
   3 + (-8 + a)* (1/13 + (0.01 + 0.0022*(-4 + a))*(5 + a)), 
   4.8 + Sin[a]}, {z, 0, 0.01*(a + 5)^2}, PlotPoints -> 100, 
  Mesh -> 20, 
  PlotStyle -> 
   Directive[Blue, Opacity[0.4], 
    Specularity[White, 30]]];(*The blue plane*)


B1 := 
 ParametricPlot3D[{x, y, 0.01*(x + 5)^2}, {x, -5, 8}, {y, 
   3 + (-8 + x) (1/13 + (0.01 + 0.0022*(-4 + x))*(5 + x)), 
   4.8 + Sin[x]}, Mesh -> 20, PlotStyle -> Opacity[0], 
  MeshStyle -> Opacity[.8], 
  PlotStyle -> 
   Directive[Blue, Opacity[0.3], Specularity[White, 30]]];

B2 := ParametricPlot3D[{x, 

    3 + (-8 + x) (1/13 + (0.01 + 0.0022*(-4 + x))*(5 + x)), 
    z}, {x, -5, 8}, {z, 0, 0.01*(x + 5)^2}, PlotPoints -> 100, 
   Mesh -> 20, MeshStyle -> Opacity[.1], 
   PlotStyle -> 
    Directive[Green, Opacity[0.3], Specularity[White, 30]]];

B3 := ParametricPlot3D[{x, 4.8 + Sin[x], z}, {x, -5, 8}, {z, 0, 
    0.01*(x + 5)^2}, PlotPoints -> 100, Mesh -> 20, 
   MeshStyle -> Opacity[.1], 
   PlotStyle -> 

    Directive[Red, Opacity[0.4], Specularity[White, 30]]];


Show[B1, B2, B3, B4, AxesStyle -> Thick, Boxed -> False, 
 AxesOrigin -> {0, 0, 0}, AxesLabel -> {x, y, z}, 
 BoxRatios -> {1, 1, 1.3}]

enter image description here


Now, I don't know how to create a slider to adjust the value of $a$ running from -5 to 8, so that we will have the same illustration. I also would like to put two figures side by side as seen from the picture above.


Could anyone give me a help! Thanks alot.




Answer



enter image description here


If it is not essential to have two different colors for the filling in the 3D plot, you can use a single Plot3D with the option Filling to get the 3D surface.


ClearAll[f1, f2, f3, polygon, arrow]
f1[x_] := 4.8 + Sin[x]
f2[x_] := 3 + (-8 + x) (1/13 + (0.01 + 0.0022*(-4 + x))*(5 + x))
f3[x_] := 0.01*(x + 5)^2

polygon[a_] := Graphics3D[{EdgeForm[{Thick, Blue}], Opacity[.5, Blue], 
   Polygon[{{a, f1[a], 0}, {a, f1[a], f3[a]}, {a, f2[a], f3[a]}, {a, f2[a], 0}}]}]


arrow[a_] := Graphics[{Thick, Blue, Arrowheads[Medium], Arrow[{a, #[a]} & /@ {f2, f1}]}]

pp = ParametricPlot[{x, v f1[x] + (1 - v) f2[x]}, {x, -5, 5}, {v, 0, 1}, 
   Mesh -> None, PlotStyle -> Opacity[.5, LightGray], 
   PlotPoints -> 30, Frame -> False, AxesOrigin -> {-6, 3/2}, 
   Ticks -> {{{-5, "a"}, {5, "b"}}, None}, AspectRatio -> 1, 
   AxesLabel -> {"x", "y"}, BoundaryStyle -> Directive[Thick, Gray], 
   ImageSize -> Medium];


bottom = ParametricPlot3D[{x, v f1[x] + (1 - v) f2[x], 0}, {x, -5, 5}, {v, 0, 1}, 
   Mesh -> None, PlotStyle -> None, PlotPoints -> 30, 
   Boxed -> False, BoxRatios -> 1, 
   BoundaryStyle -> Directive[AbsoluteThickness[3], Darker@Gray]];

p3d = Plot3D[f3[x], {x, -5, 5}, {y, 2, 6}, 
   PlotStyle -> FaceForm[Opacity[.5, White], Opacity[0]], 
   BoundaryStyle -> Directive[Thick, Red], 
   Mesh -> 20, MeshStyle -> Red, 
   Lighting -> "Neutral", Filling -> Bottom, 

   FillingStyle -> FaceForm[Opacity[.5, Red], Opacity[.3, White]], 
   PlotPoints -> 25, RegionFunction -> (f2[#] <= #2 <= f1[#] &), 
   BoxRatios -> {1, 1, 1}, ViewPoint -> {-2.7, 1.6, 1.3}, ImageSize -> Medium];

Manipulate[Row[{Show[pp, arrow[t]], Show[p3d, bottom, polygon[t]]}, Spacer[10]],
   {{t, 1}, -5, 5, 1/50}]

enter image description here


The animation above is generated using:


frames = Table[Row[{Show[pp, arrow[t]], Show[p3d, bottom, polygon[t]]}, 

    Spacer[10]], {t, -5, 5, 1/5}];

Export["fubini2.gif", frames, "AnimationRepetitions" -> Infinity]

An alternative approach is to use a Locator (instead of a Slider) to control the parameter a:


Deploy @ DynamicModule[{p = {1, f2[1]}}, 
  Row[{Show[pp, 
        Graphics[{Thick, Blue, Arrowheads[Medium], 
         Dynamic @ Arrow[{p[[1]], #[p[[1]]]} & /@ {f2, f1}], 
         Locator[Dynamic[p, (p = #; p[[2]] = f2[p[[1]]]) &], 

            Graphics[{Black, Rectangle[]}, ImageSize -> 10]]}], PlotRange -> All], 
   Dynamic@Show[p3d, bottom, polygon[p[[1]]]]}, Spacer[10]]]

enter image description here


Comments

Post a Comment

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more