4
$\begingroup$

I need to visualize some fractal circle arrangements where tangent circles can vary by ten orders of magnitude. In such cases the circles are not being drawn as tangent.

Example: The red and blue circles generated below are tangent at {0,0}, but with large red radius they are not drawn so, and the drawing error changes with PlotRange.

Manipulate[
 Graphics[{Red, Disk[{-(10^logR), -(10^logR)}/Sqrt[2], 10^logR]
    ,Blue, Disk[{1, 1}/Sqrt[2], 1]}
  ,Axes -> True
  ,ImageSize -> 200
  ,PlotRange -> {{-plotRange, plotRange}, {-plotRange, plotRange}}
  ,PlotRangeClipping -> True]
 ,{{logR, 6}, 0, 10, 1, Appearance -> "Labeled"}
 ,{plotRange, 1, 100, 1, Appearance -> "Labeled"}
]

-- Is there a way to fix this?

Note it breaks even here, where all inputs to Graphics are exact numbers (have also tried SetPrecision on those inputs, to no avail.)

UPDATE - sample output per request:

Here are some sample outputs, tho not integer logR values to show some partial misbehavior. The first and last are fine, the middle ones broken.

Sample outputs

Note that simply changing the ImageSize also changes the error, as does even selecting and enlarging the Graphics by hand in the nb.

Here is a picture from my actual context, one particular asymptotic neighborhood of interest. I need the blue circle to be tangent to all those green ones, not overlapping.

Picture from actual application context

FYI: The large blue circle and the green one at the end of the zig-zag dotted line are essentially generated by

Module[{xyGreen = {0.93836`40, 0.34624`40}},
 Graphics[{Darker@Darker@Blue, Disk[{0, 0}, 1]
   , Darker@Green, 
   Disk[xyGreen, EuclideanDistance[{0, 0}, xyGreen] - 1]},
  PlotRange -> {{0.93514, 0.94175}, {0.34259, 0.34921}}]
 ]

(The EuclideanDistance calculation and the `40 precision mean these circles should really be tangent well beyond the precision needed)

Improve this question
$\endgroup$
5
  • $\begingroup$ Can you include images of the problem result, together with the exact values that generated them? $\endgroup$
    – MarcoB
    Apr 3, 2019 at 17:08
  • 3
    $\begingroup$ I recall a related question tagged with [bug]. But I can't find it. It has a blue half-disk and a red triangle. Another related question is this one. $\endgroup$
    – Silvia
    Apr 3, 2019 at 17:21
  • 1
    $\begingroup$ @Silvia I remember it, too. I may have answered it, but I cannot find it either. The problem is in numerics in the GPU $\endgroup$
    – Michael E2
    Apr 3, 2019 at 22:27
  • $\begingroup$ I will submit a bug report. $\endgroup$
    – GFurnas
    Apr 10, 2019 at 23:25
  • $\begingroup$ MetaPoint - There has been considerable effort to make MMA handle exact and arbitrary precision calculations. It would be cool if the graphics could also do so, e.g., when given PerformanceGoal->"Quality". (Is it conceivable that GPU's could be programmed to handle arbitrary precision??) Vastly multiscale representations are increasingly important in science and engineering, and everybody seems to want dynamic interactive graphics to explore things... $\endgroup$
    – GFurnas
    Apr 10, 2019 at 23:25

2 Answers 2

Reset to default
3
$\begingroup$

I believe it's a numerics issue, possibly in the GPU, which would make an easy fix difficult. Here's one way to avoid the issues:

Manipulate[Graphics[{
   Red,
   If[Or @@ 
     Negative[{-plotRange, -plotRange} - {-(10^logR), -(10^logR)}/
        Sqrt[2]],
    Disk[{-(10^logR), -(10^logR)}/Sqrt[2], 10^logR],
    Polygon@Append[
      Table[
       N[{-(10^logR), -(10^logR)}/Sqrt[2] + 
         10^logR {Cos[t], Sin[t]}], {t, 
        Subdivide[##, 20] & @@
         ArcTan[{plotRange, -plotRange} - {-(10^logR), -(10^logR)}/
            Sqrt[2], {-plotRange, 
            plotRange} - {-(10^logR), -(10^logR)}/Sqrt[2]]}
       ],
      {-plotRange, -plotRange}]
    ],
   Blue, Disk[{1, 1}/Sqrt[2], 1]}, Axes -> True, ImageSize -> 200, 
  PlotRange -> {{-plotRange, plotRange}, {-plotRange, plotRange}}, 
  PlotRangeClipping -> True],
 {{logR, 6}, 0, 10, 1, Appearance -> "Labeled"}, {plotRange, 1, 100, 
  1, Appearance -> "Labeled"}]

It's slightly better if the points are computed accurately with N[p, {prec, acc}] instead of just N[p], but the difference is barely noticeable:

N@N[{-(10^logR), -(10^logR)}/Sqrt[2] + 10^logR {Cos[t], Sin[t]}, {8, 8}]
Improve this answer
$\endgroup$
2
  • $\begingroup$ P.S. I believe this issue has come up before, which I mentioned below the OP, but I couldn't find it. $\endgroup$
    – Michael E2
    Apr 3, 2019 at 23:03
  • $\begingroup$ Good trick, but unfortunately it is not feasible for my case. Im looking at the geometry of circle packing deep in fractal Apollonian Gaskets. Many circles of vast ranges of sizes are tangent to one another at all orientations, and I will be panning and zooming around all sorts of neighborhoods. Im interested in things approaching asymptotic structure and I have to go deep, and, it is extremely common for circles to have at least one of their "parent" tangent circles vastly larger, but other things going on locally at smaller scales as well. I'll be sad if it is a GPU issue :-( $\endgroup$
    – GFurnas
    Apr 4, 2019 at 19:39
1
$\begingroup$

This post is not meant to completely solve your problem, but perhaps start a discussion. For me, one circle with radius order of magnitude 100 times another circle's radius is just barely visible. I've fixed the red circle, and adjusted the PlotRange accordingly. Probably there are other approaches.

Manipulate[plotRange = 2 10^logR; 
  Graphics[{Red, Disk[{-(10^logR), -(10^logR)}/Sqrt[2], 10^logR], Blue,
   Disk[{1, 1}/Sqrt[2], 1]}, Axes -> False, Frame -> True, 
   FrameTicks -> None, ImageSize -> 400, 
   PlotRange -> {{-plotRange, plotRange}, {-plotRange, plotRange}}], 
                 {{logR, 1}, 0, 2, .01, Appearance -> "Labeled"}]

enter image description here

enter image description here

enter image description here

Update based on your comment:

Well, just change the plotRange to be fixed at 2 (to have the blue smaller circle completely in the frame. I've also increased the maximum radius from 100 to 1000. At 1000, the larger circle locally resembles a straight line.

Manipulate[plotRange = 2;
 Graphics[{Red, Disk[{-(10^logR), -(10^logR)}/Sqrt[2], 10^logR], Blue,
    Disk[{1, 1}/Sqrt[2], 1]}, Axes -> False, Frame -> True, 
    FrameTicks -> None, ImageSize -> 400, 
    PlotRange -> {{-plotRange, plotRange}, {-plotRange, plotRange}}],  
                {{logR, 1}, 0, 3, .01, Appearance -> "Labeled"}]

enter image description here

Improve this answer
$\endgroup$
7
  • $\begingroup$ Thank you for your thoughts, but Im concerned with the case where the smaller circle is show in its entirety, and the larger circle has its center far, far outside the plot range. $\endgroup$
    – GFurnas
    Apr 4, 2019 at 19:30
  • $\begingroup$ Right, showing the full smaller circle, and keeping plotRange fixed at 2, we can grow the larger circle until r=1000, when the larger circle appears as a straight line. I've adjusted the code, and added a picture. $\endgroup$
    – mjw
    Apr 4, 2019 at 20:39
  • $\begingroup$ If you keep the plotRange at 2, but you increase your logR range, you run into my problem just before logR=6. $\endgroup$
    – GFurnas
    Apr 5, 2019 at 0:38
  • $\begingroup$ Yes, I also saw that happening. Once the circle gets larger than a certain size, Mathematica has trouble drawing it. I think that if you check if Log10[r]>~4, and if so, replace your circle by a plane, this will produce a nice plot. $\endgroup$
    – mjw
    Apr 5, 2019 at 1:52
  • $\begingroup$ What I mean is find the line that best approximates the circle by fitting it to two or more points of tangency of the smaller circles. $\endgroup$
    – mjw
    Apr 5, 2019 at 1:59

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.