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$
  • $\begingroup$ And what have you tried? $\endgroup$ – Dr. belisarius Aug 11 '15 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$ – Marius Ladegård Meyer Aug 11 '15 at 20:57
  • $\begingroup$ There is a typo in your code linelist is not the same as lineList $\endgroup$ – Enrique Pérez Herrero Aug 11 '15 at 22:16
  • $\begingroup$ Of course, you cannot actually make a plot with infinitely many triangles… $\endgroup$ – J. M. will be back soon Aug 12 '15 at 0:33
  • $\begingroup$ @J.M. Tony's original post said that, but for some reason Tony removed that observation. $\endgroup$ – Michael E2 Aug 12 '15 at 1:24
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$
  • $\begingroup$ MarcoB: allpoints = SortBy[Join[basepoints, apexpoints], First]; also works. $\endgroup$ – David G. Stork Aug 11 '15 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
    $\begingroup$ I quite like this... +1 $\endgroup$ – ciao Aug 12 '15 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 Aug 12 '15 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$
  • $\begingroup$ Hmm, PowerRange[] is new… finally there's something like MATLAB's logspace(). :) $\endgroup$ – J. M. will be back soon Aug 12 '15 at 5:03
  • $\begingroup$ @J.M. sometimes PowerRange handy... $\endgroup$ – ubpdqn Aug 12 '15 at 5:07
  • $\begingroup$ BTW: MantissaExponent[] could also be used in your case. $\endgroup$ – J. M. will be back soon Aug 12 '15 at 5:07
  • $\begingroup$ @J.M. thanks! always learning something. Useful to know for the armamentarium $\endgroup$ – ubpdqn Aug 12 '15 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$
  • $\begingroup$ Hmm, using the PDF of a triangular distribution is quite nifty! (+1) $\endgroup$ – MarcoB Aug 12 '15 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$
  • $\begingroup$ Tested and neat +1 :) $\endgroup$ – ubpdqn Aug 12 '15 at 4:48
  • $\begingroup$ Thanks for testing! It was okay with gedanken Mathematica, so a confirmation was reassuring. $\endgroup$ – J. M. will be back soon Aug 12 '15 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 Aug 12 '15 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
    $\begingroup$ Of course, for an integer i, Boole[Mod[i, 2] == 1] is simply Mod[i, 2]. $\endgroup$ – J. M. will be back soon Aug 12 '15 at 4:43

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.