1
$\begingroup$

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]

Instead, I get

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

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

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

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

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

During evaluation of In[629]:= 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[629]:= 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[629]:= General::stop: Further output of Exists::msgs will be suppressed during this calculation.

Out[642]= 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]$?

$\endgroup$
  • 4
    $\begingroup$ 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? $\endgroup$ – ciao Sep 26 at 19:55
  • $\begingroup$ @ciao Do you have any clue on how to solve this question? $\endgroup$ – Arbuja Sep 26 at 23:46
  • $\begingroup$ 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. $\endgroup$ – yarchik Sep 28 at 9:08
  • $\begingroup$ @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. $\endgroup$ – Arbuja Sep 28 at 15:39
  • 2
    $\begingroup$ 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. $\endgroup$ – yarchik Sep 28 at 17:08
2
+50
$\begingroup$

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

$\endgroup$
  • $\begingroup$ @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? $\endgroup$ – Arbuja Sep 30 at 14:09
  • $\begingroup$ @Arbuja I edited it in. $\endgroup$ – Markhaim Oct 1 at 4:43
  • $\begingroup$ 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. $\endgroup$ – Arbuja Oct 1 at 16:37
  • $\begingroup$ @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. $\endgroup$ – Markhaim Oct 2 at 4:18
  • 1
    $\begingroup$ @Arbuja have you tried consequently calculating d[n,1,2] while manually increasing n, and investigate resulting sequence by hand? $\endgroup$ – Markhaim Oct 2 at 13:33
2
$\begingroup$

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.

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.