Inverse image function

11 January 2014

This Mathematica notebook is licensed under a MouseOver .
It provides software for producing the inverse image of an interval under a particular function. This notebook is discussed at the blog post Inverse Image Demo Revisited. I hope anyone interested will feel free to improve this work and to use it in their own publications and coursework.

Initial definitions

setup[f_,a_,b_,x_]:=Reduce[(f[x]≥a)&&(f[x]≤b),x,Reals]//Quiet(*Find interval(s)that make up inverse image.*)

mint[{x_,y_}]:={{x,0},{y,0}}  (*Produces input for ListLinePlot in the Main function showinvimg.  It makes the inverse image appear on the x-axis.*)

The Main function

showinvimg[f_,xl0_,xr0_,astart0_,bstart0_,step0_,yb0_,yt0_,ar0_,vthick0_:0.01,ycolor0_:RGBColor[.7,.2,0],xcolor0_:RGBColor[.2,.6,0]]:=
Module[{xl=xl0,xr=xr0,astart=astart0,bstart=bstart0,step=step0,yb=yb0,yt=yt0,,ar=ar0,vthick=vthick0,ycolor=ycolor0,xcolor=xcolor0},
Manipulate[
Show[
(*Plot function*)
Plot[
f[x],{x,xl,xr},PlotStyle->{Blue},PlotRange->{yb,yt},AspectRatio->ar
],
(*Plot output interval -- the interval you want to produce the inverse image of -- on the y-axis*)
If[a<b, (*Don't try to draw reversed intervals*)
ListLinePlot[
{{0,a},{0,b}},PlotStyle->{{ycolor,Thickness[vthick]}}
],
Plot[{},{x,xl,xr} ] (*Kludge necessary because "If" would produce "Null" here and Show[null] gives an error messages.*)
],
(*Show inverse image of output interval on the x-axis*)
If[a<b,
ListLinePlot[
If[Depth[setup[f,a,b,x]]<3, 
(*If Depth < 3, the setup function shows a single inequality, not as a list, so I have to put parentheses around it. If it is ≥3, it shows a list of inequalities so the outer parentheses are already there*)
{mint @{setup[f,a,b,x][[1]],setup[f,a,b,x][[-1]]}},mint @{setup[f,a,b,x][[#]][[1]],setup[f,a,b,x][[#]][[-1]]}&/@
Table[
i,{i,Length[setup[f,a,b,x]]}]
],
PlotStyle->{{xcolor,Thickness[vthick]}}],
Plot[{},{x,xl,xr}]
]
],
{{a,astart},yb,yt,step,Appearance->{"Labeled","Open"}},{{b,bstart},yb,yt,step,Appearance->{"Labeled","Open"}},SaveDefinitions->True]
]

Examples

cu[x_]:=x^3-x

showinvimg[cu,-1.7,1.7,-1.0,1.0,.05,-1.7,1.7,1.0,0.01]

Parabola

qu[x_]:=x^2-1

showinvimg[qu,-1.8,1.8,-0.5,1.2,.05,-1.05,2.25,3.6/3.3]

Quartic

qf[x_]:=x (.75x-1) (x-2) (1.1x+1)

showinvimg[qf,-1.1,2.2,-.3,.75,.05,-1,1,4/8.4]

Quintic

ff[x_]:=-.5+.5x+.2x^2-.19x^3-.015x^4+.01x^5

Manipulate[setup[ff,a,b,x],{{a,-1},-2,2,.05,Appearance->{"Labeled","Open"}},{{b,1},-2,2,.05,Appearance->{"Labeled","Open"}}]

Manipulate[setup[ff,a,b,x]//TreeForm,{{a,-1},-2,2,.05,Appearance->{"Labeled","Open"}},{{b,1},-2,2,.05,Appearance->{"Labeled","Open"}}]

showinvimg[ff,-4.1,4.3,-1.4,1,.05,-2,2,4/8.4]

Rational function

rf[x_]:=1.5(x^4-1)/(x^4+1)+.5x

rf[x]

rf[x]//TeXForm

Plot[rf[x],{x,-4,4}]

showinvimg[rf,-4,4,0,2,.05,-2,3.5,2/3]

Straight line with variable slope

Module[{m},
Manipulate[
showinvimg[m#&,-4,4,-1,2,.05,-4,4,1],{{m,1,"slope"},-4,4,Appearance->{"Labeled","Open"}},SaveDefinitions->True
]
]

Sine

I did this function using piecewise functions because the answer produced by Reduce wouldn’t work inside showinvimg.  I would bet that someone cleverer could make it work, because it worked for the other functions in this notebook that have multivalued inverses.

Reduce[y==Sin[x]&&-Pi≤x≤Pi,{x}]

ispL[t_]:=Piecewise[{{-Pi-ArcSin[t],-1≤t<0}},-4](*The value -4 is a kludge to stop the value from being shown on the graph when it is out of range. There is presumably a more elegant way to do this.*)

ispM[t_]:=Piecewise[{{ArcSin[t],-1≤t≤1}},4]

ispR[t_]:=Piecewise[{{Pi-ArcSin[t],0<t≤1}},4]

Manipulate[
Plot[If[a<b,
{ispL[t],ispM[t],ispR[t]}],{t,a,b},PlotStyle->Blue,PlotRange->{{-1,1},{-Pi,Pi}},AspectRatio->Pi],{{a,-.3},-1,1,Appearance->{"Labeled","Open"}},{{b,.4},-1,1,Appearance->{"Labeled","Open"}}]

Manipulate[
If[a<b,ispL[t],{t,5}],
{{t,-.2},-1,1,Appearance->{"Labeled","Open"}},
{{a,-.5},-1,1,Appearance->{"Labeled","Open"}},{{b,.7},-1,1,Appearance->{"Labeled","Open"}}]

Manipulate[
Show[
ParametricPlot [
If[a<b,{{ispL[t],.3},{ispM[t],.2},{ispR[t],.4}},{t,5}],
{t,a,b},PlotStyle->Thickness[.015],PlotRange->{{-Pi,Pi},{-1,1}},AspectRatio->1/Pi]],{{a,-.5},-1,1,Appearance->{"Labeled","Open"}},{{b,.7},-1,1,Appearance->{"Labeled","Open"}}]

Manipulate[
Show[
(*Plot function*)
Plot[
Sin[x],{x,-Pi,Pi},PlotStyle->{Blue},PlotRange->{-1,1},AspectRatio->1/Pi
],
(*Plot output interval*)
If[a<b, (*Don't draw reversed intervals*)
ListLinePlot[
{{0,a},{0,b}},PlotStyle->{{RGBColor[.7,.2,0],Thickness[.01]}}
],
Plot[{},{x,-Pi,Pi} ] (*Kludge necessary because "If" would produce "Null" here and Show[null] gives an error messages.*)
],
(*Show inverse image of output interval*)
If[a<b,
ParametricPlot [
If[a<b,{{ispL[t],0},{ispM[t],0},{ispR[t],.0}},{t,5}],
{t,a,b},PlotStyle->{Thickness[.01],RGBColor[.2,.6,0]},PlotRange->{{-Pi,Pi},{-1,1}},AspectRatio->Pi],Plot[{},{x,-Pi,Pi} ]]
],
{{a,-.5},-1,1,.05,Appearance->{"Labeled","Open"}},{{b,.6},-1,1,.05,Appearance->{"Labeled","Open"}},SaveDefinitions->True]

Experiment

Draw lines connecting input to output.  Will be done later.

siic[f_,xl0_,xr0_,astart0_,bstart0_,step0_,yb0_,yt0_,ar0_,vthick0_:0.01,ycolor0_:RGBColor[.7,.2,0],xcolor0_:RGBColor[.2,.6,0]]:=
Module[{xl=xl0,xr=xr0,astart=astart0,bstart=bstart0,step=step0,yb=yb0,yt=yt0,,ar=ar0,vthick=vthick0,ycolor=ycolor0,xcolor=xcolor0},
Manipulate[
Show[
(*Plot function*)
Plot[
f[x],{x,xl,xr},PlotStyle->{Blue},PlotRange->{yb,yt},AspectRatio->ar
],
(*Plot output interval -- the interval you want to produce the inverse image of -- on the y-axis*)
If[a<b, (*Don't try to draw reversed intervals*)
ListLinePlot[
{{0,a},{0,b}},PlotStyle->{{ycolor,Thickness[vthick]}}
],
Plot[{},{x,xl,xr} ] (*Kludge necessary because "If" would produce "Null" here and Show[null] gives an error messages.*)
],
(*Show inverse image of output interval on the x-axis*)
If[a<b,
ListLinePlot[
If[Depth[setup[f,a,b,x]]<3, 
(*If Depth < 3, the setup function shows a single inequality, not as a list, so I have to put parentheses around it. If it is ≥3, it shows a list of inequalities so the outer parentheses are already there*)
{mint @{setup[f,a,b,x][[1]],setup[f,a,b,x][[-1]]}},mint @{setup[f,a,b,x][[#]][[1]],setup[f,a,b,x][[#]][[-1]]}&/@
Table[
i,{i,Length[setup[f,a,b,x]]}]
],
PlotStyle->{{xcolor,Thickness[vthick]}}],
Plot[{},{x,xl,xr}]
]
],
{{a,astart},yb,yt,step,Appearance->{"Labeled","Open"}},{{b,bstart},yb,yt,step,Appearance->{"Labeled","Open"}},SaveDefinitions->True]
]