User karl fabian - MathOverflow

Answer by Karl Fabian for Another colored balls puzzle (part II)

2013-05-15T11:49:29Z

For given $n$ it is possible to calculate the expected number of turns from an absorbing Markov chain on the integer partitions of $n$.

Each state of the Markov process corresponds to the ordered list of the number of equally colored balls. The matrix of transition probabilities between the states is easily calculated according to rules 1 or 2,

e.g. Removing from position 1, adding to position 2 : {3,1,1} -> {2,2,1}
with probability p = P(choosing position 1 out of all balls) * P(choosing position 2 out of remaining balls) =3/5 * 1/2

Given the transition matrix with the unique absorbing state {n} and the initial state {1,1,1,...,1} it is possible to calculate the expected number of turns before absorption.

This is done in the Mathematica program below. Here some results where the first number is n, the second the numerical result, and the third the exact fraction:

Rule 1

{{2, 1., 1}, 

{3, 4., 4}, 

{4, 10.3333, 31/3}, 

{5, 22.4852, 16729/744}, 

{6, 45.2173, 33913/750},

{7, 87.7733, 26707139046097/304274018880}, 

{8, 168.252, 129857255359868261/771803525388385},

{9, 322.292, 4555917617310039296830835441635/14135986803865219963776139264}, 

{10,620.346,822838635777324535445878391148603051494611/1326419190860455039655669536523314862820}}

Only the numerical values for n>10:

{{11, 1202.04}, {12, 2344.58}, {13, 4599.07}, {14, 9062.01},

{15, 17916.8}, {16, 35513.4},{17, 70522.1}, {18, 140231.},{19, 279122.}, {20, 555989.}}

Rule 2

{{2, 1., 1}, 

{3, 2.5, 5/2}, 

{4, 4.41667, 53/12}, 

{5, 6.6994, 2251/336}, 

{6, 9.31157, 866023/93005}, 

{7, 12.2249, 1009285097/82560060},

{8, 15.4166, 2246993235815929/145751872750176}, 

{9, 18.868, 2285085765293281062003190373/121108796080566797904702840}, 

{10, 22.5637, 618224636000595187350171250435705332105433100763641/27399140168645771065204844597274355963355735154297}}

Only the numerical values for n>10:

{{11, 26.4901}, {12, 30.6358}, {13, 34.9907}, {14, 39.546}, {15, 44.2936}, {16, 49.2266}, {17, 54.3383}, {18, 59.6231}, {19, 65.0754}, {20, 70.6904}}

Program:

(*
Defining Rule 1:
  input : lst = Partition of n , e.g. {5,3,2,1} with n=11
        k, m :  Positions to be changed ; remove ball from position k and add to position m
 output : list containing changed partition and probability for this change

 E.g. PartMove[{5, 3, 2, 1}, 1, 3] -> {{4, 3, 3, 1}, 5/33}
*)
PartMove[lst_, k_, m_] :=
 Module[{ll = lst, len = Plus @@ lst, prob},
  prob = (ll[[k]]/len*ll[[m]]/(len - ll[[k]]));
  ll[[k]] -= 1; ll[[m]] += 1;
  If[ll[[k]] == 0, ll = Drop[ll, {k}]]; {Reverse[Sort[ll]], prob}]

(*Alternatively
Defining Rule 2:
  input : lst = Partition of n , e.g. {5,3,2,1} with n=11
        k, m :  Positions to be changed ; add ball to position k and remove from  position m
 output : list containing changed partition and probability for this change

 E.g. PartMove[{5, 3, 2, 1}, 1, 3] ->   {{6, 3, 1, 1}, 5/33}
*)
 PartMove[lst_, k_, m_] :=
 Module[{ll = lst, len = Plus @@ lst, prob},
  prob = (ll[[k]]/len*ll[[m]]/(len - ll[[k]]));
  ll[[k]] += 1; ll[[m]] -= 1;
  If[ll[[m]] == 0, ll = Drop[ll, {m}]]; {Reverse[Sort[ll]], prob}]

  (*
Calculate all possible target partitions for a given partition with respective probabilities:
  input : lst = Partition of n , e.g. {5,3,2,1} with n=11

  output : list containing all possible changed partitions with their  probabilities
 Note: Depends on the chosen rule via PartMove

 E.g. for rule 1:
 Targets[{2, 1, 1}] -> {{{2, 2}, 1/6}, {{3, 1}, 1/3}, {{2, 1, 1}, 1/2}}
*)
  Targets[lst_] := Module[{len = Length[lst], pairs, res},
  If[len <= 1, {{lst, 1}},
   pairs = Select[Tuples[Range[len], 2], #[[1]] != #[[2]] &];
   res = Sort[PartMove[lst, #[[1]], #[[2]]] & /@ pairs];
    {#[[1, 1]], Plus @@ (#[[2]] & /@ #)} & /@ SplitBy[res, First]]]

(*  Define all possible states for chosen n (here n=4) *)

states = IntegerPartitions[4];

(* Define transition matrix PM for Markov chain *)
nn = Length[states];
Clear[PartIndex]; n = 1; (PartIndex[#] = n++) & /@ states;
PM = Table[0, {nn}, {nn}];
Do[(PM[[PartIndex[#[[1]]], k]] = #[[2]]) & /@
  Targets[states[[k]]], {k, 1, nn}]

(* Define submatrix Q for transient state changes *)
Q = (Drop[#, 1] & /@ Drop[PM, 1]);
(* Calculate fundamental matrix NPM of absorbing Markov chain*)
NPM = Inverse[ IdentityMatrix[Length[Q]] - Q];
(*Calculate expected number t of turns when starting from {1,1,..,1} = states[[-1]] *)
t = Plus @@ (#[[-1]] & /@ NPM);
{N[t], t} (*numerical and exact value of t*)

Answer by Karl Fabian for Non-rigorous reasoning in rigorous mathematics

2012-12-04T16:01:57Z

Every geometric problem that has a two-dimensional representation is solved by almost every mathematician by first drawing a diagram, then deriving the correct formal description from this diagram, and then continuing to solve the problem in the algebraic description.

These certainly are ubiquitous "situations in which there is a heuristic argument which is valid and can be formalized."

Also the heuristic argument is "separate (or complementary)" to the "rigorous argument, but the heuristic argument is more enlightening and more explanatory."

Answer by Karl Fabian for Does every ellipse inside a tetrahedron inside a ball fit in a triangle inside the ball?

2012-10-02T14:16:55Z

Here is a bit of Mathematica code that rather supports Joseph's conclusion.

Tet[phi_] := {{Sin[phi], 0, Cos[phi]}, {-Sin[phi], 0, Cos[phi]}, {0, Sin[phi], -Cos[phi]}, {0, -Sin[phi], -Cos[phi]}};

Rect[a_, phi_] := Module[{x, y, u, w}, {x, y, u, w} = Tet[phi]; Polygon[{a x + (1 - a) u, a x + (1 - a) w, a y + (1 - a) w, a y + (1 - a) u}]];

v = Subsets[Range[4], {3}];

Manipulate[ Graphics3D[{Opacity[0.2], Sphere[{0, 0, 0}, 1], Opacity[0.3], GraphicsComplex[Tet[phi], Polygon[v]], Opacity[0.8], Rect[a, phi]}], {phi, 0, Pi/2}, {a, 0, 1}]

Using parameters like a=0.9, phi=1.4 one obtains an elongated rectangle inscribed a flat tetrahedron, close to an equatorial plane. The maximal inscribed ellipse in this rectangle hardly is contained in any triangle that fits in the unit ball.

Edit (2):

The following improved version uses an analytic solution for tetrahedra $ABCD$ with $[AB]$ perpendicular to $[CD]$, and the maximal ellipse $E$ in a plane cutting $ABCD$ parallel to $[AB]$ and $[CD]$. In this case the maximal distance of the vertices of the smallest enclosing triangle $T'$ from the origin is

$1 - 2 (1 - a) a (1 + \cos(\phi - \psi))\leq 1$ for $0 < a < 1 $,

where $A=(\sin \phi, 0, \cos\phi)$, , $B=(-\sin \phi, 0, \cos\phi)$ , $C=(0, \sin \psi, -\cos\psi)$, $D=(0, - \sin \psi, -\cos\psi)$. Thus in all these cases the triangle $T'$ lies inside $B$.

I even think that all other (nontrivial) cases of $E\subset T$ can be reduced to one of the above cases by aligning two edges of the enclosing tetrahedron $T$ to lie along the principal axes of $E$, while keeping $E$ inside. But this I cannot prove yet.

Code:

Tet[phi_, psi_] := {{Sin[phi], 0, Cos[phi]}, {-Sin[phi], 0, Cos[phi]}, {0, Sin[psi], -Cos[psi]}, {0, -Sin[psi], -Cos[psi]}}; Rect[a_, phi_, psi_] := Module[{x, y, u, w}, {x, y, u, w} = Tet[phi, psi]; Polygon[{a x + (1 - a) u, a x + (1 - a) w, a y + (1 - a) w, a y + (1 - a) u}]]; v = Subsets[Range[4], {3}]; ParPl[a_, phi_, psi_] := ParametricPlot3D[{a Sin[phi] Cos[t], -(-1 + a) Sin[psi] Sin[t], a Cos[phi] + (-1 + a) Cos[psi]}, {t, 0, 2 Pi}, Boxed -> False, Axes -> False]; Tangent[a_, phi_, psi_, t_, lam_] := {a Sin[phi] Cos[t], -(-1 + a) Sin[psi] Sin[t], a Cos[phi] + (-1 + a) Cos[psi]} + lam {-a Sin[phi] Sin[t], (1 - a) Cos[t] Sin[psi], 0};

Manipulate[ bt = 2 ArcTan[ 1 - (a Csc[psi] Sin[phi])/(-1 + a) - Sqrt[( a Csc[psi] Sin[phi] (2 - 2 a + a Csc[psi] Sin[phi]))/(-1 + a)^2]]; p1 = Tangent[a, phi, psi, bt, Cot[bt]]; p2 = Tangent[a, phi, psi, bt, -Sec[bt] - Tan[bt]]; p3 = {-1, 1, 1}*p2; Show[Graphics3D[{Opacity[0.2], Sphere[{0, 0, 0}, 1], Opacity[0.3], GraphicsComplex[Tet[phi, psi], Polygon[v]], Opacity[0.8], Rect[a, phi, psi], Green, Polygon[{p1, p2, p3}]}], ParPl[a, phi, psi]], {{phi, Pi/4}, 0, Pi/2}, {{psi, Pi/4}, 0, Pi}, {{a, 0.7}, 0, 1}]

Answer by Karl Fabian for Area of union of random circles in a plane

2012-09-03T22:29:22Z

The question is already interesting for general $r$ when $S=[0,1]$. Then the area of $E$ is $\pi r^2 + 2 r$. Because the area defect to $E$ of two circles being $d$ apart is $\frac{d^3}{12~ r}$, and $d\approx n^{-1}$, for large $n$ only the distance between minimum $a$ and maximum $b$ of the circle centers in $S$ determines the asymptotics. The independent expectation values for $a$ and $b$ are $1/(n+1)$ and $1-1/(n+1)$ giving an asymptotic area defect to $E$ of $4r/(n+1)$.

Answer by Karl Fabian for Path length of ball on tilted, perforated plane

2012-08-27T11:19:09Z

You use the fact that the set of points and directions where $L(\epsilon)=\infty$ has measure zero. One can translate this problem to considering closed billiard paths through $p$ in a square, which avoid the corners by $\epsilon$. In the vicinity of a closed path this may be used to bound the number of reflections necessary to reach a corner.

Answer by Karl Fabian for Covering a unit ball with balls half the radius

2012-05-29T00:32:05Z

This is a numerical calculation of an improved covering like the one proposed by Gerhard Paseman. It gives the following list of 22 centers for 1/2-balls that cover the unit ball. All, besides the central one, are on the sphere with radius Sqrt[3]/2.

2 are on the poles

6 on the upper hemisphere at latitude t = 0.20483559485813116` Pi

6 on the lower hemisphere at latitude t = 0.20483559485813116` Pi

7 lie distributed over the equator with angular distance 2/7.15 Pi, and phase shift 0.86 wrt the six upper and lower.

I didn't yet calculate all intersections of neighboring balls explicitely.

Centers: {{0, 0, 0}, {0.570962, 0.651155, 0.}, {-0.137028, 0.855116, 0.}, {-0.745836, 0.440145, 0.}, {-0.81481, -0.293402, 0.}, {-0.294026, -0.814585, 0.}, {0.439574, -0.746173, 0.}, {0.855011, -0.137682, 0.}, {0.599996, 0.346408, 0.519621}, {0., 0.692816, 0.519621}, {-0.599996, 0.346408, 0.519621}, {-0.599996, -0.346408, 0.519621}, {0., -0.692816, 0.519621}, {0.599996, -0.346408, 0.519621}, {0.599996, 0.346408, -0.519621}, {0., 0.692816, -0.519621}, {-0.599996, 0.346408, -0.519621}, {-0.599996, -0.346408, -0.519621}, {0., -0.692816, -0.519621}, {0.599996, -0.346408, -0.519621}, {0., 0., 0.866025}, {0., 0., -0.866025}}

Graphics:

ddp = 0.86; equator = Take[Table[{Cos[p], Sin[p], 0}, {p, ddp, 2 Pi, 2/7.15 Pi}], 7]; t = 0.20483559485813116 Pi; dp = 0; up = Table[{Cos[p] Cos[t], Sin[p] Cos[t], Sin[t]}, {p, Pi/6 + dp, 11/6 Pi + dp, Pi/3}]; dn = Table[{Cos[p] Cos[t], Sin[p] Cos[t], -Sin[t]}, {p, Pi/6 + dp, 11/6 Pi + dp, Pi/3}]; poles = {{0, 0, 1}, {0, 0, -1}}; out = Sqrt[3]/2 Join[equator, up, dn, poles]; Graphics3D[{{Opacity[1], Red, Sphere[{0, 0, 0}, 1/2]}, {Opacity[0.4], Red, Sphere[{0, 0, 0}, 1]}, {Opacity[0.2], Sphere[ #, 1/2] & /@ out}}, Boxed -> True]

[Graphic from the above code added by J.O'Rourke:]

KF-PS: I changed the phase shift from 0.85... to ddp = 0.86. In this case numerical calculation shows that in fact the minimum of the maximum intersection points of three neighboring spheres is >1, which implies that the unit ball is covered.

Answer by Karl Fabian for Covering a unit ball with balls half the radius

2012-05-28T18:38:48Z

Extending the idea of W. Jagy, this is a Mathematica code visualizing that 33 spheres with radius 1/2 centered at the origin and the midpoints of the faces of a soccerball with circumradius 3/4 cover the unitsphere.

coord = PolyhedronData["TruncatedIcosahedron", "VertexCoordinates"]; faces = PolyhedronData["TruncatedIcosahedron", "FaceIndices"]; f6 = Select[faces, Length[#] == 6 &]; f5 = Select[faces, Length[#] == 5 &]; len = Norm[coord[[1]]] // Simplify; Graphics3D[{{Opacity[0.3], Sphere[{0, 0, 0}, len*4/3], Sphere[ Mean[coord[[#]]], len*2/3] & /@ f6, Sphere[ Mean[coord[[#]]], len*2/3] & /@ f5, Opacity[1], Sphere[{0, 0, 0}, len*2/3]}, {Opacity[0.4], PolyhedronData["TruncatedIcosahedron" , "Faces"]}}, Boxed -> False]
[Graphic from the above code added by J.O'Rourke:]

Plotting only three outer spheres as in

Graphics3D[{{Opacity[0.3], Sphere[{0, 0, 0}, len*4/3], Sphere[ Mean[coord[[#]]], len*2/3] & /@ Take[f6, 2], Sphere[ Mean[coord[[#]]], len*2/3] & /@ Take[f5, 1], Opacity[1], Sphere[{0, 0, 0}, len*2/3]}, {Opacity[0.4], PolyhedronData["TruncatedIcosahedron" , "Faces"]}}, Boxed -> False]
[Graphic from the above code added by J.O'Rourke:]

shows that the two intersection points of three neighboring outer spheres lie either outside the sphere with radius 1 or inside the sphere of radius 1/2. This can easily be made rigorous by calculation:

mcl = Chop[ Join[Mean[coord[[#]]] & /@ Take[f6, 2], Mean[coord[[#]]] & /@ Take[f5, 1]]]; erg = Solve[(Norm[{x, y, z} - #] == len*2/3) & /@ mcl, {x, y, z}] // N; ((Norm[{x, y, z}]/len*3/4) /. #) & /@ erg

that yields the distances

{0.216794, 1.06042}

Answer by Karl Fabian for Counting restricted polyominoes

2012-01-22T15:16:42Z

By numerical calculation using the Mathematica code below the counting can be extended to n=16 in short time. The results roughly confirm the asymptotics claimed in the previous answers. This is the counting result as a list {n, Count(n)}:

{{1, 1}, {2, 1}, {3, 2}, {4, 4}, {5, 10}, {6, 21}, {7, 49}, {8, 104}, {9, 227}, {10, 468}, {11, 976}, {12, 1978}, {13, 4030}, {14, 8095}, {15, 16313}, {16, 32656}}

In comparison the approximative formula

Round[2^(n - 1) + 2^(Ceiling[n/2]) - n^3/24]

yields

{{1, 3}, {2, 4}, {3, 7}, {4, 9}, {5, 19}, {6, 31}, {7, 66}, {8, 123}, {9, 258}, {10, 502}, {11, 1033}, {12, 2040}, {13, 4132}, {14, 8206}, {15, 16499}, {16, 32853}, {17, 65843}}

and the count not including symmetric shapes

Round[2^(n - 1) - (n^3 - n^2 + 10 n + 4)/16]

results in

{{1, 0}, {2, 0}, {3, 1}, {4, 2}, {5, 6}, {6, 17}, {7, 41}, {8, 95}, {9, 210}, {10, 449}, {11, 941}, {12, 1941}, {13, 3961}, {14, 8024}, {15, 16178}, {16, 32518}, {17, 65236}}

Here the Mathematica code for n=10 (just replace PN for other values of n). The list poly contains all different poyominoes of size PN. Each can be visualized by e.g. Outline[poly[[3]]] (for the third) Poyomino shapes are encoded by the bit representation of integers.

PN = 10;
ToBit[x_] := IntegerDigits[x, 2];
BitCount[x_] := DigitCount[x, 2, 1];
CompatibleQ[bc1_, bc2_] := BitCount[BitAnd[bc1, bc2]] == 1;
FarCompatibleQ[bc1_, bc2_] := BitCount[BitAnd[bc1, bc2]] < 2;
ms = Sort[Flatten[Table[2^k (2^n - 1), {n, 1, PN - 1}, {k, 0, PN}]]];
Clear[CompList]; 
CompList[n_] := ComList[n] = Select[ms, CompatibleQ[n, #] &];
Clear[FarCompList]; 
FarCompList[n_] := FarComList[n] = Select[ms, FarCompatibleQ[n, #] &];
Cont[shape_] := 
  If[Length[shape] == 1, CompList[shape[[1]]], 
   Intersection @@ 
    Append[FarCompList /@ Drop[shape, -1], CompList[shape[[-1]]]]];
PReduce[shape_] := shape/(2^Min[IntegerExponent[#, 2] & /@ shape]);
BitArray[shape_] := Module[{pp = PReduce[shape], len },
   len = Length[ToBit[Max[pp]]]; 
   IntegerDigits[#, 2, len] & /@ pp];
Unify[shape_] := Module[{p = PReduce[shape], ba, rb, tb, rtb},
   ba = BitArray[p];
   Sort[PReduce /@ 
      Map[FromDigits[#, 2] &, {ba, rb = Reverse[ba], 
        tb = Transpose[ba], rtb = Reverse[tb], Reverse /@ ba, 
        Transpose[rb], Reverse /@ rb, Reverse /@ rtb}, {2}]][[1]]];
Outline[shape_] := With[{ll = Length[ToBit[Max[shape]]]},
   ArrayPlot[IntegerDigits[#, 2, ll] & /@ shape, Frame -> False]];
PLen[shape_] := Plus @@ (BitCount /@ shape);
PExpand[shape_, nn_] := Module[{ls = PLen[shape], cont},
   Which[ls > nn, {}, ls == nn, {shape}, True,
    cont = Select[Cont[shape], (BitCount[#] <= nn - ls) &];
    Append[shape, #] & /@ cont]];
poly = {{2^(PN - 1)}};
Do[poly = Flatten[PExpand[#, PN] & /@ poly, 1]; 
  Print[{k, Length[poly]}], {k, 1, PN - 1}];
polyonimoes[PN] = poly = Union[Unify /@ poly]; NP = Length[poly]

Comment by Karl Fabian

2012-10-03T05:26:12Z

@Joseph : Thanks, that is corrected now.

Comment by Karl Fabian

2012-09-26T16:18:49Z

$C_i$ means the center of the $i$-th circle, not the barycenter of $H_i$.

Comment by Karl Fabian

2012-09-03T20:36:49Z

There is a book by Sydney Redner: A guide to first-passage processes, Cambridge UP, 2001. It rather discusses physical processes, and continuous random walks, often with n<=3, but may help to find bounds also for the discrete case and general n.

Comment by Karl Fabian

2012-05-29T21:26:03Z

Dear Gerhard "Rotates by a Few Degrees" Paseman, thats almost a description of the above situation, but I'll give it a try when back on the sphere after leaving the plane tomorrow.

Comment by Karl Fabian

2012-05-29T16:50:25Z

I crudely estimated the necessarry overlap from a planar honeycomb and found that with this overlap one needs more than 21 spheres to cover the unit sphere, so the 21 above are better than that, such that each sphere on average cuts more than 6 others at its periphery.