1
$\begingroup$

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)$

enter image description here

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?

$\endgroup$
  • $\begingroup$ Could you please show us what you tried so far? $\endgroup$ – Victor K. Apr 18 at 21:06
  • $\begingroup$ 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. $\endgroup$ – dskeletov Apr 18 at 23:02
  • $\begingroup$ @dskeletov For $x_i=\frac{1}{n}$, not all sub-intervals include an element of $A$. So we need a different concrete partition sequence. $\endgroup$ – Arbuja Apr 18 at 23:15
  • $\begingroup$ @VictorK. I made edits $\endgroup$ – Arbuja Apr 20 at 22:30
  • 2
    $\begingroup$ 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. $\endgroup$ – Victor K. Apr 21 at 3:27
1
+100
$\begingroup$

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]]

Mathematica graphics

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} *)
| improve this answer | |
$\endgroup$
  • $\begingroup$ I set calculate[Identity, generateA[200],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. $\endgroup$ – Arbuja Apr 21 at 19:05
  • $\begingroup$ Note that with a200 = generateA[200], Min[Differences@a200] // N returns 6.22302*10^-61, so setting s much smaller won't help. $\endgroup$ – Victor K. Apr 21 at 19:23
  • $\begingroup$ And I'm not confident that this sum approaches 0, btw. You can try a denser set (e.g., generateA[500]) to see if it changes things. $\endgroup$ – Victor K. Apr 21 at 19:24
  • $\begingroup$ 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. $\endgroup$ – Victor K. Apr 21 at 19:26
  • $\begingroup$ I get {.00598798,.00598798}. I'm sure the sums converge to zero. $\endgroup$ – Arbuja Apr 22 at 4:04

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.