19

As you note, dealing with millions of points in Graphics will be slow to render. The usual approach for dealing with strange attractors of this sort, is to bin the resulting points and color according to the 'hits'. This can be done easily using BinCounts, e.g. for the DeJong attractor: naiveDeJong[{x_, y_}, {a_, b_, c_, d_}] := {Sin[a y] - Cos[b x], ...


9

A starting point: With[{n = 4}, Graphics[MapIndexed[{ColorData[97] @@ #2, #1} &, Append[Riffle[ Table[Rectangle[{1 - 2^(1 - k), 0}, {1 - 2^-k, 2^-k}], {k, n}], Table[Rectangle[{1 - 2^(1 - k), 2^-k}, {1, 2^(1 - k)}], {k, n}]], Rectangle[{1 - 2^-n, 0}...


8

Using an input example from the documentation page for ImageGraphics: hilbert = Import["https://i.stack.imgur.com/F9aZB.png"] smoothHilbert = CurvatureFlowFilter[MeanShiftFilter[hilbert, 8, 1/16], 2]; ig = ImageGraphics[smoothHilbert, 3] colors = Cases[ig, {a_, _FilledCurve} :> a, All] ig /. colors[[1]] -> HatchFilling[] ig /. {colors[[1]...


7

We can construct a hexagon with short edges (with length 1) and long edges (with length β >= 1) using AnglePath as follows: ClearAll[diamondcoords, diamond] diamondcoords[β_: 1] := AnglePath @ Thread[{{1, β, 1, β, 1, β}, {0, 1, 1, 1, 1, 1} 2 Pi / 6}] diamond[β_: 1] := {AbsoluteThickness[10], CapForm["Round"], MapIndexed[{{Red, Blue}[[...


7

cp = CirclePoints[6]; hexagon = {EdgeForm[Black], FaceForm[], Polygon@cp, Red, PointSize@Large, Point@cp}; Graphics[hexagon] ClearAll[translations] translations[n_] := Prepend[{0, 0}][Join @@ (Thread[{Range[-#, #, 2], -# Sqrt[3]}] & /@ Range[n])]; Graphics[Translate[hexagon, #] & /@ translations[5]] Graphics[Translate[hexagon, #] & /@ ...


6

Edit Another effect by use ParametricPlot a = 1; {p1, p2, p3} = SSSTriangle[3/2 a, a, a][[1]]; e1 = p2 - p1; e2 = p3 - p1; fig = ParametricPlot[{u, v} . {e1, e2}, {u, 0, 10}, {v, 0, 10}, MeshFunctions -> {#3 &, #4 &, #3 + #4 - 1 &}, Mesh -> {Range[0, 20, 2]}, PlotPoints -> 80, Axes -> False, Frame -> False, ...


5

Update: We can generalize the method in the original answer to make the side length a parameter: ClearAll[angleList, anglePath, hexaGon, hexTile] angleList[α_] := TriangleMeasurement[SSSTriangle[α, 1, 1], {"InteriorAngle", All}] angleList[α] {ArcCos[1 - α^2/2], ArcCos[Sqrt[α^2]/2], ArcCos[Sqrt[α^2]/2]} anglePath[α_] := FullSimplify @ ...


5

Nowadays, Polygon[] supports holes. Using george's example: hole = Polygon[MeshPrimitives[BoundaryDiscretizeGraphics[Disk[{8, 8}, 2]], 2][[1, 1]] -> {{7, 7}, {9, 7}, {9, 8}, {7, 8}}]; ContourPlot[Cos[x] + Cos[y], {x, 0, 4 π}, {y, 0, 4 π}, Epilog -> {Directive[Red, EdgeForm[Directive[Thick, Black]]], hole}]


5

Using ArrayPad + Fold + Nest + MatrixPlot ClearAll[padMat] padMat = Fold[ArrayPad[#, RotateLeft[{{0}, {Length @ #, 0}}, #2 - 1], 1 + Max @ #] &, #, {1, 2}] &; Examples: With[{n = 6}, MatrixPlot[Nest[padMat, {{1}}, n] /. x_Integer :> ColorData[97][x], ImageSize -> 600, Frame -> False, Mesh -> All]] Grid @ Partition[#, 3] & @ ...


4

We can also use affine transformations of the unit rectangle to get the desired picture: ClearAll[rectangleCoords] rectangleCoords[n_] := Module[{mod = Mod[Range[0, n - 2], 2], sy = 2^Floor[Range[0, n - 2]/2], rcoords = {{0, 0}, {1, 1}}}, Through[(Reverse @ Prepend[Identity][AffineTransform[{{{#, 0}, {0, #2}}, {##3}}] & @@@ (Transpose[{(1 + ...


2

kglr's solution is what I would have done in old Mathematica. Nowadays, I would use Riffle[]: With[{n = 5}, Graphics[Riffle[Flatten[{Circle[{0, 0}, 2 #1 - 1], Circle[{0, 0}, 2 #1]} & /@ Range[n]], {Blue, Red}, {1, -2, 2}], Axes -> True]]


2

Use BezierCurve and FilledCurve. Just for fun. c = 4/3 Tan[π/8]; pts = {{0, 1}, {c, 1}, {1, c}, {1, 0}, {1, -c}, {c, -1}, {0, -1}, {-c, -1}, {-1, -c}, {-1, 0}, {-1, c}, {-c, 1}, {0, 1}}; Graphics[{Orange, FilledCurve[{{BezierCurve[3 pts]}, {BezierCurve[ 2 pts]}, {BezierCurve[pts]}}]}]


2

pts1 = RandomReal[{}, {5, 2}]; pts2 = RandomReal[{}, {6, 2}]; region = ConvexHullMesh[Join[pts1, pts2], Axes -> True, MeshCellStyle -> {1 -> Opacity[1, Red]}, MeshCellHighlight -> {2 -> Opacity[.3, Red]}, Frame -> False]; BoundaryMeshRegion[region, MeshCellLabel -> {All -> Placed["CellIndex", "Centroid"]}]...


2

pts = CirclePoints[200]; region = ConvexHullMesh[pts, Axes -> True, MeshCellStyle -> {1 -> Opacity[1, Red]}, MeshCellHighlight -> {2 -> Opacity[.3, Red]}, Frame -> False]; We can render the labels as custom Arrowheads: mc = MeshCoordinates @ region; Show[Graphics[{Arrowheads[{{.05, 1, {Graphics[Text[Style[Round[#, .01], 12, ...


2

Here's a way to do it without converting the image into vectorized graphics. hilbert = Import["https://i.stack.imgur.com/F9aZB.png"]; smoothHilbert = CurvatureFlowFilter[MeanShiftFilter[hilbert, 12, 1/16], 2]; quantizedHilbert = ColorQuantize[smoothHilbert, {Black, White, Gray}, Dithering -> False]; whiteMask = ColorReplace[quantizedHilbert, ...


1

I just learnt from this post (Possible Bug in DiscretizeRegion with Option MaxCellMeasure) that this might be a bug in Mathematica. Using one of the solutions recommended here, I applied DiscretizeRegion with the MaxCellMeasure option to the meshed object produced by DiscretizeGraphics: mr = DiscretizeGraphics[g]; DiscretizeRegion[mr, MaxCellMeasure -> {&...


1

P2 = {{0, 1/4, 1/2, 1/4, 0, 0}, {0, 1, 0, 0, 0, 0}, {0, 0, 1/3, 0, 2/3, 0}, {0, 0, 0, 0, 0, 1}, {0, 0, 1/4, 0, 3/4, 0}, {1/4, 0, 0, 0, 3/4, 0}}; proc2 = DiscreteMarkovProcess[1, P2]; tm2 = MarkovProcessProperties[proc2, "TransitionMatrix"]; You can specify the edge labels using patterns: Graph[proc2, EdgeLabels -> {DirectedEdge[i_, j_]...


1

I was at my dullest. Or, if not that, mostly oblivious to what the In[2] command in the snippet from the question body does. Apparently it is possible to pass several LaTeX-commands within the preamble. A bit of testing shows that In[2]:=SetOptions[MaTeX, "Preamble" -> {"\\usepackage{color}", "\\definecolor{orange}...


1

We can also recursively divide the bottom-right rectangle into three rectangles as follows: ClearAll[threerects, step, rectlist] threerects = # /. Rectangle[{a_, b_}, {c_, d_}] :> {Rectangle[{a, (b + d)/2}, {c, d}], Rectangle[{a, b}, {a + c, b + d}/2], Rectangle[{(a + c)/2, b}, {c, (b + d)/2}]} &; Graphics[MapIndexed[{{Red, Green,...


1

This is addendum to cygnt's excellent answer. I thought the answer would be improved if we could see the regions the answer produced. On the other hand, I felt that it would too invasive to make such a large edit to cygnt's answer, especially since I have taken liberties with display style. I think my changes to that clarify the results. SeedRandom[42] pts1 =...


1

We can use Haar wavelets to solve this problem. First we map {y,0,10} on $(0,1)$, then equations turns to a = 1; A = 2; Pr = 65/10; M = 1; S = 1; B = 5; L = 10; Ode1 = (-A*T'[y]*f''[y] + (a + A)*f'''[y] - A*T[y]*f'''[y])/L^2 - M*(y/2*f''[y] + f'[y]) - (f'[y]*f'[y] - f[y]*f''[y])/L==0; Ode2 = 1/Pr*(T''[y] + B*T'[y]*T'[y] + B*T[y]*T''[y])/ L^2 - (M*y/...


1

An answer in the same vein as @Mr.Wizard's, but that works in more recent versions of Mathematica: data = {{{2006, 10, 1}, 10}, {{2006, 10, 15}, 12}, {{2006, 10, 30}, 15}, {{2006, 11, 20}, 20}}; dlp = DateListPlot[data]; (*get x plotrange*) xpr = First[PlotRange /. Options[dlp, PlotRange]]; (*get the frameticks that DateListPlot uses by default from the ...


Only top voted, non community-wiki answers of a minimum length are eligible