Hot answers tagged

25

Stealing half of evanb's answer we could do: With[{n = 3}, Graphics[{ LightGray, Disk[#, 0.5] & /@ Flatten[Table[{i, j}, {i, 0, n}, {j, 0, n}], 1], Thick, Module[{m, paths = Sort@Permutations[Join @@ ({{0, 1}, {1, 0}} & /@ Range[n])]}, m = Length@paths; Table[{Hue[(i - 1)/(m - 1)], Line@FoldList[Plus, 1/(2 Sqrt[2]) {-1 + (2 (-...


22

There are many ways to do this, modifying, improving my method or doing a completely different thing. My goal here is to show a very basic idea that should give you a start. LocatorPane and Manipulate give means of interactive addition/deletion and dragging of points in 2D plane. The problem is how to add an edge -- there has to be interaction between 2 ...


22

Graphics[{Disk[{0, 0}, 1, {0, Pi}], {Dashing[Riffle[RandomReal[.1, 25], RandomReal[.02, 25]]], HalfLine[{{0, 0}, Through[{Cos, Sin}@#]}]} & /@ Subdivide[0, Pi, 50]}, PlotRange -> {{-3/2, 3/2}, {0, 4}}, Axes -> {True, False}, AxesStyle -> Directive[Thick, Black], Ticks -> None] raylengths = {2, 10}; Graphics[{Disk[{0, 0}, 1, {0, ...


21

You can use the Graph capabilities to solve this problem. First, note that every path from $(1,1)$ to $(n,n)$ has $2n-2$ moves, so it is just a matter of using FindPath with GridGraph n = 3; g = GridGraph[{n, n}, VertexLabels -> "Name"] FindPath[g, 1, n n, {2 n - 2}, All] /. Thread[Range[n n] -> GraphEmbedding[g]] You can visualize all the paths ...


18

You could try something like this: Show[Graphics[{RandomColor[], Line[#]}] & /@ ( (* Make graphics of *) FoldList[Plus, RandomReal[{0, 0.1}, 2] + {0, 0}, #] & /@ (* Trajectories built from *) Permutations[ (* All possible orderings of *) Join @@ ({{0, 1}, {1, 0}} & /@ Range[5]) (* Five steps N and five steps E*) ] )] The RandomReal[{0,0....


17

There are a couple ways to do this! One is with ImageSize, and one is with RasterSize (probably recommended), and they have slightly different effects. Specifying ImageSize essentially scales up your graphics image first, and then rasterizes it for the PNG format. Since these lines in Mathematica have a width that is independent of the size of the image they'...


14

A solution just to show Solve can also be used directly on basis of the problem specification: With[{max = 4}, With[{coords = Table[{x[n], y[n]}, {n, 2 max - 1}]}, coords /. Solve[ (* the first and last points *) {x[1] == y[1] == 1, x[2 max - 1] == y[2 max - 1] == max, (* intermediate constrained steps *) ...


13

Edit: I made the size of the graphic generalised so you can have any size of canvas and any thickness of line As Szabolcs said in a comment, there is an example of that in the documentation. Hating to leave something without completely understanding it I translated the code from the cell (only the drawing section, not the classifier): (*Inputs for the ...


12

g[n_] := Module[{tup = Tuples[{{1, 0}, {0, 1}}, 2 n]}, Pick[tup, Total[#] == {n, n} & /@ tup]]; fun[n_] := With[{r = Accumulate /@ (Join[{{1/2, 1/2}}, #] & /@ g[n])}, Join @@ MapIndexed[ Panel[#1, ToString[#2[[1]]] <> " of " <> ToString[Length@r]] &, Table[ListPlot[#[[1 ;; j]], Joined -> True, AxesOrigin -> {0, ...


12

I've never used this function before, but BoundingRegion seems to be able to do the bulk of the work. For example, pts = {#1, #1 + #2} & @@@ RandomReal[1, {15, 2}]; Graphics[{ {EdgeForm[Black], FaceForm[LightBlue], Scale[BoundingRegion[pts, "FastStadium"], 1.1]}, Point[pts] }] There's also "FastEllipse", but for some reason it gives less ...


11

ClearAll[draw]; draw[deg_, segmentsNumber_Integer, z_] := With[{singleSegment = Polygon@{{0, 0, z}, {1, 0, 0}, {Cos[deg Degree], Sin[deg Degree], 0}}}, NestList[ GeometricTransformation[#, RotationTransform[deg Degree, {0, 0, 1}]] &, singleSegment, segmentsNumber]] Manipulate[ Graphics3D[{Red, Arrow[{{0, 0, 0}, {1.5, 0, 0}}], ...


9

Bells and whistles. Doesn't replicate the crossings of the orbits in the artwork, but it's more consistent. Colors and lighting are a bit hard to get right. ClearAll[orbit]; orbit // Options = {ColorFunction -> None}; orbit[OptionsPattern[]] := With[{cf = OptionValue[ColorFunction], rot = ( { {1, 0, 1/10}, {0, 1, 1/10} } )}, ...


9

ClearAll[zigzag] zigzag[][{{a_, b_}, {c_, d_}}, ___] := Line @ {{a, b}, {(a + c)/2, b}, {(a + c)/2, d}, {c, d}} zigzag["Vertical"][{{a_, b_}, {c_, d_}}, rest___] := Map[Reverse, zigzag[][{{b, a}, {d, c}}, rest], {2}] Examples: vlabels = "v" <> ToString @ # & /@ Range[5] edges = {1 -> 2, 1 -> 3, 3 -> 4, 3 -> 5}...


9

Something to point you in a possible direction... Updated a second time with some modifications from the original. (I clearly have too much time on my hands today and I fully recognize the silliness of the changes ;-) Grid[{{ VerticalGauge[0, {0, 2}, Background -> LightGray, GaugeMarkers -> None, ScaleDivisions -> {2, 4}, ...


8

How about this using rectangles instead of Lines? paren[t1_, t2_, p_, h_] := {Rectangle[{0, 0}, {t1, h}], Rectangle[{0, 0}, {t2 + p, t2}], Rectangle[{0, h}, {t2 + p, h - t2}]} Manipulate[ Graphics[paren[t1, t2, p, h], PlotRange -> {{0, 1}, {0, 1}}], {{t1, .1}, 0, .3}, {{t2, .1}, 0, .3}, {{p, .2}, 0, .5}, {{h, 1}, 0, 2} ]


8

One of many ways to get 3D hollow disks is to use Annulus[] to specify the region in Plot3D: p3d = Plot3D[{x + y, x/2, -y}, {x, y} ∈ Annulus[{0, 0}, {.9, 1}], Mesh -> None, MaxRecursion -> 5, PlotPoints -> 90, BoundaryStyle -> Directive[Thick, Gray], Lighting -> "Neutral", PlotStyle -> {Lighter @ Magenta, Cyan, Lighter @...


8

Animate[ r = Sqrt[1 - h^2]; phi = Sqrt[2] Pi /r; pts = Table[r {Cos[p], Sin[p], 0}, {p, 0, phi, phi/10}]; ptsc = Table[r {Cos[p], Sin[p], 0}, {p, 0, phi, phi/100}]; Graphics3D[{Line[ptsc], Line[{#, {0, 0, h}}] & /@ pts, Red, Arrow[{{0, 0, 0}, {1, 0, 0}}], Arrow[{{0, 0, 0}, {0, 1, 0}}], Arrow[{{0, 0, 0}, {0, 0, 1}}], Text["X", {1.1, ...


7

NOTE: This works on my Mathematica 10, but not tested on other versions. This method involving modification of a system file, thus is likely prohibited by the EULA. First locate the notebook corresponding to the Drawing Tools, which should be on a path similar to the following: (Mathematica root)\SystemFiles\FrontEnd\SystemResources\DrawingTools.nb ...


7

GridLines and Ticks should prove useful. Graphics[{PointSize[Large], Point[{10, 20}]}, GridLines -> {Range[0, 25], Range[0, 25]}, Ticks -> {{{5, "A"}, {10, "B"}, {15, "C"}, {20, "D"}}, Automatic}, PlotRange -> { {0, 25}, {0, 25}}, Axes -> True]


7

Have you seen the basic drawing tools? e.g. starting from Graphics[{}, GridLines -> Transpose@Table[{x, x}, {x, -10, 10, 0.08}], Frame -> True, PlotRange -> {{-1, 1}, {-1, 1}/GoldenRatio}, ImageSize -> {1000, 1000/GoldenRatio} ] and then right-clicking on the graphics and choosing "drawing tools" will give you something like what you are ...


7

ClearAll[cone, radius] radius[h_] = r /. First@ Solve[{Pi r Sqrt[r^2 + h^2] (1 + h )/2 == Pi /2, h > 0}, r, Reals]; radius[0] = 1; cone[h_] := ParametricPlot3D[{Cos[θ] (1 - z) radius[h], Sin[θ] (1 - z) radius[h], h z}, {θ, 0, Pi + h Pi}, {z, 0, 1}, PlotStyle -> None, MeshFunctions -> {#4&}, Boxed -> False, PlotRange -&...


6

Show[RegionPlot3D[1 <= x^2 + y^2 + z^2 <= 3 && (y >= x Sin[Pi/2] || y < -x Sin[Pi/2]), {x, -2, 2}, {y, -2, 2}, {z, -2, 2}, Mesh -> None, PlotPoints -> 100], Graphics3D[{Red, Sphere[{0, 0, 0}, 1]}]]


6

A start: Graphics3D[ {Specularity[White, 10], Black, Sphere[], Red, Sphere[{1, 1, 1}, .3], Blue, Sphere[{-1, -1, 1}, .3], Green, Sphere[{-1, 1, 1}, .3]}, Lighting -> {{"Point", White, {3, 0, 5}}}, Boxed -> False]


6

Second thoughts (borrowing some code from How to draw a circle in 3d on a sphere): circle3D[centre_ : {0, 0, 0}, radius_ : 1, normal_ : {0, 0, 1}, angle_ : {0, 2 Pi}] := Composition[Line, Map[RotationTransform[{{0, 0, 1}, normal}, centre], #] &, Map[Append[#, Last@centre] &, #] &, Append[DeleteDuplicates[Most@#], Last@#] &, ...


5

I'll build on David's answer (if you vote for this one, please also vote for his), since it's been a while since anyone demonstrated the excellent shadow` package on this site. We start by defining the arrows as in the previous answer: myarrow[x_, y_] := Graphics[{ Purple, Thickness[0.02], Arrowheads[.08], Arrow[{{x, y}, {x, y - 1.5}}], ...


5

Polygon is always filled (it can be filled with white). Use Circle for a "hollow" circle. r = 0.24; R = 0.25; Graphics[Circle[{0, 0}, #] & /@ {r, R}] Graphics[{EdgeForm[Black], White, Polygon[CirclePoints[#, 50]] & /@ {R, r}}] Note that since the polygons are filled, the smaller circle must be drawn on top (last) to be seen. EDIT: For a red ...


5

With Mathematica 12 a possible approach is OuterPolygon: pol = Polygon[{{{0, -1}, {1, 1}, {-1, 1}}, {{-1, -1}, {1, -1}, {1, 0}, {-1, 0}}}] Graphics[{FaceForm[], EdgeForm[{Thick, Blue}], pol}] Graphics[{FaceForm[], EdgeForm[{Thick, Blue}], OuterPolygon[pol]}]


5

We can also design a new arrow style by use Graphics arrowStyle = Graphics[{Black, Polygon[{{0, 0}, {-1, .2}, {-.8, 0}, {0, 0}}]}]; semiArrow = Arrowheads[{{0.2, 1, arrowStyle}}]; Graphics[{semiArrow, Arrow[{{0, 0}, {1, 1}}], Arrow[{{1 + .1, 1 - .1}, {.1, -.1}}]}]The above codes does not suitable for 3D,why not? It is the first attempt. Late we can ...


5

Something like: n = 50; rays = Table[{Dashing[Flatten@Table[{RandomReal[.2], .01}, {10}]], , Line[{{0, 0}, If[EvenQ[n ph/Pi], 2, RandomReal[{0.2, 0.9}]] {Sin[ph], Cos[ph]}}]}, {ph, 0, 2 Pi, Pi/n}]; Graphics[{ Disk[{0, 0}, 0.3], rays }, PlotRange -> {{-.6, .6}, {0, 1}}


5

Just a start: Manipulate[ Graphics3D[Cone[{{0, 0, h}, {0, 0, 1}}]], {h, 0, 0.9} ] And a bit more... Manipulate[ Graphics3D[{ {Opacity[0.5], Cone[{{0, 0, h}, {0, 0, 1}}]}, Line[{{1.25, 0, 0}, {0, 0, 0}}], Line[{{0, 1.25, 0}, {0, 0, 0}}], Line[{{0, 0, 1.25}, {0, 0, 0}}] }, Boxed -> False], {h, 0, 0.9} ]


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