# How to visualize and solve darboux-like sum taking average of function $P$ defined on domain dense in its’ infinite limit points?

Consider $$P:A\to[0,1]$$ where $$A\subseteq[0,1]$$. Suppose

$$A=\left\{\frac{1}{2^x}+\frac{1}{2^y}+\frac{1}{2^z}:x,y,z\in\mathbb{Z}\right\}\cap[0,1]$$

and the partition of $$[0,1]$$ is a sequence $$x_i$$ where

$$0= x_0 \le x_1 \le ...\le x_n=1$$

,$$t_i\in A\cap[x_{i-1},x_i]$$, if $$|A\cap[x_{i-1},x_{i}]>1$$ then $$x_{i}-x_{i-1}=1/s$$, if $$|A\cap[x_{i-1},x_i]|=1$$ then $$x_{i}-x_{i-1}>0$$ and if neither are possible, $$x_{i}-x_{i-1}=\sup\limits_{|A\cap[x_{i-1},x_i]|=0} x_{i}-x_{i-1}$$.

As $$s\to\infty$$, calculate the following

$$\sum_{i=1}^{n}\inf_{t_i\in A\cap[x_{i-1},x_i]}P(t_i)(1/n) \le \text{Average of P} \le \sum_{i=1}^{n} \sup_{t_i\in A\cap[x_{i-1},x_i]}P(t_i)(1/n)$$

My guess is the sums should converge to $$P(0)$$.

Edit: As @VictorK pointed out, I was wrong; however, it seems my answer would be one of the infinitely possible limits of $$\lim\limits_{x\to 0^{+}}P(x)$$ and $$\lim\limits_{x\to 0^{-}}P(x)$$.

How do we visualize this on a graph for a given function ($$P(x)=x$$)? How do we solve the upper and lower sums to prove whether I am right or wrong?

## EDIT

Here's what I tried

Unprotect[O]
Remove[x, y, z, a, b, c, P, A, B, r, O, S, s]
Subscript[A, 1][x_, y_, z_] :=
1/2^x + 1/2^y + 1/2^z;  (*Function Inside Set A*)
P[x_] := x ;
Subscript[A, 2][a_, b_, c_] :=
Table[Table[
Table[Subscript[A, 1][x, y, z], {x, 0, a}], {y, 0, b}], {z, 0,
c}] ;(*Function that Lists Elements of A between 0 and 1 as a,b,c
approach Infinity *)
A = DeleteDuplicates[
Select[Flatten[Subscript[A, 2][20, 20, 20]], Between[#, {0, 1}] &]];
ListPlot[Table[{A[[x]], P[A[[x]]]}, {x, 0, Length[A]}],
PlotStyle -> PointSize[.003]]
z = Sort[A]; (*Sort A from Least to Greatest*)


This gives us a graph of $$P(x)$$ We order the elements from least to greatest and take their differences.

z = Sort[A]; (*Sort A from Least to Greatest*)
B = Differences[z]; (*Takes the difference of two consecutive elements in
A*)


The distance between the elements in z represent the length of intervals $$[x_{i-1},x_i]$$.

Now we do the following. We set $$s=.001$$. Since B[] is not greater than $$s$$, we add the differences until the sums are greater than $$s$$.

Using O[a_,b_]

O[a_, b_] := Sum[B[[x]], {x, a, b}]; (*Takes the sum of those differences
from one indice to another*)


We find B[]+B[]+B[]+B[]+... is not greater than $$s$$ till B[]. At B, we add consecutive differences till the sum is greater than $$s$$, using O[a_,b_] we find B[]+B[]+B[]+... is not greater than $$s$$ till B[]. The first two terms of $$x_i$$ should be z[]+O[1,189] and z[]+O[1,189]+O[190,251].

The first eight terms, substituted as $$\left\{x_i,P(x_i)\right\}$$ should be

  {{3/524288, 3/524288}, {531/524288, 531/524288}, {2121/1048576, 2121/
1048576}, {803/262144, 803/262144}, {4271/1048576, 4271/
1048576}, {2697/524288, 2697/524288}, {6677/1048576, 6677/
1048576}, {1027/131072, 1027/131072}, {9275/1048576, 9275/1048576}}


However, using O[a_,b_] takes too much time. The only approach I can think of is a double while loop

u = B[], S = z[], a = 1, b = 1, c = 0; (*Initial factors*)
While b <= Length[B]; (*Continues looping till b reaches the final element
in B*)
c = c + 1 (*Counts the number of elements in S[c]*)
While B[[b]] < s && b <= Length[B], (*Continues looping as till
B[[b]] is less than s*)
S[c]/c  (*The average. As the loops keep going we get the average \
desired*)
B[[b]] = B[[b]] + B[[b + 1]] (*Adds consecutive elements to B[[b]]
until B[[b]]<s*)
P[u[c]] = P[u[c]] +  B[[b]] (*U[c] is substituted into P[x] to get the
average of the outputs of P[x] defined in A *)
S[c + 1] = S[c] + P[u[c]] (*Sums the outputs of P[x] defined in A*)
B[[b]] = B[[b]] + B[[b + 1]] (*Continues to the next element*)


However, it's recommended we don't use while loops in Mathematica and I get the following:

Syntax::tsntxi: "u=B[],S=z[],a=1,b=1,c=0;While
b<=Length[B];c=c+1" is incomplete; more input is needed.


How do we fix this? Is there a better approach?

• Could you please show us what you tried so far? Apr 18, 2020 at 21:06
• Choose a concrete partition sequence $x_i = \frac 1 n$, for example, then calculate $t_i$ for that case, and see what you get for $P(x)=x^2$. That should give you plenty of intuition. Apr 18, 2020 at 23:02
• @dskeletov For $x_i=\frac{1}{n}$, not all sub-intervals include an element of $A$. So we need a different concrete partition sequence. Apr 18, 2020 at 23:15
• @VictorK. I made edits Apr 20, 2020 at 22:30
• Thanks for the clarification and for showing your inputs. Is there a way to simplify your question? As stated, your are asking to optimize a pretty complex piece of code, or even find a better solution to your original problem, which is also pretty complex. Apr 21, 2020 at 3:27

First, let's have a look at the set $$A$$, to get a sense for what it's like. Note that given the formula to generate $$A$$ is symmetrical, we can assume $$1<=x<=y<=z$$:

generateA[n_Integer] := Select[
Union@Flatten[
Table[1/2^x + 1/2^y + 1/2^z, {x, 1, n}, {y, x, n}, {z, y, n}]],
0 <= # <= 1 &]

NumberLinePlot[generateA, PlotStyle -> PointSize[0.003]] The above is one example of what I meant by simplification: we don't need to define generateA to accept three different limits, as in your definition of Subscript[A, 2][a_, b_, c_], since you yourself are only using it with $$a=b=c$$ in your definition of $$A$$. I would also advise you against using Subscript unless necessary; it's probably better to just give your function a descriptive name, which simplifies the understanding of the following code.

Looking at the number line plot above, you can start developing some intuition about $$A$$: it's dense around $$0$$ but e.g. discreet around $$1$$; the closest you can get to 1 is $$7/8 = 1/2 + 1/4 + 1/8$$, and there are no elements of $$A$$ between $$7/8$$ and 1, for example.

This also illustrates what you want from your partition $$x_i$$: for those regions where $$A$$ is dense, the length of the interval should be $$s<<1$$, and for those regions where $$A$$ is discreet, you want the interval $$[x_{i-1}, x_i]$$ to contain only a single element of $$A$$.

The second part of your question can be restated as follows: given a set $$A$$ as above and a number $$s$$, split $$A$$ into partitions such that 1) each partition has either a single element or has a diameter less than $$s$$; 2) no element in the partition can be extended by adding another element from $$A$$.

partition[a_List, s_] := Module[{f, r},
f[{},x_] := {x};
f[l_List,x_] :=
If[x - l[] < s,
Append[l, x],
Sow[l]; {x}];
r = Reap[Fold[f, {}, a]];
Append[r[[2,1]],r[]]]
partition[{0, 1, 2, 7, 10, 11, 12}, 5]
(* {{0, 1, 2}, {7, 10, 11}, {12}} *)


We can evaluate $$\inf$$ and $$\sup$$ of any function $$P$$ on a partially generated set a given a partition size $$s$$.

calculate[p_, a_, s_] := Module[{parts = partition[a, s], n, inf, sup},
n = Length[parts];
inf = Total[Min[p /@ #] & /@ parts];
sup = Total[Max[p /@ #] & /@ parts];
{inf/n, sup/n}]


Finally, here is your answer for $$P=x$$, $$s=0.001$$, and $$A$$ calculated for $$1<=x<=y<=z<=50$$:

calculate[Identity, generateA, 0.001] // N
(* {0.276151, 0.276533} *)

• I set calculate[Identity, generateA,N[10^(-170)]] // N and I still get .0149246. That's not convincing enough to show the sum approaches 0. Is there a better way to show this? I guess mathematics is the best way out. Thanks anyways. Apr 21, 2020 at 19:05
• Note that with a200 = generateA, Min[Differences@a200] // N returns 6.22302*10^-61, so setting s much smaller won't help. Apr 21, 2020 at 19:23
• And I'm not confident that this sum approaches 0, btw. You can try a denser set (e.g., generateA) to see if it changes things. Apr 21, 2020 at 19:24
• One other improvement would be to use N inside generateA, as it will convert everything to reals right away and you won't have the penalty of doing exact math. Apr 21, 2020 at 19:26
• I get {.00598798,.00598798}. I'm sure the sums converge to zero. Apr 22, 2020 at 4:04