Exercise 2.4 Solutions

2.

f[x_] := (x^2) - x - 3

(a)

g[x_] := x - f[x]/D[f[x], x]

Simplify[g[x]]

(b)

FixedPointIteration[((3 + (x^2))/(-1 + 2  x)), 1.6, 0.01, 3, 
      6, {-4, 4}, {-4, 4}]

(c)

FixedPointIteration[((3 + (x^2))/(-1 + 2  x)), 0, 0.01, 4, 
      6, {-4, 4}, {-4, 4}]

5.

f[x_] := Cos[x]

(a)

x - f[x]/D[f[x], x]

(b)

FixedPointIteration[x + Cot[x], 3, 0.01, 4, 
      6, {0, 4}, {-10, 10}]

(c)

FixedPointIteration[x + Cot[x], 5, 0.01, 4, 
      6, {0, 6}, {-10, 10}]

7.

f[x_] := x(E^(-x))

(a)

x - f[x]/D[f[x], x]

(b)

FixedPointIteration[x + (1/Log)[x E], 0.2, 0.01, 4, 
      6, {-1, 6}, {-5, 5}]

(c)

FixedPointIteration[x + (1/Log)[x E], 20, 0.01, 4, 
      6, {0, 20}, {0, 25}]

11.

f[x_] := (x^3) - A

x - f[x]/D[f[x], x]

Simplify[%]

Finding the cube root of 5

FixedPointIteration[((5 + 2 (x^3))/(3 (x^2))), 5. , 0.0001, 10, 
      6, {0, 20}, {0, 25}]

Solve[(x^3) == 5, x]

N[%]

Mathematica Functions Used in this Notebook

\(\(Bisection[f0_, a0_, b0_, delta_, 
          digits_, {leftx_, rightx_}, {lowery_, uppery_}] := 
        Module[{a, b, c, Ya, Yb, Yc, f, k, cond, MaxIter, MethodDoesNotApply, 
            PerfectZero, RootInTolerance, tablelist, gr1, gr2, 
            gr3}, 
		Set @@ {f[x_], f0}; 
		a = 
            N[a0, digits]; 
		b = N[b0, digits]; 
newa = 
            a; newb = b; 
tablelist = {}; 
		k = 
            0; 
		Ya = f[a]; 
		Yb = f[b]; 
		dx = 
            b - a; 
		cond = 0; 
gr1\  = 
            Plot[f[x], {x, leftx, rightx}, 
              PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
              DisplayFunction -> Identity]; 
		MaxIter = 
            N[1 + Floor[\(Log[dx] - Log[delta]\)\/Log[2.0]]]; 
          If[Ya\ Yb > 0, cond = MethodDoesNotApply; 
            Print["Starting Points Don't Have Opposite Signs"]; 
            Break[];]; 
		While[cond == 0 && k < MaxIter, 
            c = \(a + b\)\/2; 
			Yc = f[c]; 
            tablelist = 
              Append[tablelist, {k, newa, c, newb, Yc}]; 
			gr2\  = 
              Show[Graphics[
                  Map[{PointSize[0.03], RGBColor[1, 0, 0], Point[#]} &, {{c, 
                        0}}]], DisplayFunction -> Identity]; 
            gr3 = Show[
                Graphics[
                  Map[{PointSize[0.02], Point[#]} &, {{newa, 0}, {newb, 
                        0}}]], DisplayFunction -> Identity]; 
            Show[{gr1, gr2, gr3}, DisplayFunction -> $DisplayFunction]; 
            If[Yc == 0, a = c; b = c; cond = PerfectZero]; 
            If[Yb\ Yc > 0, b = c; newb = b; Yb = Yc, a = c; newa = c; 
              Ya = Yc]; 
			dx = b - a; k = k + 1;]; 
          If[dx < delta && cond ≠ PerfectZero, 
            cond = RootInTolerance]; 
Print["Sequence of Approximations for ", f[x]]; 
Print[
            TableForm[tablelist, 
              TableHeadings -> {None, {"k", "left", "mid", "right", "yval"}}]];
];\)\)

\(FalsePosition[f0_, a0_, b0_, delta_, epsilon_, 
        digits_, {leftx_, rightx_}, {lowery_, uppery_}] := 
      Module[{a, b, c, Ya, Yb, Yc, f, k, cond, Iterating, RootInTolerance, 
          PerfectZero, MethodDoesNotApply, ptlist, nextpt, gr1, gr2, gr3, 
          gr4, gr5, gr6, gr7, newa, newb, 
          tablelist}, 
		Set @@ {f[x_], f0}; 
		a = 
          N[a0, digits]; 
		b = N[b0, digits]; 
		k = 0; newa = a; 
        newb = b; 
	
        tablelist = {}; 
		Ya = f[a]; 
		Yb = f[b]; 
		dx = 
          b - a; 
		cond = 0; 
		MaxIter = 
          100; 
		If[Ya\ Yb > 0, 
          cond = MethodDoesNotApply; 
          Print["Starting Points Don't Have Opposite Signs"]; 
          Break[];]; 
		gr1\  = 
          Plot[f[x], {x, leftx, rightx}, 
            PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
            DisplayFunction -> Identity]; 
		While[
          cond == 0 && 
            k < MaxIter, 
			dx = \(Yb\ \((b - a)\)\)\/\(Yb - Ya\); 
			c = b - dx; 
			Yc = f[c]; 
		tablelist = 
            Append[tablelist, {k, newa, c, newb, 
                Yc}]; 
			 (*\(Print["c"\_k, " = ", 
                N[c, digits], ",   |dc| ≤ ", 
                N[dx, digits]];\)*) 
			If[Yc == 0, a = c; b = c; 
            cond = PerfectZero]; 
gr3 = 
            Show[Graphics[
                Map[{PointSize[0.02], Point[#]} &, {{newa, Ya}, {newb, 
                      Yb}}]], 
              DisplayFunction -> Identity]; 
gr4 = 
            Show[Graphics[Line[{{newa, Ya}, {newb, Yb}}]], 
              DisplayFunction -> Identity]; 
If[
            Yb\ Yc > 0, b = c; newb = b; Yb = Yc, a = c; newa = a; 
            Ya = Yc]; 
	
          gr2 = Show[
              Graphics[
                Map[{PointSize[0.03], RGBColor[1, 0, 0], Point[#]} &, {{c, 
                      0}}]], DisplayFunction -> Identity]; 
          Show[{gr1, gr2, gr3, gr4}, 
            DisplayFunction -> $DisplayFunction]; 
If[
            Abs[dx] < delta && Abs[Yc] < epsilon, cond = RootInTolerance]; 
          k = k + 1;]; 
        If[cond == 0, 
          cond = Iterating]; 
		Print["Sequence of Approximations for ", f[x]]; 
Print[
          TableForm[tablelist, 
            TableHeadings -> {None, {"k", "left", "mid", "right", "yval"}}]]
]\)

NewtonRaphson[f0_, x0_, delta_, epsilon_, max_, 
        digits_, {leftx_, rightx_}, {lowery_, uppery_}, 
        graphicstoggle_:  1]:=
	Module[{f, k, small, cond, AbscissaInTolerance, 
            OrdinateInTolerance, RootInTolerance, Iterating},
		Set @@ {f[x_], f0};
		p0 = x0;
		Y0 = N[f[p0], digits];
		p1 = p0 + 1;
		k = 0;
	newp0 = p0;
	tablelist = {};
		cond = 0;
		small = N[(1/(10^20)), digits];
	gr1  = 
              Plot[f[x], {x, leftx, rightx}, 
                PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
                DisplayFunction -> Identity];
		While[cond == 0 && k < max,
			Df=N[f'[p0],digits];
			\(If[Df == 0, 
                    cond = DivByZero; 
				Dp = p1 - p0; 
				p1 = 
                      p0, 
				Dp = Y0\/Df; 
				p1 = p0 - Dp]\);
			Y1 = N[f[p1], digits];
		newp1 = p1;
gr2 = 
                    Show[Graphics[
                        Map[{PointSize[0.02], RGBColor[1, 0, 0], 
                              Point[#]} &, {{newp0, f[newp0]}, {newp1, 0}}]], 
                      DisplayFunction -> Identity];
gr3 = 
                    Show[Graphics[Line[{{newp0, f[newp0]}, {newp1, 0}}]], 
                      DisplayFunction -> Identity];
If[graphicstoggle == 1, 
                    Show[{gr1, gr2, gr3}, 
                      DisplayFunction -> $DisplayFunction]];
	tablelist = 
                    Append[tablelist, {k, newp0, newp1, Y1, 
                        Abs[newp0 - newp1]}];
			RelErr = 
                    N[Abs[Dp]/(Abs[p1] + small), digits];If[RelErr < delta, cond = AbscissaInTolerance];If[Abs[Y1] < epsilon, cond = OrdinateInTolerance];If[RelErr < delta && Abs[Y1] < epsilon, 
                    cond = RootInTolerance];p0 = p1;
			Y0 = Y1;
		newp0 = p1;
			k = k + 1;];
		If[cond == 0, cond = Iterating];Print["Sequence of Approximations for ", f[x]];
\(Print[
              TableForm[tablelist, 
                TableHeadings -> {None, {"k", "old", "new", "yval", "deltax"}}]]\);
tablelist
]

\(\(SecantMethod[f0_, x0_, x1_, delta_, epsilon_, max_, 
          digits_, {leftx_, rightx_}, {lowery_, uppery_}, 
          graphicstoggle_:  1] := 
	
        Module[{f, k, small, cond, DivByZero, AbscissaInTolerance, 
            OrdinateInTolerance, RootInTolerance, Iterating, newp0, 
            newp1}, 
		Set @@ {f[x_], f0}; 
		p0 = x0; 
		Y0 = 
            N[f[p0], digits]; 
		p1 = x1; 
		Y1 = 
            N[f[p1], digits]; 
		k = 1; 
	
          newp0 = p0; 
	newp1 = p1; 
	
          tablelist = {{newp0, Y0}, {newp1, Y1}}; 
gr1\  = 
            Plot[f[x], {x, leftx, rightx}, 
              PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
              DisplayFunction -> Identity]; 
		cond = 
            0; 
		small = N[1\/10\^20, digits]; 
	
          While[cond == 0 && 
              k < max, 

			Df = \(Y1 - Y0\)\/\(p1 - p0\); 
			If[Df == 0, cond = DivByZero; Dp = p1 - p0; p2 = p1, Dp = Y1\/Df; 
              p2 = p1 - Dp]; 
			Y2 = 
              N[f[p2], digits]; 
tablelist = 
              Append[tablelist, {p2, Y2}]; 
            gr2 = Show[
                Graphics[
                  Map[{PointSize[0.02], RGBColor[1, 0, 0], Point[#]} &, 
                    tablelist]], 
                DisplayFunction -> Identity]; 
gr3 = 
              Show[Graphics[Map[Line[#] &, addin[tablelist]]], 
                DisplayFunction -> Identity]; 
If[
              graphicstoggle == 1, 
              Show[{gr1, gr2, gr3}, 
                DisplayFunction -> $DisplayFunction]]; 

RelErr = 
              N[Abs[Dp]\/\(Abs[p2] + small\), digits]; 
            If[RelErr < delta, cond = AbscissaInTolerance]; 
            If[Abs[Y2] < epsilon, cond = OrdinateInTolerance]; 
            If[RelErr < delta && Abs[Y2] < epsilon, cond = RootInTolerance]; 
            p0 = p1; newp0 = p1; 
			Y0 = Y1; 
			p1 = p2; 
            newp1 = p2; 
			Y1 = Y2; 
			k = k + 1;]; 
		If[
            cond == 0, cond = Iterating]; 
          Print[" "]; 
		Print["Sequence of Approximations for ", 
            f[x]]; 
tablelist = 
            Transpose[
              Prepend[Transpose[tablelist], 
                  Table[m - 2, {m, 1, Length[tablelist]}]] /. \(-1\) -> 
                  0]; 
Print[
            TableForm[tablelist, 
              TableHeadings -> {None, {"Iteration", "pk", "f(pk)"}}]]
];\)\)

\(\(FixedPointIteration[g0_, X0_, tolerance_, max_, 
          digits_, {leftx_, rightx_}, {lowery_, uppery_}] := 
	
        Module[{g, k, x0, x1, relerr, plist, doubleplist, gr1, gr2, gr3, 
            gr4}, 
 (*Initial\ Values\ for\ Variables*) 
	
          Set @@ {g[x_], g0}; 
		x0 = 
            N[X0, digits]; 
	\ \ plist = {x0}; 
		k = 
            0; 
		err = 1. ; 
		relerr = 1; 
		small = 
            N[1\/10\^20, 
              digits]; 
Print[\*""Iterates (Subscript[p, k]),  "", "    Relative Error |Δp|"]; 
		Print["p"\_0, " = ", N[x0, digits]]; 
 (*Iteration*) 
		While[
            k < max && 
              tolerance ≤ 
                relerr, 
			Module[{}, 
				x1 = 
                g[x0]; 
				k = k + 1; 
				err = 
                Abs[x1 - x0]; 
				Print["p"\_k, " = ", 
                N[x1, digits], ",   |Δp| ≤ ", 
                N[err, digits]]; 
			relerr = \(2  Abs[x1 - x0]\)\/\(Abs[x1] + small\); 
				x0 = x1; 
              plist = Append[plist, x1]]]; 
		p = 
            x0; 
		Print[" "]; 
 (*Collect\ approximations\ into\ a\ list\ to\ form\ points\ for\ graphing*) 
	
          doubleplist = 
            Flatten[Transpose[{plist, plist}]]; 
	
          pts = Transpose[{Drop[doubleplist, {Length[doubleplist]}], 
                Prepend[Drop[doubleplist, 2], 
                  0]}]; 
 (*Print\ Results*) 
		Print["The function is g[x] = ", g[x]]; 
          Print["Approximation to a fixed point of g[x] is:"]; 
          Print["  p  = ", N[p, digits]]; 
          Print["g[p] at the approximated fixed point= ", 
            N[g[p], digits]]; 
          Print["|Δp| ≤ ", 
            N[err, digits]]; 
 (*Graph\ Results*) 
	
          gr1\  = Plot[g[x], {x, leftx, rightx}, 
              PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
              PlotStyle -> RGBColor[1, 0, 0], 
              DisplayFunction -> Identity]; 
		gr2\  = 
            Plot[x, {x, leftx, rightx}, 
              PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
              PlotStyle -> RGBColor[0, 1, 0], 
              DisplayFunction -> Identity]; 
	
          gr3\  = ListPlot[pts, 
              PlotRange -> {{leftx, rightx}, {lowery, uppery}}, 
              PlotStyle -> {PointSize[0.01]}, 
              DisplayFunction -> Identity]; 
	
          gr4 = Show[Graphics[Line[pts]], 
              DisplayFunction -> Identity]; 
		Show[{gr1, gr2, gr3, 
              gr4}, DisplayFunction -> $DisplayFunction];];\)\)

addin[
        lll_] := 
  
  
Module[{temp, rest, newones}, 
temp = 
          Take[lll, 2]; 
rest = 
          Drop[lll, 2]; 
newones = 
          Transpose[rest]; 
newones = 
          Append[newones, 
            Table[0, {Length[
                  newones[[1]]]}]]; 
Partition[
          Partition[
            Flatten[Prepend[
                Transpose[{newones[[1]], newones[[3]], 
                    newones[[1]], newones[[2]]}], temp]], 2], 2, 
          1]
]