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

Question

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[[1]] 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[[1]]+B[[2]]+B[[3]]+B[[4]]+... is not greater than $s$ till B[[189]]. At B[190], we add consecutive differences till the sum is greater than $s$, using O[a_,b_] we find B[[190]]+B[[191]]+B[[192]]+... is not greater than $s$ till B[[251]]. The first two terms of $x_i$ should be z[[1]]+O[1,189] and z[[1]]+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[1] = B[[1]], S[1] = z[[1]], 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[1]=B[[1]],S[1]=z[[1]],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?

Answer 1

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[50], 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[[1]] < s,
    Append[l, x],
    Sow[l]; {x}];
  r = Reap[Fold[f, {}, a]];
  Append[r[[2,1]],r[[1]]]]
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[50], 0.001] // N
(* {0.276151, 0.276533} *)