# Need an equation for modeling Tytler's Cycle

In all cultures over all time there appears, in different languages for different countries, the maxim "Shirtsleeves to shirtsleeves in three generations." This is a function with three phases exhibiting first growth then maintenance, then dissipation. The patriarch gets off the boat penniless, builds a comfortable life, leaves it to his son who manages to hold onto it until he then leaves it to his son who spends it. The society-wide equivalent for nation states is known as "Tytler's Cycle."

Assume a Phase I accumulation rate of Exp[a r t] where "r" is a rate we will fix at 9% for now, "t" is time and "a" is a damper or weariness factor which declines over time. Phase I plots like this

Plot[Evaluate@Table[E^(a .09 t), {a, {.99, .7, .55}}], {t, 1, 50},
Frame -> {True, True, False, False},
FrameLabel -> {"Time (t)", "Accumulation"},
PlotStyle -> {Blue, Green, Red},
PlotLabel ->  "production = \!$$\*SuperscriptBox[\(\[ExponentialE]$$, $$a\\\ \.09, t$$]\)",
PlotLegends -> {"a = .99", "a = .70", "a = .55"}]


displaying three sub phases of decline in "a" as Dad ages and tires. We will return to connecting phases I and III, later.

The dissipation phase is also exponential with the accumulated capital, "C", being eroded as C Exp[-(1/a) .09 t] where "C" is a constant representing the capital accumulated in Phase I and "a" is now the rate of profligacy and indolence. Three possible profiles plot thus:

Plot[Evaluate@Table[100 E^(- (1/a) .09 t), {a, {.50, .35, .15}}], {t,  6, 20},
Frame -> {True, True, False, False},
FrameLabel -> {"Time (t)", "Accumulation"},
PlotStyle -> {Blue, Green, Red},
PlotLabel ->  "production = 700 \!$$\*SuperscriptBox[\(\[ExponentialE]$$, \$$\(-\*FractionBox[\(1$$, $$a$$]\)\\\  .09, t\)]\)",
PlotLegends -> {"a = .50", "a = .35", "a = .15"}]


Rather than have this process look like the side view of a volcanic mountain, Phase II needs rounded corners to make the function everywhere differentiable. We assume little or no growth in Phase II so the length of time is not so important.

Here is a preview using a numerical method

seg1 = MapThread[(E^(#1 .09 #2)) &, {Table[i, {i, .99, .51, -.02}], Range[25]}];
seg2 = ConstantArray[E^(.51 .09 25), 10];
ListLinePlot[Join[seg1, seg2, Reverse[seg1]]]


Interpolation will make it into a function. But to have an interactive Manipulate where all the variables can be changed, it seems to me that the the most general approach might be a differential equation using WhenEvent for the tipping point when the functional form of "a" changes sometime near the end of Phases II. I have struggled to make that work and so far have only been able to construct the separate pieces.

Help collecting the parts into a cohesive whole will be appreciated.

The Logistic Equation is used as a model of population growth, but it may be useful for your simulation. This single equation can simulate dad as he ages and tires, and the decline in the third stage.

Here's a modified version of the equation that allows for delayed starting time offset, where c, r, and x0 are parameters that define the curve shape, and t0 is the time offset. The c parameter represents the accumulated capital, which is set to 10 in the following graphs.

logeq[c_, r_, x0_, t0_] := c/(1 + (1/x0 - 1) Exp[-r (t - t0)])


Here are examples of three growth and decay curves which depend on r0.

Plot[{Table[logeq[10, r0, .01, 0], {r0, {.35, .5, .8}}], 10}, {t, 0, 30},
PlotLabels -> {"", "c = 10"}]


Plot[{Table[logeq[10, r0, .995, 40], {r0, {-.35, -.5, -.8}}], 10}, {t, 40, 70},
PlotLabels -> {"", "c = 10"}]


As an example, we can use a Piecewise function definition to simulate a rapid rise during generation 1 and slow decline during generation 3.

Plot[
Piecewise[{
{logeq[10, .5,.011, 0], t < 20}, (* generation 1 *)
{10, 20 < t < 40}, (* generation 2 *)
{logeq[10, -.3, .997, 40], t > 40}}], (* generation 3 *)
{t, 0, 75}]