# Approximating the density of $S\cap[a,b]$ using a Folner Sequence of $A$, where $S \subseteq A$?

Edit: I redid my code but it's still not working.

How do we use Mathematica to approximate

$$D(S\cap[a,b])=\lim_{n\to\infty}\frac{\left|S\cap{F_n\cap[a,b]}\right|}{\left|F_n\cap[a,b]\right|}$$

where $$D$$ is the density of $$S\cap[a,b]$$ (in $$A\cap[a,b]$$), $$[a,b]$$ is an interval for $$a,b\in\mathbb{R}$$, $$F_n$$ is the Folner Sequence of $$A$$, and $$S\subseteq A$$. For more information, click here (replace $$G,X,i,g$$ with $$A,S,n,a$$) and here.

$$A$$ is countable and dense in $$\mathbb{R}$$ and can be written as the operations of finite or infinite one-variable functions that, when defined on countable domains dense in $$\mathbb{R}$$, intersect with the integers.

Example:

$$A=\left\{\frac{m+\ln(w)}{2^{(p/q)}+\sqrt{z}}:m,p,q,z,w\in\mathbb{Z},2^{p/q}+\sqrt{z}\neq0,q\neq0,z>0,w>0\right\}$$

There are many Folner Sequence of $$A$$. In general, the most natural, "intuitive" sequence is calculated by restricting the whole set, and the variables of each function in the set, by $$n$$.

$$F_n=\left\{\frac{m+\ln(w)}{2^{(p/q)}+\sqrt{z}}:m,p,q,z\in\mathbb{Z},2^{p/q}+\sqrt{z}\neq0,q\neq0,z>0, w>0,\left|\frac{m+\ln(w)}{2^{(p/q)}+\sqrt{z}}\right|\le n,|m|\le n,|p|\le n,|q|\le n, |z| \le n, |w| \le n\right\}$$

$$S$$ can be written similarly to $$A$$ except it must be a subset.

Example:

$$S=\left\{\frac{m_1}{2^{(p_1/q_1)}+\sqrt{z_1}}:m_1,q_1,z_1\in\mathbb{Z},2^{(p_1/q_1)}+\sqrt{z_1}\neq0,q_1\neq0,z_1>0\right\}$$

I attempted to approximate $$D(S\cap[0,1])$$ when $$S=\left\{\frac{m^2}{n^2}:m,n\in\mathbb{Z},n\neq 0\right\}$$, $$A=\mathbb{Q}$$, $$F_n=\left\{\frac{p}{2^k(2q+1)}:p,k,q\in\mathbb{Z},2^k \le n, |2q+1|\le n, \left|\frac{p}{2^k(2q+1)}\right|\le n\right\}$$.

(In my code I replaced $$A$$ with A[x_,y_,z_,...] and $$F_n$$ with F[x_,y_,z_,...], $$S$$ with S[x_,y_,z_,...], and $$D$$ with d. I also set $$a=0$$ and $$b=1$$.)

I tried to list all elements of $$F_n\cap[0,1]$$ depending on $$n$$ and determine which elements in $$S\cap[0,1]$$ exist in $$F_n\cap[0,1]$$. Then I counted all elements where this holds and divided it by the total elements in $$F_n\cap[0,1]$$.

Unprotect[d]
Remove[d]
A[p_, k_, q_] := p/((2^k)*(2*q + 1))
F[p_, n_] :=
Table[A[p, k, q], {k, 0, Floor[Log[2, n]]}, {q, 0, Floor[(n - 1)/2]}]
f[n_, a_, b_] :=
p /. Table[
Solve[a <= A[p, k, q] <= b, p, Integers], {k, 0,
Floor[Log[2, n]]}, {q, 0, Floor[(n - 1)/2]}]
Ff[n_, a_, b_] :=
DeleteDuplicates[
Flatten[Table[
F[f[n, a, b][[v]][[u]], n][[v]][[u]], {v, 1,
Floor[Log[2, n]] + 1}, {u, 1, Floor[(n - 1)/2] + 1}]]]
S[j_, k_] := j^2/k^2
X[a_, b_, n_] :=
Count[Boole[Resolve[Exists[{j, k}, S[j, k] == Ff[n, a, b]]]], 1]
Y[a_, b_, n_] := Count[Ff[n, a, b]]
d[n_, a_, b_] := N[(Y[a, b, S] - X[a, b, S])/Y[a, b, S]]
Ff[4, 1, 2]
X[1, 2, 4]
Y[1, 2, 4]
d[1, 2, 4]


 During evaluation of In:= Table::iterb: Iterator {v,1,1+Floor[Log[S]/Log]} does not have appropriate bounds.

During evaluation of In:= Table::iterb: Iterator {v,1,1+Floor[Log[S]/Log]} does not have appropriate bounds.

During evaluation of In:= Table::iterb: Iterator {v,1,1+Floor[Log[S]/Log]} does not have appropriate bounds.

During evaluation of In:= General::stop: Further output of Table::iterb will be suppressed during this calculation.

During evaluation of In:= Exists::msgs: Evaluation of S[j,k]==Ff[S,2,4] generated message(s) {General::stop,Table::iterb}.

During evaluation of In:= Exists::msgs: Evaluation of j^2/k^2==Table[F[f[<<3>>][[v]][[u]],S][[v]][[u]],{v,1,1+Floor[Log[S]/Log[<<1>>]]},{u,1,Floor[(S-1)/2]+1}] generated message(s) {Table::iterb}.

During evaluation of In:= Exists::msgs: Evaluation of j^2/k^2==Table[F[f[<<3>>][[v]][[u]],S][[v]][[u]],{v,1,1+Floor[Log[S]/Log[<<1>>]]},{u,1,Floor[(S-1)/2]+1}] generated message(s) {Table::iterb}.

During evaluation of In:= General::stop: Further output of Exists::msgs will be suppressed during this calculation.

Out= 1.


Is there a better and faster method to solving my example? How do we generalize this for any $$S\cap[a,b]$$ and $$A\cap[a,b]$$?

• As an aside, you are playing with fire with Unprotect and Remove on initial capitalized symbols. You do realize, D is a built-in Mathematica symbol, yes?
– ciao
Sep 26, 2019 at 19:55
• @ciao Do you have any clue on how to solve this question? Sep 26, 2019 at 23:46
• Have a look at your line i[s_] := Solve[s > a && s < b, p, Integers] . There is no p in the inequality that you are trying to solve. Notice that you have already assign values to a and b. Sep 28, 2019 at 9:08
• @yarchik If you take Thread[i[G[p,n]] there is a p in the inequality of i. And I decided to take a specific example of $a$ and $b$. I will mention this in my post. Sep 28, 2019 at 15:39
• I tried to debug your code. There are a number of things that are not working as you expect. My recommendation is to work step by step and isolate the problems. Consider replacing problematic pieces with simpler constructions. Try to avoid Unprotect and Remove. There are enough small case letters, which do not have a reserved meaning. Sep 28, 2019 at 17:08

This works and provides expected resulst as far as I'm aware:

Clear[A, F, f, p, Ff, S, X, Y, d, j, k];
A[p_, k_, q_] := p/((2^k)*(2*q + 1));
F[p_, n_] :=
Table[A[p, k, q], {k, 0, Floor[Log[2, n]]}, {q, 0,
Floor[(n - 1)/2]}];
f[n_, a_, b_] :=
p /. Table[
Solve[a <= A[p, k, q] <= b, p, Integers], {k, 0,
Floor[Log[2, n]]}, {q, 0, Floor[(n - 1)/2]}];
Ff[n_, a_, b_] := DeleteDuplicates@Flatten@Table[
F[f[n, a, b][[v]][[u]], n][[v]][[u]]
, {v, 1, Floor[Log[2, n]] + 1}
, {u, 1, Floor[(n - 1)/2] + 1}
];
S[j_, k_] := j^2/k^2;
X[n_, a_, b_] :=
Count[Resolve[
Exists[{j, k}, S[j, k] == # && {j, k} ∈ Integers]] & /@
Ff[n, a, b], True];
Y[n_, a_, b_] := Length[Ff[n, a, b]];
d[n_, a_, b_] := N[(Y[n, a, b] - X[n, a, b])/Y[n, a, b]];
Ff[4, 1, 2]
X[4, 1, 2]
Y[4, 1, 2]
d[4, 1, 2]


{1,2,4/3,5/3,3/2,7/6,11/6,5/4,7/4,13/12,17/12,19/12,23/12}
1
13
0.923077

• @Markhain You don’t have to read my formula. You can read the articles I posted. Y[4,1,2] shouldn’t be one, it counts the elements in Ff[n] and should be 13. As with X[4,1,2], It should be greater than zero. Do you know how to correct this? Sep 30, 2019 at 14:09
• @Arbuja I edited it in. Oct 1, 2019 at 4:43
• I still get X[4,1,2] equals zero. I don't know why? I doubt we can calculate Limit[d[n,1,2],n->Infinity]. How would we do that? I made (mathematica.stackexchange.com/questions/207177/… question] just in case. Oct 1, 2019 at 16:37
• @Arbuja Sorry there was a typo ({j, k} a ∈ Integers in stead of {j, k} ∈ Integers) in the code. Fixed it and double checked that the code in the answer is working. Oct 2, 2019 at 4:18
• @Arbuja have you tried consequently calculating d[n,1,2] while manually increasing n, and investigate resulting sequence by hand? Oct 2, 2019 at 13:33

Just to get you started, the first part of the code where you solve for p can be written as

f[n_, a_, b_] := Cases[
Flatten[
Table[
Solve[a < p/((2^k) (2 q + 1)) < b, p, Integers],
{k, 0, Floor[Log[2, n]]}, {q, 0, Floor[(n - 1)/2]}
]
], Rule[x_, y_] -> y]


Test

f[2, 1, 5]
(* {2, 3, 4, 3, 4, 5, 6, 7, 8, 9} *)


Notice, I eliminated all redundant lists and functions.

• If I wanted to find outputs of $\frac{p}{2^k(2q+1)}$ between $a$ and $b$. What would we do instead? Sep 28, 2019 at 20:48
• @yarchick I redid my code. It should make sense now...... but I still get error messages. Sep 28, 2019 at 23:33