6
$\begingroup$

I try to plot the following graph using Graphics and Table. The graph consists of infinitely many isosceles triangles (without their bases).

The plot is within $[0,1]\times[0,1]$. The first isosceles triangle is of base $\frac{1}{2}$ and height $1$, the 2nd is of base $\frac{1}{4}$ and height $\frac{1}{2}$, etc. In general the $k$ th is of base length $2^{-k}$ and height $\frac{1}{k}$. There are infinitely many such triangles and the total base length is hence $\sum\limits_{k = 1}^\infty {{2^{ - k}}} = 1$.

The code I tried is

linelist = Table[
   {{Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + 
      Boole[Mod[i, 2] == 1]*(1 - 2^(-(i + 1)/2) - 2^(-(i + 1)/2 - 1)),
      Boole[Mod[i, 2] == 0]*0 + Boole[Mod[i, 2] == 1]*2/(i + 1)}},
   {i, 1, 100}
   ];

Graphics[lineList, Axes -> True];

but something wrong occurs and the output is empty. I don't know what is wrong with the code.

Thank you!

The graph I want to plot is sketched as the following:

enter image description here

$\endgroup$
5
  • $\begingroup$ And what have you tried? $\endgroup$ Commented Aug 11, 2015 at 20:55
  • 1
    $\begingroup$ What have you tried? It should be straightforward to find a formula for the coordinates of the maxima and minima, then you can just make as many as you need and use ListPlot. $\endgroup$ Commented Aug 11, 2015 at 20:57
  • $\begingroup$ There is a typo in your code linelist is not the same as lineList $\endgroup$ Commented Aug 11, 2015 at 22:16
  • $\begingroup$ Of course, you cannot actually make a plot with infinitely many triangles… $\endgroup$ Commented Aug 12, 2015 at 0:33
  • $\begingroup$ @J.M. Tony's original post said that, but for some reason Tony removed that observation. $\endgroup$
    – Michael E2
    Commented Aug 12, 2015 at 1:24

9 Answers 9

12
$\begingroup$

Another approach would be to consider the triangles as graphics primitives. The first triangle would be constructed manually with

Triangle[{{0, 0}, {1/4, 1}, {1/2, 0}}]

and each other triangle would be constructed by translating and scaling properly the first triangle. A set of triangles would be obtained with

myTriangles[number_] := NestList[
  {Scale[
  Translate[Triangle[{{0, 0}, {1/4, 1}, {1/2, 0}}], {(#[[2]] + 1)/2, 0}], 
  {#[[3]]/2, 1/(Denominator@#[[4]] + 1)}, {Left, Bottom}], 
  (#[[2]] + 1)/2, #[[3]]/2, 1/(Denominator@#[[4]] + 1)} &, 
  {Triangle[{{0, 0}, {1/4, 1}, {1/2, 0}}], 0, 1, 1}, number - 1][[All, 1]]

To plot 100 triangles we would use for instance

Graphics[myTriangles[100], Axes -> True, AspectRatio -> 1/GoldenRatio]

enter image description here

EDIT

An alternative (perhaps cleaner) approach would be to use the MapThread function

myTranslations[number_] := Accumulate@NestList[#/2 &, 1/2, number - 1]
myScalingsX[number_] := NestList[#/2 &, 1/2, number - 1]
myScalingsY[number_] := NestList[1/(Denominator@# + 1) &, 1/2, number - 1]

myTrianglesFromMT[number_] := {Triangle[{{0, 0}, {1/4, 1}, {1/2, 0}}], MapThread[
   Scale[
   Translate[Triangle[{{0, 0}, {1/4, 1}, {1/2, 0}}], {#1, 0}], 
   {#2, #3}, {Left, Bottom}] &, 
   {myTranslations[number], myScalingsX[number], myScalingsY[number]}]}
$\endgroup$
10
$\begingroup$
num=100

p = Partition[Accumulate@Prepend[NestList[#/2 &, 1/2, num - 1], 0], 2,1];
ListLinePlot[Join @@ MapThread[{{#1[[1]], 0}, {Mean[#1], #2}, {#1[[2]], 0}} &, 
   {p, 1/Range@Length@p}], PlotRange -> All]

enter image description here

$\endgroup$
10
$\begingroup$

Here is another couple of takes on the same problem. Both attempts construct a list of base points (in red in the plot below), and a separate list of apex points (in blue), then they Riffle the two lists together to get a list of points to plot with ListPlot.

The first approach uses MovingAverage to determine the $x$ position of the apex points:

nmax = 10;

basepoints = {#, 0} & /@ Join[{0}, Accumulate[Table[2^-n, {n, 1, nmax}]]]
apexpoints = MapIndexed[{#1, 1/First@#2} &, MovingAverage[%[[All, 1]], 2]]
allpoints = Riffle[basepoints, apexpoints]

ListPlot[
 allpoints,
 Filling -> Axis, Joined -> True, AspectRatio -> 0.3, 
 PlotRange -> All, ImageSize -> Full,
 Epilog -> {PointSize[0.01], Red, Point[basepoints], Blue, Point[apexpoints]}
]

numerical results

corresponding plot


The second approach uses direct formulae to calculate the positions of those points. The results, of course, are the same.

nmax = 10;

basepoints = Table[{1 - 2^-n, 0}, {n, 0, nmax + 1, 1}];
apexpoints = Table[{1 - 3 2^-(n + 2), 1/(n + 1)}, {n, 0, nmax, 1}];
allpoints = Riffle[basepoints, apexpoints];
$\endgroup$
1
  • $\begingroup$ MarcoB: allpoints = SortBy[Join[basepoints, apexpoints], First]; also works. $\endgroup$ Commented Aug 11, 2015 at 23:26
10
$\begingroup$

GeometricTransformation is an efficient graphics tool for drawing many affine transforms of a figure.

Graphics[{
  LightGray, EdgeForm[Lighter@Blue],
  GeometricTransformation[
   Polygon[{{0, 0}, {1/2, 0}, {1/4, 1}}], 
   ScalingTransform[{2^(1 - #), 1/#}, {1, 0}] & /@ Range[100]
   ]},
 Frame -> True
 ]

Mathematica graphics

$\endgroup$
2
  • 2
    $\begingroup$ I quite like this... +1 $\endgroup$
    – ciao
    Commented Aug 12, 2015 at 1:49
  • 1
    $\begingroup$ @ciao, Thanks but if I hadn't started off on the wrong path, I would have used ScalingTransform[{2^(1 - #), 1/#}, {1, 0}] & /@ Range[100] from the start. :) $\endgroup$
    – Michael E2
    Commented Aug 12, 2015 at 2:44
7
$\begingroup$
g[n_] := Sum[1/2^i, {i, 1, n}];
f[n_] := (- 1/2^(n + 1) + g[n] )
t1 = Table[{f[n], 1/n}, {n, 1, 20}];
t2 = Table[{g[n], 0}, {n, 0, 20}];
t3 = Sort[Union[t1, t2]]
ListPlot[t3, Joined -> True, Filling -> Axis, PlotRange -> All]

Triangle Plot

You can try also with your code:

linelist = 
  Table[{Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + 
  Boole[Mod[i, 2] == 1]*(1 - 2^(-(i + 1)/2) - 2^(-(i + 1)/2 - 1)), 
  Boole[Mod[i, 2] == 0]*0 + Boole[Mod[i, 2] == 1]*2/(i + 1)}, {i, 1, 100}];    
(*Note removed {} *)
ListPlot[linelist, Joined -> True, Filling -> Axis, PlotRange -> All]
$\endgroup$
6
$\begingroup$
tr[x_] :=Abs[TriangleWave[x 2^-(Floor[Log[2, 1 - x]] + 1)]/(Floor[Log[2, 1 - x]])]

Visualizing:

Plot[tr[x], {x, 0, 1}, 
 GridLines -> {1 - PowerRange[1/2, 1/128, 1/2], Table[1/j, {j, 7}]}, 
 Frame -> True]

enter image description here

$\endgroup$
4
  • $\begingroup$ Hmm, PowerRange[] is new… finally there's something like MATLAB's logspace(). :) $\endgroup$ Commented Aug 12, 2015 at 5:03
  • $\begingroup$ @J.M. sometimes PowerRange handy... $\endgroup$
    – ubpdqn
    Commented Aug 12, 2015 at 5:07
  • $\begingroup$ BTW: MantissaExponent[] could also be used in your case. $\endgroup$ Commented Aug 12, 2015 at 5:07
  • $\begingroup$ @J.M. thanks! always learning something. Useful to know for the armamentarium $\endgroup$
    – ubpdqn
    Commented Aug 12, 2015 at 5:09
5
$\begingroup$
heights = Table[1/(k 2^(k + 1)), {k, 1, 15}];
widthpositions = 
  Partition[Accumulate@Prepend[NestList[#/2 &, 1/2, 14], 0], 2, 1];
Plot[MapThread[#1 PDF[TriangularDistribution[#2], x] &, 
  {heights, widthpositions}], 
 {x, 0, 1}, 
 Filling -> Axis]

enter image description here

$\endgroup$
1
  • $\begingroup$ Hmm, using the PDF of a triangular distribution is quite nifty! (+1) $\endgroup$
    – MarcoB
    Commented Aug 12, 2015 at 3:16
5
$\begingroup$

Untested Just tested:

With[{n = 20},
     Plot[Sum[UnitTriangle[(x - 1) 2^(k + 1) + 3]/k, {k, n}], {x, 0, 1}]]

Here is a solution that is entirely equivalent to ubpdqn's:

Plot[Abs[TriangleWave[#1]/(#2 - 1)] & @@ MantissaExponent[1 - x, 2], {x, 0, 1}]
$\endgroup$
3
  • $\begingroup$ Tested and neat +1 :) $\endgroup$
    – ubpdqn
    Commented Aug 12, 2015 at 4:48
  • $\begingroup$ Thanks for testing! It was okay with gedanken Mathematica, so a confirmation was reassuring. $\endgroup$ Commented Aug 12, 2015 at 5:01
  • 2
    $\begingroup$ one day I hope to develop such a "gedanken" Mathematica alas my hardware is too old and you can't get upgrades...that is why I MSE provides a nice network to extend beyond ones constraints :) $\endgroup$
    – ubpdqn
    Commented Aug 12, 2015 at 5:04
4
$\begingroup$

Actually there is nothing much wrong with your approach. You generate the coordinates for vertices you want to plot, but that's not enough. Graphics requires graphic primitives such as Line (the one to use in this case), so you need to wrap your coordinates in that primitive.

pts[max_Integer?EvenQ] :=
  Table[
    {Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + 
     Boole[Mod[i, 2] == 1]*(1 - 2^(-(i + 1)/2) - 2^(-(i + 1)/2 - 1)),
     Boole[Mod[i, 2] == 0]*0 + Boole[Mod[i, 2] == 1]*2/(i + 1)}, 
    {i,0, max}]

pts[4]
{{0, 0}, {1/4, 1}, {1/2, 0}, {5/8, 1/2}, {3/4, 0}}
Graphics[Line[pts[12]], Axes -> True]

plot

Another minor error you made was to write

{{
  Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + 
  Boole[Mod[i, 2] == 1]*(1 - 2^(-(i + 1)/2) - 2^(-(i + 1)/2 - 1)),
  Boole[Mod[i, 2] == 0]*0 + Boole[Mod[i, 2] == 1]*2/(i + 1)}
}}

when all you needed was

{
  Boole[Mod[i, 2] == 0]*(1 - 2^(-i/2)) + 
  Boole[Mod[i, 2] == 1]*(1 - 2^(-(i + 1)/2) - 2^(-(i + 1)/2 - 1)),
  Boole[Mod[i, 2] == 0]*0 + Boole[Mod[i, 2] == 1]*2/(i + 1)
}
$\endgroup$
1
  • 1
    $\begingroup$ Of course, for an integer i, Boole[Mod[i, 2] == 1] is simply Mod[i, 2]. $\endgroup$ Commented Aug 12, 2015 at 4:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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