Skip to main content

graphics - How to quickly calculate intersections of filled curves?


I am trying to quickly calculate the intersection of polygons with more than 6,000 points. A compiled solution would be preferable.



Here is one example of the problem:


o = First[
       First[ImportString[
         ExportString[
          Style["O", Italic, FontSize -> 24, FontFamily -> "Times"], 
          "PDF"], "PDF", "TextMode" -> "Outlines"]]];

p = First[
   First[ImportString[
     ExportString[

      Style["P", Italic, FontSize -> 24, FontFamily -> "Times"], 
      "PDF"], "PDF", "TextMode" -> "Outlines"]]];

Graphics[{EdgeForm[Black], ColorData["Crayola", "Sunglow"], {o, p}}]

Another:


    Module[{a = FilledCurve[{{Line[{{2, 3}, {0.8125, 0.625}}],
      BezierCurve[{{0.6875, 0.375}, {0.375, 0.25}, {1.125, 0.25}}, 
       SplineDegree -> 2], 
      BezierCurve[{{0.8125, 0.375}, {0.9375, 0.625}}],

      Line[{{1.3125, 1.375}, {2.4375, 1.375}, {2.8125, 0.625}}],
      BezierCurve[{{2.9375, 0.375}, {2.625, 0.25}, {3.625, 0.25}}, 
       SplineDegree -> 2], 
      BezierCurve[{{3.3125, 0.375}, {3.1875, 0.625}}]},
     {Line[{{1.875, 2.5}, {1.375, 1.5}, {2.375, 1.5}}]}}]}, 
 Graphics[Table[{EdgeForm[Black], Hue[RandomReal[]], 
    Translate[Rotate[Scale[a, RandomReal[5]], RandomReal[2 Pi]], 
     RandomReal[20, {2}]]}, {30}]]]

So in the problem is: how to intersect of multiple (or two at a time) polygons (with or without) holes (and with up to 6000 points in their triangulations)?



I have tried using the Weiler–Atherton clipping algorithm but my implementation was too slow (anything relying on bitmaps is too slow). Perhaps there is a solution that uses LibraryLink to harness a standard library? I found one here http://www.cs.man.ac.uk/~toby/alan/software/gpc.html


Updates


It was suggested in the comments that GraphicsMesh be used but this is way too slow in even 100 points and doesn't handle holes:


a = Polygon@RandomReal[1, {100, 2}];
b = Polygon@RandomReal[1, {100, 2}];
AbsoluteTiming[c = Graphics`Mesh`PolygonIntersection[a, b]]
Graphics[{Blue, a, Red, b, Yellow, Polygon /@ List @@ c}]

enter image description here


Here is a sample input polygon for the letter G:



 G = Polygon[{{-0.466796, -0.0328696}, {-0.466336, 0.0186753}, {-0.463089, 
   0.0682893}, {-0.459379, 0.100181}, {-0.451495, 
   0.146241}, {-0.444693, 0.175763}, {-0.432171, 0.21827}, {-0.422278,
    0.245423}, {-0.411147, 0.271628}, {-0.39878, 0.296886}, {-0.37791,
    0.332996}, {-0.362451, 0.355885}, {-0.345756, 
   0.377826}, {-0.327823, 0.398819}, {-0.300607, 
   0.426707}, {-0.281598, 0.443668}, {-0.251786, 
   0.466663}, {-0.231046, 0.480362}, {-0.198638, 
   0.498465}, {-0.176168, 0.508902}, {-0.141165, 
   0.522112}, {-0.116964, 0.529288}, {-0.0793649, 

   0.537605}, {-0.0534337, 0.541519}, {-0.013239, 
   0.544944}, {0.0144228, 0.545596}, {0.0521431, 
   0.544603}, {0.0973423, 0.540566}, {0.140374, 0.533423}, {0.181237, 
   0.523175}, {0.212366, 0.512741}, {0.249327, 0.496903}, {0.283288, 
   0.47845}, {0.310993, 0.459561}, {0.336333, 0.438254}, {0.359309, 
   0.414528}, {0.379921, 0.388384}, {0.398168, 0.359821}, {0.414052, 
   0.328839}, {0.427571, 0.295438}, {0.438725, 0.259618}, {0.444849, 
   0.234395}, {0.449921, 0.208096}, {0.309296, 0.208096}, {0.299494, 
   0.244597}, {0.29219, 0.264834}, {0.283819, 0.283824}, {0.267496, 
   0.312703}, {0.256279, 0.328367}, {0.243996, 0.342784}, {0.235215, 

   0.351703}, {0.221153, 0.364041}, {0.206024, 0.375133}, {0.189953, 
   0.385077}, {0.161346, 0.399325}, {0.14309, 0.406478}, {0.124015, 
   0.412584}, {0.0904026, 0.420435}, {0.0691431, 0.42375}, {0.0470644,
    0.426018}, {0.00844619, 0.427471}, {-0.0284694, 
   0.425533}, {-0.0551123, 0.421535}, {-0.0892443, 
   0.412813}, {-0.121786, 0.400214}, {-0.152737, 
   0.383739}, {-0.182097, 0.363387}, {-0.209866, 
   0.339158}, {-0.235987, 0.311056}, {-0.248019, 
   0.295569}, {-0.259191, 0.279133}, {-0.269503, 
   0.261747}, {-0.278956, 0.243411}, {-0.291525, 

   0.214127}, {-0.298829, 0.193418}, {-0.305275, 
   0.171759}, {-0.313331, 0.137489}, {-0.321066, 
   0.0884734}, {-0.325362, 
   0.0356589}, {-0.32624, -0.0188127}, {-0.324105, -0.0667413}, \
{-0.319123, -0.112199}, {-0.311294, -0.155187}, {-0.300618, \
-0.195705}, {-0.294213, -0.215037}, {-0.28327, -0.242878}, \
{-0.270726, -0.269329}, {-0.25151, -0.302436}, {-0.235136, \
-0.325433}, {-0.216766, -0.346138}, {-0.196376, -0.3645}, {-0.173967, \
-0.380518}, {-0.149538, -0.394191}, {-0.123089, -0.405521}, \
{-0.104334, -0.411771}, {-0.0846818, -0.41698}, {-0.0535202, \

-0.422841}, {-0.0203389, -0.426357}, {0.0148622, -0.427529}, \
{0.0509528, -0.426065}, {0.0853497, -0.421672}, {0.118053, \
-0.414352}, {0.149062, -0.404104}, {0.171208, -0.394496}, {0.1924, \
-0.383241}, {0.212641, -0.370339}, {0.231928, -0.35579}, {0.250217, \
-0.339572}, {0.266916, -0.321406}, {0.281843, -0.301207}, {0.290811, \
-0.286611}, {0.302785, -0.263022}, {0.312987, -0.237399}, {0.321418, \
-0.209743}, {0.326054, -0.190175}, {0.331531, -0.159129}, {0.334198, \
-0.137302}, {0.336722, -0.102866}, {0.337421, -0.0787786}, {0.174296, \
-0.0787786}, {0.0111708, -0.0787786}, {0.0111708, 
   0.0393464}, {0.238983, 0.0393464}, {0.466796, 

   0.0393464}, {0.466796, -0.517529}, {0.377235, -0.517529}, \
{0.343661, -0.386923}, {0.320697, -0.411362}, {0.294314, -0.43722}, \
{0.26921, -0.459296}, {0.245385, -0.477589}, {0.222841, -0.492099}, \
{0.200503, -0.503935}, {0.174026, -0.515381}, {0.145794, -0.524995}, \
{0.108033, -0.534437}, {0.0758485, -0.539931}, {0.0331483, \
-0.544223}, {-0.0029876, -0.545596}, {-0.0362581, -0.545124}, \
{-0.0713561, -0.542341}, {-0.10544, -0.537172}, {-0.138509, \
-0.529619}, {-0.170564, -0.51968}, {-0.191371, -0.511729}, \
{-0.211727, -0.502717}, {-0.231632, -0.492646}, {-0.260644, \
-0.475551}, {-0.279422, -0.462829}, {-0.29775, -0.449047}, \

{-0.315626, -0.434205}, {-0.324396, -0.426386}, {-0.34277, \
-0.405934}, {-0.367955, -0.373398}, {-0.390289, -0.338633}, \
{-0.403595, -0.314218}, {-0.415633, -0.288813}, {-0.426404, \
-0.262417}, {-0.440185, -0.220965}, {-0.447788, -0.192092}, \
{-0.456817, -0.146926}, {-0.461252, -0.115577}, {-0.465529, \
-0.0666954}, {-0.466796, -0.0328696}}];


Comments

Post a Comment

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more