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.
Associated Publications
10.5281/zenodo.18458348
This is a companion discussion topic for the original entry at https://www.comses.net/codebases/602c9bbc-b45a-423a-9d1b-0c41e476d1e3/releases/1.0.0