Gender Dynamics at a Naturist Venue (infinite capacity) 1.0.0
Manipulate[
Module[{fDot, mDot, poly, roots, stableRoots, rStar, rIso,
endPointStar, endPointIso},(1. Define the System Dynamics)
fDot = phi1(f/m) - phi2(m/f);
mDot = mu1(f/m) - mu2(m/f);
(2. Find the Equilibrium Ratio r=f/
m)(The cubic polynomial governing the ratio evolution)
poly[r_] := -mu1r^3 + phi1r^2 + mu2r - phi2;
(Solve for positive real roots)
roots = r /. NSolve[{poly[r] == 0, r > 0}, r];
(Filter for STABLE roots where P’(r)<0)
stableRoots = Select[roots, (D[poly[x], x] /. x -> #) < 0 &];
rStar = If[Length[stableRoots] > 0, First[stableRoots], None];
(3. Define the F-Isocline (Growth Boundary))rIso = Sqrt[phi2/phi1];
(4. Geometric Helper:Find the edge intersection for a line y=k
x)(This ensures rays are always drawn across the full visible box)
getEdge[k_] := If[k <= 1, {scale, scalek}, {scale/k, scale}];
endPointIso = getEdge[rIso];
endPointStar = If[NumberQ[rStar], getEdge[rStar], {0, 0}];
(5. Generate the Plot)
Show[StreamPlot[{mu1(f/m) - mu2(m/f),
phi1(f/m) - phi2(m/f)}, {m, 0.1, scale}, {f, 0.1, scale},
StreamPoints -> density,
StreamStyle -> {Arrowheads[0.02], Thickness[0.002], GrayLevel[0.4]},
Frame -> True,
FrameLabel -> {Style[“Male Population (m)”, 12,
FontFamily -> “Helvetica”],
Style[“Female Population (f)”, 12, FontFamily -> “Helvetica”]},
LabelStyle -> {12, FontFamily -> “Helvetica”}, ImageSize -> 500,
PlotRange -> {{0, scale}, {0, scale}},
PlotRangePadding -> None],(Overlays)
Graphics[{(Shaded Region:
Female Decline (Below Isocline)){Opacity[0.15], Orange,
Polygon[{{0, 0}, {scale, 0}, endPointIso}]},(Green Dotted Line:
F-Isocline){Thickness[0.005], Dotted, Darker[Green],
Line[{{0, 0}, endPointIso}]},(Red Dashed Line:
Stable Attractor (Only if it exists))
If[NumberQ[rStar], {Thickness[0.007], Dashed, Red,
Line[{{0, 0}, endPointStar}]}, {}]}],(Legend)
PlotLegends ->
Placed[LineLegend[{Directive[Red, Dashed, Thickness[0.005]],
Directive[Darker[Green], Dotted, Thickness[0.005]],
Directive[Orange, Opacity[0.5]]}, {“Stable Attractor”,
“Growth Boundary”, “Decline Zone”}, LegendFunction -> Framed,
LegendMargins -> 5], {Right, Top}]]],(Controls*){{phi1, 4.0,
“Fem. Influx ([Phi]1)”}, 0.1, 10,
Appearance -> “Labeled”}, {{phi2, 1.0, “Fem. Exit ([Phi]2)”}, 0.1,
10, Appearance -> “Labeled”}, {{mu1, 1.0, “Male Influx ([Mu]1)”},
0.1, 10, Appearance -> “Labeled”}, {{mu2, 1.0, “Male Exit ([Mu]2)”},
0.1, 10,
Appearance -> “Labeled”}, Delimiter, {{scale, 10, “Max Population”},
10, 100, 10,
Appearance -> “Labeled”}, {{density, 20, “Streamline Density”}, 5,
40, 1, Appearance -> “Labeled”}, ControlPlacement -> Left,
TrackedSymbols :> {phi1, phi2, mu1, mu2, scale, density}]
Release Notes
This Mathematica code implements an interactive model of gender balance at naturist venues based on a mathematical model I am publishing.