75
Based on Oleksandr's excellent design idea here is my re-implementation of his package which offers much richer set of shapes.
UPDATE from October 2019
Now my function is published in the Wolfram Function Repository what means that it is available for users of Mathematica version 12.0 or higher as ResourceFunction["PolygonMarker"]. Users of ...
43
Fortunately, Wikipedia has the answer, as long as we are content to restrict ourselves to non-intersecting closed polygons. This will probably be an acceptable limitation, given that excessively complicated plot markers tend to look slightly distracting anyway.
Because we seek an aesthetic rather than rigorously well defined result, we do not need to be ...
28
UPDATE:
The previous version of my answer worked, but did not give control on the rounding radius, nor did it fully work with as a starting point for a geometric region for further calculations. Here is a version that is still based on spline curves, but it gives full control over the corner rounding radius. It also returns a FilledCurve object that in my ...
26
Here is an alternative answer. Of course, since you answered your own question, you may not need this. But I think the following is a viable alternative that may end up looking comparable, and has additional dynamic features.
Instead of ListPlot, just use BubbleChart.
data = ConstantArray[Range[5], 4] + Range[0, 6, 2];
newData = Map[MapIndexed[Join[#2, {#, ...
21
The reason that these are called "pursuit polygons" is because they are formed from a dynamical system in which different agents pursue each other. Example:
In this image, one agent starts in each corner of the triangle. The agent starting in the lower right corner pursues the agent starting in the top corner, the agent in the top corner pursues the agent ...
19
Just wanted to add purely mathematical approach using complex mapping technique.
PolyMap[n_, z_] := z Hypergeometric2F1[1/n, 2/n, (n + 1)/n, z^n]
(* Integrate[1/(1 - ξ^n)^(2/n), {ξ, 0, z}] *)
g = GraphicsGrid[
Table[
ParametricPlot[
z = PolyMap[n, r (Cos[t] + I Sin[t])]; {Re[z], Im[z]},
{t, 0, 2 π}, PlotRange -> All, Axes -> False] /.
...
18
Late to the party~
A slight modification to make them more similar:
steps = AnglePath@Table[{r-0.015 r^2, 1.002*(2 Pi/5)}, {r, .1, 25, 0.1}];
ls=Thread[{Join[ConstantArray[Opacity@1,7],ConstantArray[Opacity@.7,13]],#}]&/@
Partition[Line/@Thread@{Most@steps,Rest@steps},20];
Graphics[{Red, ls}, Background -> Black]
Effect:
This solution focused on ...
17
Since you mention that you want to use the rounded polygon in NDSolve[] as a region, you might want to look at the following construction:
With[{r = 1/5 (* rounding radius *)},
rp = DiscretizeRegion[
ImplicitRegion[RegionDistance[
Polygon[CirclePoints[{1 - 2 Sqrt[5 - 2 Sqrt[5]] r, π/10}, 5]], {x, y}] <=
r Sqrt[(5 - ...
16
Does this do what you are looking for?
The following function takes a parameterization surface and a region region and tries to mesh it with hexagons of radius meshsize. Afterwards, it maps surface over it and creates a mesh of extruded hexagons of thickness thickness
ClearAll[hexhex]
hexhex[surface_, thickness_, meshsize_, region_] :=
Module[{hex0, ...
15
FilledCurve will do the job because it can be styled by JoinForm:
Graphics[{
EdgeForm[{JoinForm["Round"], Thickness[0.05]}],
FilledCurve[Line /@ Partition[CirclePoints[5], 2, 2, 1]]
}, PlotRange -> 1.2]
MarcoB found that this simpler version also works (see comments):
Graphics[{
EdgeForm[{JoinForm["Round"], Thickness[0.05]}],
FilledCurve[Line@...
15
Here is a more general method for producing polygons with rounded corners. Using a bit of vector algebra and trigonometry, I came up with the following:
arcgen[{p1_, p2_, p3_}, r_, n_] :=
Module[{dc = Normalize[p1 - p2] + Normalize[p3 - p2], cc, th},
cc = p2 + r dc/EuclideanDistance[dc, Projection[dc, p1 - p2]];
th = Sign[...
15
This might do the trick:
Manipulate[
ParametricPlot[
#1 {Cos[#2], Sin[#2]} & @@ {t, Log[i] Floor[t]},
{t, 0, 200}
, Background -> Black
, PlotStyle -> Purple
, Axes -> False
, PerformanceGoal -> "Quality"
, PlotRange -> {{-201, 201}, {-201, 201}}
],
{{i, 3.525}, 3.43, 3.6}
]
Since you enjoyed the animation aspect here ...
15
It's something like this:
steps = Table[{r, 1.001 (2 Pi/5)}, {r, 1, 25, 0.1}];
Graphics[{Red, Line@AnglePath[steps]}, Background -> Black]
15
1 + 4
We can discretize the rounded Polygon objects and then add the negative of the mesh through Prolog.
rm = DiscretizeGraphics[roundedPolygon[#, 0.3] & /@ MeshPrimitives[mesh, 2]]
Now there's some floating point differences in the results from roundedPolygon that seem to effect subsequent Boolean operations. We can fix this crudely merging nearby ...
15
One way to solve the case provided is to apply a DistanceFunction to FindShortestTour. Here, I apply a stiff penalty to the next point that does not share an X or Y value with the current point.
pts = {{1, 0}, {2, 0}, {2, 3}, {3, 3}, {3, 4}, {0, 4}, {0, 3}, {1,
3}, {1, 0}};
(*randomize points*)
pts = (#[[RandomSample[Range[Length@#], Length@#]]]) &[...
14
In case the undocumented internal function Region`Mesh`MeshCellNormals[meshregion, dimension] is of use to someone:
reg = BoundaryDiscretizeRegion[Ball[], PlotTheme -> "SmoothShading",
PrecisionGoal -> 1, MaxCellMeasure -> 0.1];
Graphics3D[
GraphicsComplex[
MeshCoordinates[reg],
{EdgeForm[], Thread[MeshCells[reg, 2], Polygon]},
...
14
A quick hack, essentially interpolating a point travelling at constant speed on polygon edge and averaging the position over a time interval:
With[{coords = Append[#, #[[1]]] &@RandomPolygon[{"Convex", 8}][[1]]},
With[{ip =
Interpolation[
Transpose@{Rescale@Accumulate@
Prepend[EuclideanDistance @@@ Partition[coords, 2, 1], 0],
...
13
(grabbing a lot of code from this answer)
This is just to get you started, adding in colors to the final GraphicsComplex should be pretty easy.
xyzString = ExportString[
qxyz /. {a_Integer, b___} :> {ElementData[a, "Abbreviation"], b},
"Table"];
{plot, coords, atoms} =
ImportString[
xyzString, {"XYZ", {"Graphics3D", "VertexCoordinates",
...
13
Having Area generate conditions is informative:
Area[
RegionIntersection[
Polygon[{{1, 2}, {-1, 1}, {2, 5}}],
Polygon[{{2, 4}, {1, -3}, {1, a}}]
],
GenerateConditions -> True
]
(* Out: ConditionalExpression[0, a < 2] *)
Indeed, for $a<2$ there is no intersection, so the area of the intersection is correctly $0$.
On the one hand, we ...
11
EDIT: Reported to WRI as CASE:4237867 - fixed on V12. :)
Seems like a bug in my opinion. Consider the following:
With[{poly0 = Polygon[{{0, 0}, {4, 0}, {2, 2}, {4, 4}, {0, 4}}]},
With[{poly = Transpose[IdentityMatrix[2].Transpose@#] & /@ poly0},
{poly0 === poly, Area /@ {poly0, poly}}]]
{True, {12, Area[Polygon[{{0, 0}, {4, 0}, {2, 2}, {4, 4}, {...
10
This ought to do it:
GeoGraphics[{GeoStyling[RGBColor[0.1, 0.1, 0.3], Opacity[1]],
EntityClass["AdministrativeDivision", "ContinentalUSStates"][
"Polygon"]}, GeoBackground -> None]
What was needed was a different Entity (or rather in this case an EntityClass). This is a collection of US states, so I suspect it has ...
10
I think it's worth reporting this to support. As a workaround you can numericize the polygon:
RegionMember[
Polygon[
N@{
{11,10},{10,11},{9,12},{9,13},{8,14},{7,15},{7,16},
{6,17},{6,18},{5,18},{4,18},{3,19},{2,18},{1,19},
{-1,19},{-2,19},{-3,19},{-4,19},{-5,18},{-4,18},
{-3,16},{-3,16},{-2,14},{-1,...
10
This seems like a bug. It might even be a bug I have reported in the past.
In particular, your polygon is slightly degenerate: it has {-3, 16} twice in a row, creating a zero-length edge. (This doesn't seem to be a sufficient condition alone to make RegionMember fail.)
You can remove such edges by the following replacement rule:
RegionMember[
Polygon[...
10
This is a packed array issue:
Area @ Polygon[Developer`ToPackedArray @ {{0, 0}, {4, 0}, {2, 2}, {4, 4}, {0, 4}}]
Area[Polygon[{{0, 0}, {4, 0}, {2, 2}, {4, 4}, {0, 4}}]]
This will be fixed in M12.
10
Not an anwser, yet. This is how the curve shorthening flow would act on the cells:
As you can see, the cells lose contact. So this is probably not what you are looking for, right?
Something similar can be obtained by just subdividing the polygons a little (cutting off the corners) and then using BSplineCurve:
polys = MeshPrimitives[mesh, 2][[All, 1]];
f[...
9
A shot in the dark: Reverse the orientation. Hey, it works...but I don't know why...???
Graphics3D[Polygon /@ Reverse@*pentagram /@ (vert[[#]] & /@ ind)]
A guess at what's happening. I'm not sure of the reason why things work correctly when one coordinate is the same for all vertices and do not work when the plane of the polygon is oblique. In the ...
9
H3110 customer,
thank you for contacting StackExchange coding service. We propose the following solution to your urgent problem:
pts = Table[{Cos[phi], Sin[phi]}, {phi, 0, 2 Pi - 2 Pi/5, 2 Pi/5}];
Graphics[{FaceForm[], EdgeForm[Black], Polygon[pts],
Dashed, Red,
Line[{pts[[-1]], pts[[1]] - 2*(pts[[1]] - pts[[2]])*{1, 0}, pts[[2]]}]
}]
9
xyz = Rest /@ qxyz;
Show[
ListPlot3D[xyz,
Mesh -> None,
BoxRatios -> Automatic,
Boxed -> False,
Axes -> False,
InterpolationOrder -> 1,
ColorFunction -> "Rainbow"],
NearestNeighborGraph[xyz, {All, 1.6}]]
9
Here's an extension of @C.E.'s code to non-triangular polygons - polygons taken from a Voronoi mesh of roughly equidistributed (https://mathematica.stackexchange.com/a/141215/3056) 31 points over a square. Code is awful, I didn't really have time to think.
ClearAll@PursuitPolygon;
PursuitPolygon[pts_] := Module[{vars, sols},
vars = Table[Unique[], Length@...
9
mr = MeshRegion[{{0, 0}, {1, 1}, {2, 1/2}, {2, -1/2}}, {Line[{1, 2}],
Line[{2, 3}], Line[{3, 4}], Line[{4, 1}]}];
rp = RandomPoint[mr, 50];
Show[mr, Epilog -> {Red, PointSize[Large], Point @ rp}]
See the section RandomPoint >> Scope for examples of various forms the first argument of RandomPoint can take:
Only top voted, non community-wiki answers of a minimum length are eligible
