New answers tagged

6

Here's something you can start with, rinit = 6; rfactor = 0.05; rstep = .025; npoints = Floor[(rinit - rfactor rinit)/rstep]; imglist = Table[ With[{r = rinit - n rstep}, Graphics[{Thickness[.03], Circle[#, rfactor r]} & /@ CirclePoints[{0, -r + 2 (rinit - npoints rstep)}, {r, 2 π/npoints n}, 40.], ImageSize -> ...


8

Fun question. A simple but fast two-part solution which revolves around performing a 2D cross product on the coordinates of the vertices of the route to calculate the Left / Right / Straight, and then finding just those vertices at which a decision actually has to be made via their VertexDegree: Using your style def g = GridGraph[{20, 30}, EdgeWeight -> ...


25

Another way that produces a more uniform distribution of lines is to take the DistanceTransform of the text. I start with the text itself: image = Rasterize@Graphics[ Text[ Style["MUSEUM", 64, Bold, FontFamily -> "Arial"] ], ImageSize -> {360, 200}] And the use the distance transform: ImageAdjust@DistanceTransform@ColorNegate@image ...


31

Here is another way of making this kind of graphics using version 6 commands. I am not sure how valuable is this different way of making them compared to the other answers of Martin Buettner and kirma, but I do think some of the results look interesting. I was mainly motivated to explore the 3D versions of writing words with straight lines. Code Here is ...


5

FYI the algorithm for those letters is simply: Say each of the six lettes is one unit width. Draw a vertical line on the left of the screen. Take a random step to the right $0.03$ to $0.1$ units (just tune these two figures to get the look of the original; it's about $3\rightarrow10$) and draw another vertical line. You'll end up with roughly $100$ ...


37

Weighted sampling of line segments based on overlap/non-overlap ratio: Module[{reg}, reg = BoundaryDiscretizeGraphics[ Text[Style["MUSEUM", FontFamily -> "Arial"]], _Text, MaxCellMeasure -> 0.1]; Graphics@Line@ RandomSample[(With[{iarea = Quiet@Area@ BoundaryDiscretizeRegion@ ...


60

Here is a start. I'm sure others will come up with better solutions, but I think from here it's mostly down to finding a better algorithm to pick the random lines. First, we get ourselves a Region representation of the text we want to stylise (thanks to yode for simplifying this part): textRegion = DiscretizeGraphics[ Text[Style["MUSEUM", FontFamily ...


3

I remember playing around with clear plastic sheets with grid lines. Here's a way to simulate the real-time moving around of the sheets. Starting with gpap's function, change this to an image and set the alpha channel so that the white area is actually transparent. Then use GraphicsGrid to display multiple copies. Now you can move them around and rotate ...


12

I like to keep things simple, so I'll skip the letter labels, but include the lines overhanging from the grid: m = 30 (* number of mesh lines *); h = 2 (* overhang *); lins = Join[#, Map[Reverse, #, {2}]] & @ Outer[{##} &, ArrayPad[Range[-1, 1, 2/m], h, "Extrapolated"], {-1, 1}]; Table[Graphics[{AbsoluteThickness[1/100], ...


5

g = Graphics@GraphicsGroup[ Table[{Line[{{x, -5}, {x, 5}}], Line[{{-5, x}, {5, x}}]}, {x, -5, 5, .25}] ]; Manipulate[ Overlay[ Table[ Rotate[g, i θ], {i, -2, 2}], Alignment -> Center ], {θ, 0, π/12}] or g = Graphics@GraphicsGroup[ Table[{Line[{{x, -5}, {x, 5}}], Line[{{-5, x}, {5, x}}]}, {x, -5, 5, .25}] ]; ...


31

I feel that once you start with Moire patterns, there's no ending. The way I would replicate these is by making a grid into a function (like @JasonB) but also parametrise the angle of rotation into it: lines[t_, n_] := Line /@ ({RotationMatrix[t].# & /@ {{-1, #}, {1, #}}, RotationMatrix[t].# & /@ {{#, -1}, {#, 1}}} & /@ ...


23

Something like this: nlines = 30; Table[ Overlay[ Rotate[ Graphics[{ Table[{ Line[{{0, n}, {nlines, n}}], Line[{{n, 0}, {n, nlines}}]}, {n, 0, nlines}], Text[Style[#1, 18], {0, 0}, {-1, -1}, Background -> White] }, AspectRatio -> 1, PlotRangePadding -> None, ImageSize -> ...


40

I'd like to expand on Quantum_Oli's answer to give an intuitive explanation for what's happening, because there's a neat geometric interpretation. At one point in the animation it looks like there is a circle of colored dots moving about the center, this is a special case of so called hypocycloids known as Cardano circles. A hypocyloid is a curve generated ...


3

The process is quite complicated as you can see. The code creates a set of parametric equation which can give you set of discrete plots. You can choose few of them which might work (At least worked in this case). mess = 1; ParametricPlot[ Evaluate[tocurve[#, 25, t] & /@ lines[[1 ;; mess]]], {t, 0, 1}, Frame -> True, Axes -> False] gives ...


51

Edit: Added the reversal and some refinements ω = 1; posP[t_, φ_] := Sin[ω t + φ] {Cos[φ], Sin[φ]} posL[φ_] := {-#, #} &@{Cos[φ], Sin[φ]} Animate[ Graphics[{PointSize[0.02], Table[{Black, Line[posL[π i]], Hue[i], Point[posP[t, π i]]}, {i, 0, 1, 1/(3π-Abs[9.43-t])}] }, PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}} ], {t, 0, 6π, 0.2} ]



Top 50 recent answers are included