Complex Fun
This post is based on this wonderful answer by @Roman.
testz = Complex @@@ RandomPoint[Circle[{0, 0}, 2], 10000];
testw = I Complex @@@ RandomPoint[Circle[{2, -5}, 1], 10000];
g[{u_, v_}] := u^2 - u v - 4
p1 = (g[{Sqrt[3] - I, -4 - 2 I}] // ComplexExpand)
p2 = (g[{-Sqrt[3] - I, -4 - 2 I}] // ComplexExpand)
ComplexListPlot[{g /@ Thread[{testz, testw}], N[{p1, p2}]},
Epilog -> Circle[{0, 0}, 8],
PlotStyle -> {Automatic, PointSize[Large]}]This is the mapping of points on the two circles. The orange points are the solution.
Some more fun:
Just for Fun
This post is based on this question
p1 = f[x] + g[4 - x] == 4;
p2 = -f[x - 8] + g[x] == 8;
p3 = g[4] == 8;
p4 = g[4 - x] - g[x + 4] == 0;
p5 = p1 /. x -> 0;
Solve[{p5, p3}, {f[0], g[4]}]
p6 = p2 /. x -> x + 4
p7 = SubtractSides[SubtractSides[p1, p6], p4]
Fold[AddSides,
Table[p7 /. x -> j, {j, 6, 30, 8}]~Join~
Table[p7 /. x -> j, {j, 8, 32, 8}]]
To get the values:
f4 = Table[
f[x] /. RSolve[{p7, f[0] == -4}, f[x], x][[1]] /. x -> j, {j, 4, 32,
4}]
p8 = p1 /. x -> -2;
p9 = p2 /. x -> 6;
p10 = p4 /. x -> 2;
p11 = p7 /. x -> 2;
Reduce[{p8, p9, p10, p11}, {f[2], f[-2]}]
f2 = Table[
f[x] /. RSolve[{p7, f[2] == -2}, f[x], x][[1]] /. x -> j, {j, 2, 30,
4}]
Total[f4] + Total[f2]
Penney Full of Thoughts
This post is motivated by this question on Mathematica Stackexchange.
The code is entirely based on 138 Aspen code.
138 Aspen codes a solver for the Penney’s game.
func[pattern1_, pattern2_] := Module[
{prefixes, orderedPrefixes, transitions, selftoselfTransitions,
transitionDict, states, stateToIndex, transitionMatrix,
markovProcess, sd, edgeList, edgeLabels, g},
On[Assert];
Assert[
StringMatchQ[pattern1,
Repeated["H" | "T", {StringLength[pattern1]}]]];
Assert[
StringMatchQ[pattern2,
Repeated["H" | "T", {StringLength[pattern2]}]]];
Assert[StringLength[pattern1] == StringLength[pattern2]];
prefixes =
Union[StringTake[pattern1, #] & /@ Range[StringLength[pattern1]],
StringTake[pattern2, #] & /@ Range[StringLength[pattern2]]];
prefixes = Append[prefixes, ""];
orderedPrefixes = ReverseSortBy[prefixes, StringLength];
transitions[prefix_] :=
Module[{newH, newT, suffixH, suffixT}, newH = prefix <> "H";
newT = prefix <> "T";
suffixH = FirstCase[orderedPrefixes, _?(StringEndsQ[newH, #] &)];
suffixT = FirstCase[orderedPrefixes, _?(StringEndsQ[newT, #] &)];
{suffixH -> 1/2, suffixT -> 1/2}];
selftoselfTransitions[prefix_] := {prefix -> 1};
transitionDict =
AssociationMap[transitions, Drop[orderedPrefixes, 2]]~Join~
AssociationMap[selftoselfTransitions, Take[orderedPrefixes, 2]];
states =
Union[Keys[transitionDict],
Flatten[Keys /@ Values[transitionDict]]];
stateToIndex = AssociationThread[states -> Range[Length[states]]];
transitionMatrix =
ConstantArray[0, {Length[states], Length[states]}];
Do[Do[{transitionMatrix[[stateToIndex[state],
stateToIndex[
nextState]]] = (Association @@ transitionDict[state])[
nextState];}, {nextState,
Keys[transitionDict[state]]}], {state, Keys[transitionDict]}];
markovProcess = DiscreteMarkovProcess[1, transitionMatrix];
sd = Column[{StationaryDistribution@markovProcess,
stateToIndex}];
Needs["GraphUtilities`"];
edgeList =
Flatten[KeyValueMap[
Function[{key, val}, key \[DirectedEdge] # & /@ Keys[val]],
transitionDict]];
edgeLabels =
Flatten[KeyValueMap[
Function[{key, val},
Thread[(key \[DirectedEdge] # & /@ Keys[val]) -> Values[val]]],
transitionDict]];
g = Graph[edgeList, VertexLabels -> Placed["Name", Center],
EdgeLabels -> edgeLabels, DirectedEdges -> True,
VertexSize -> 0.4, ImageSize -> Medium];
Column[{sd, g}]]Applying the function to all the possible first player choices (and the optimal second player choices) reproduces the results in the Wikipedia entry.
Triangles and Parabolas
This post is motivated by this question on Mathematica Stackexchange.
cp = CirclePoints[3];
func[a_, b_] := Module[{v = b - a, m, xp},
m = #2/#1 & @@ v;
xp = y - a[[2]] - m (x - a[[1]]) // Expand;
x^2 + y^2 - xp^2/(m^2 + 1) // Expand]
pl1 = ContourPlot[
Evaluate@
Thread[(fs = func @@@ Partition[cp, 2, 1, 1]) == 0], {x, -1,
1}, {y, -1, 1},
Epilog -> {Red, Circle[], FaceForm[None], EdgeForm[Blue],
Triangle[cp], PointSize[0.02], Point[{{0, 0}}~Join~cp]}];
pl2 = RegionPlot[(And @@ Thread[fs <= 0] && x^2 + y^2 <= 1), {x, -1,
1}, {y, -1, 1}];
ir = ImplicitRegion[(And @@ Thread[fs <= 0] &&
x^2 + y^2 <= 1), {{x, -1, 1}, {y, -1, 1}}];
a1 = RegionMeasure[ir] // FullSimplify
a2 = RegionMeasure[Triangle[cp]]
a1/a2
Show[pl1, pl2]
The code uses side of triangle as directrix and centre as focus. Thereafter region functionality is used.
Around the Twist
This post is motivated by Hopf fibration.
I used the following stereographic projection:
s3[a_, s_, t_] := {Cos[(a + s)/2] Sin[t/2], Sin[(a + s)/2] Sin[t/2],
Cos[(a - s)/2] Cos[t/2], Sin[(a - s)/2] Cos[t/2]}
sproj[a_, {s_, t_}] :=
Module[{w = s3[a, s, t]}, w[[{1, 2, 3}]]/(1 - w[[4]])]
My preliminary visualizations (the animated gif still needs work):
String Around A Circle
This post is just a placeholder:
arc[t_] := {Sin[t], 1 - Cos[t]}
line[s_] :=
Module[{r},
r = t /.
Quiet@Solve[{Norm[t {Cos[s], Sin[s]}]} == 2 Pi - s && t > 0,
t][[1]];
{Red, Circle[{0, 1}, 1], Black,
Circle[{0, 1}, 1, {3 Pi/2, 3 Pi/2 + s}],
Line[{arc[s], arc[s] + r {Cos[s], Sin[s]}}]}]
The above was unnecessarily complex. Motivated by this question:
func[r_, a_, d_] :=
If[d <= r a, r {Sin[d/r], -Cos[d/r]},
r {Sin[a], -Cos[a]} + (d - r a) {Cos[a], Sin[a]}]
Using some points from the post:
pts = {{1.7320508075688772`, 0.`}, {3.4641016151377544`,
0.`}, {5.196152422706632`, 0.`}, {6.928203230275509`, 0.`}};
ds = Norm[# - pts[[1]]] & /@ pts;
rd = ds[[-1]]/(2 Pi);
cntr = {pts[[1, 1]], rd};
Manipulate[
ParametricPlot[cntr + func[rd, q, x], {x, 0, 2 Pi rd},
Epilog -> {Circle[cntr, rd], Red,
Point[Table[cntr + func[rd, q, j], {j, ds}]]},
PlotRange -> {{-4, 7}, {-2, 7}}], {q, 0, 2 Pi - 0.1}]
Wrapping points around circle:
Stretching Soap Film
I recently enjoyed When Least is Best by Paul Nahin, This post is exploration of stretching soap film between 2 equal circular rings below the Goldschmidt limit. This YouTube video by Matt Parker is a wonderful exposition.
This was modeled using minimal surface of revolution of 
The Sun was on the Right
I came across a Joy of X podcast serendipitously ( 10 March 2020: Special Kind of Magic). I am new to listening to podcasts and this was a joyful experience. This post is motivated by Herodotus Histories 4.42 that was referred to in the podcast.
The seemingly innocuous retelling of the observation was so powerful.
The following photograph is of my backyard with geographic directions superimposed. If walk from East to West the sun is on my right.
The primary and secondary rainbow are just because I like rainbows. The picture shows a number of features: sequence of colours in primary versus secondary, light and dark areas, the time of day and direction reflect the ~~42 degrees.
Reed Solomon
This post is motivated by this nice video of vcubingx. of explaining the Reed Solomon error correcting code.
You can implement this in Wolfram Language:
p = PolynomialMod[
Expand[InterpolatingPolynomial[w = {{0, 2}, {1, 4}, {2, 3}, {3, 1}},
x]], 5];
rs = Thread[{Range[0, 5], Mod[p, 5] /. {x -> Range[0, 5]}}];This yields the code: {{0, 2}, {1, 4}, {2, 3}, {3, 1}, {4, 0}, {5, 2}};
Illustrating the effect of loss of 2 packets:
{SortBy[#, First],
PolynomialMod[InterpolatingPolynomial[#, x], 5]} & /@
Subsets[rs, {4}] // Grid[#, Frame -> All] & 
Morning Walk
We have been taking our granddaughter to and from daycare, It has been beneficial exercise in addition to grandparental joy.
This post is an exercise in importing gpx file from Runkeeper.com into Wolfram Language, for one of the journeys to and from the day care.
I like the wonderful symmetry in the altitude plot to and from.
Unknown Blogger Mathematica 