Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphics and Visualization sorted by activeFull-range plotting with ParametricPlot?
https://community.wolfram.com/groups/-/m/t/1639076
A puzzle with ParametricPlot. The first plot masks part of the range, but nevertheless plots test points in the masked area. Can I get rid of the mask? The second plot shows no mask(s), but I don't know why it works. Can I get an informed comment? Thanks for your time,
Whiffee Bollenbach
d2 = ImplicitRegion[
0 <= x < \[Infinity] \[And] -\[Infinity] < y < \[Infinity], {x, y}];
p2 = ParametricPlot[
Through[{Re, Im}[(x + I y)^0.5]], {x, y} \[Element] d2,
PlotRange -> {{-1, 3.5}, {-3, 3}}, Frame -> True, ImageSize -> 200,
AspectRatio -> Automatic,
Epilog -> {{Blue, PointSize[0.025],
Point[{Re[(x + I y)^0.5] /. {x -> 0, y -> -10},
Im[(x + I y)^0.5] /. {x -> 0, y -> -10}}]}, {Red,
PointSize[0.025],
Point[{Re[(x + I y)^0.5] /. {x -> 0, y -> -1},
Im[(x + I y)^0.5] /. {x -> 0, y -> -1}}]}, {Black,
PointSize[0.025],
Point[{Re[(x + I y)^0.5] /. {x -> 0, y -> 1},
Im[(x + I y)^0.5] /. {x -> 0, y -> 1}}]}}];
p3 = ParametricPlot[
Through[{Re, Im}[x + (I y)^3.5]], {x, y} \[Element] d2,
PlotRange -> {{-1, 3.5}, {-3, 3}}, Frame -> True, ImageSize -> 200,
AspectRatio -> Automatic,
Epilog -> {{Blue, PointSize[0.025],
Point[{Re[(x + I y)^0.5] /. {x -> 0, y -> -10},
Im[(x + I y)^0.5] /. {x -> 0, y -> -10}}]}, {Red,
PointSize[0.025],
Point[{Re[(x + I y)^0.5] /. {x -> 0, y -> -1},
Im[(x + I y)^0.5] /. {x -> 0, y -> -1}}]}, {Black,
PointSize[0.025],
Point[{Re[(x + I y)^0.5] /. {x -> 0, y -> 1},
Im[(x + I y)^0.5] /. {x -> 0, y -> 1}}]}}];
Row[{p2, p3}]Whiffee Bollenbach2019-03-24T21:26:59ZThe Chaos Game - part II
https://community.wolfram.com/groups/-/m/t/1039030
![enter image description here][1]
A couple of weeks ago I posted my first [The Chaos Game post][2]. This will be a continuation on that, exploring some new ideas. Please make sure to read [the previous one first][3]. And once you're finished with this post, read the continuation [part III][4].
## Colors ##
The first thing I wanted to try after my previous post was coloring. Let's color each of the points based on the point it jumps towards to:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
Table[
circlepoints=N@CirclePoints[n];
seq=sequence[n,50000];
pts=Rest[FoldList[(#1+circlepoints[[#2]])/2&,RandomChoice[circlepoints],seq]];
plotdata=Transpose[{pts,seq}];
plotdata=SortBy[GatherBy[plotdata,Last],#[[1,2]]&];
plotdata=plotdata[[All,All,1]];
colors=ColorData[97]/@Range[n];
Rasterize[Graphics[{PointSize[0.001],Riffle[colors,Point/@plotdata],FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.01],Riffle[colors,Point/@circlepoints]},ImageSize->{400,400},PlotRange->1.1],"Image",ImageSize->{400,400},RasterSize->{400,400}]
,
{n,3,8}
] // Partition[#,3]& // ImageAssemble
![enter image description here][5]
This explains why the regular triangle and the square have such an unique behavior; it does not 'blend'. To be more precise: the triangle only excludes spaces, and the square exactly covers the plane again. For higher order regular polygons you see that there is overlap and that creates high and low density regions creating a bunch of patterns.
For the case of restricted jumping, like we did last time, we can also do the coloring, here the modified code:
ClearAll[CreateSequence,CreateSequenceImage]
CreateSequence[n_,steps_,choices_]:=Mod[Accumulate[RandomChoice[choices,steps-1]~Prepend~1],n,1]
CreateSequenceImage[n_,m_,choices_]:=Module[{seq,circlepoints,pts,plotdata,colors},
seq=CreateSequence[n,m,choices];
circlepoints=N@CirclePoints[n];
pts=Rest@FoldList[(#1+circlepoints[[#2]])/2&,First[circlepoints],seq];
plotdata=Transpose[{pts,seq}];
plotdata=SortBy[GatherBy[plotdata,Last],#[[1,2]]&];
plotdata=plotdata[[All,All,1]];
colors=ColorData[97]/@Range[n];
Rasterize[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.001],Riffle[colors,Point/@plotdata],PointSize[0.03],Riffle[colors,Point/@circlepoints]},ImageSize->300,PlotRange->1.1],"Image",RasterSize->{300,300}]
]
Let's have a look at all the possible jumping-subsets for hexagons:
Grid[Join @@@
Partition[{#, CreateSequenceImage[6, 10^4, #]} & /@
Subsets[Range[6], {1, \[Infinity]}], UpTo[4]], Frame -> All]
![enter image description here][6]
Some really nice patterns are now created!
## Fractional jumping ##
Up to now we have always jumped half-way, let's change that, and see what happens. I will introduce alpha the factor that we jump. Historically we always have set that to 0.5 (half-way). In my definition 0 means not moving, and 1 going all the way to the next point. The code can be easily modified:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
FactorJump[n_,m_,\[Alpha]_]:=Module[{circlepoints,seq,pts,counts,img,bg},
circlepoints=N@CirclePoints[n];
seq=sequence[n,m];
pts=FoldList[(1-\[Alpha])#1+\[Alpha] circlepoints[[#2]]&,First[circlepoints],seq];
counts=Transpose@BinCounts[pts,{-1.1,1.1,0.005},{-1.1,1.1,0.005}];
counts=Reverse[counts];
img=Image[1-counts/Max[counts]];
bg=Graphics[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],Text[NumberForm[\[Alpha],{\[Infinity],2}],{0,1.05}]},ImageSize->500,PlotRange->1.1]];
bg=Rasterize[bg,"Image",RasterSize->ImageDimensions[img],ImageSize->ImageDimensions[img]];
ImageMultiply[img,bg]
]
Note that I also included the plotting of the density of the points using **BinCounts**, which gives smooth images. Let's try it out with some new alpha:
FactorJump[3, 10^7, 0.3]
![enter image description here][7]
pretty nifty! Let's make a movie changing alpha gradually from 0 to 1:
n = 3;
imgs = Table[FactorJump[n, 3 10^5, \[Alpha]], {\[Alpha], 0, 1, 0.01}];
Export[ToString[n] <> "factor.gif", imgs, "DisplayDurations" -> 1/25.0]
![enter image description here][8]
Now for squares:
![enter image description here][9]
pentagons:
![enter image description here][10]
Of course we are not limited by our range 0 to 1, we can go beyond. (negative alpha means you run away, quickly going outside the screen, so that is not a good idea). Here for pentagons, and for alpha up to 1.8:
![enter image description here][11]
## Distance jumping ##
Rather than jumping a certain fraction, let's jump a specific distance in the direction of our point. Again we modify the code quite easily:
ClearAll[sequence,DistanceJump]
sequence[n_,m_]:=RandomChoice[Range[n],m]
DistanceJump[n_,m_,d_]:=Module[{circlepoints,seq,pts,counts,img,bg,reg,size},
circlepoints=N@CirclePoints[n];
seq=sequence[n,m];
pts=FoldList[#1+d Normalize[circlepoints[[#2]]-#1]&,First[circlepoints],seq];
size=3;
counts=Transpose@BinCounts[pts,{-size,size,size/250.0},{-size,size,size/250.0}];
counts=Reverse[counts];
reg=Quantile[Join@@counts,0.999];
img=Image[1- counts/reg];
bg=Graphics[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],Text[NumberForm[d,{\[Infinity],2}],{0,-1.05}]},ImageSize->500,PlotRange->size]];
bg=Rasterize[bg,"Image",RasterSize->ImageDimensions[img],ImageSize->ImageDimensions[img]];
ImageMultiply[img,bg]
]
Let's try it out:
DistanceJump[5, 10^6, 0.5]
![enter image description here][12]
again we see patterns emerge; let's again make a movie varying the distance d:
j=0;
Dynamic[j]
n=3;
CloseKernels[];
LaunchKernels[4];
DistributeDefinitions[DistanceJump,n]
SetSharedVariable[j];
imgs=ParallelTable[j++;DistanceJump[n,10^6,d],{d,0.1,3,0.01}];
Export[ToString[n]<>"distance.gif",imgs,"DisplayDurations"->1/25.0]
![enter image description here][13]
and for a pentagon:
![enter image description here][14]
Really nice visualization with very complicated patterns emerging from the very simple equations! Hope you enjoyed this little exploration.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=26415distance.gif&userId=73716
[2]: http://community.wolfram.com/groups/-/m/t/1025180
[3]: http://community.wolfram.com/groups/-/m/t/1025180
[4]: http://community.wolfram.com/groups/-/m/t/1047603
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=colored.png&userId=73716
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6subsetcolored.png.png&userId=73716
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=factorjumptest1.png&userId=73716
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=13373factor.gif&userId=73716
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=93424factor.gif&userId=73716
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=102355factor.gif&userId=73716
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=107365Largefactor.gif&userId=73716
[12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=distancejumptest1.png&userId=73716
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=68463distance.gif&userId=73716
[14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=26415distance.gif&userId=73716Sander Huisman2017-03-24T23:06:24Z[GIF] Symmetric Minimality (symmetric lattice trefoil knot)
https://community.wolfram.com/groups/-/m/t/1639178
![Symmetric lattice trefoil knot][1]
**Symmetric Minimality**
After I posted [_Minimal_][5] on [Mathstodon][2], [David Eppstein asked about][3] and then [found][4] a minimal lattice trefoil with 3-hedral symmetry.
Here are the (mean-centered) vertices:
symmetrictrefoil = # - Table[Mean[#], {Length[#]}] &[{{0, 0, 0},
{1, 0, 0}, {2, 0, 0}, {2, 0, 1}, {2, 1, 1}, {2, 2, 1}, {1, 2, 1},
{0, 2, 1}, {-1, 2, 1}, {-1, 2, 0}, {-1, 2, -1}, {-1, 1, -1},
{0, 1, -1}, {1, 1, -1}, {1, 1, 0}, {1, 1, 1}, {1, 1, 2},
{1, 2, 2}, {1, 3, 2}, {0, 3, 2}, {0, 3, 1}, {0, 3, 0}, {0, 2, 0}, {0, 1, 0}}];
The animation demonstrates the 3-fold symmetry which is lacking from the relatively asymmetric minimal trefoil from [_Minimal_][5] (which was just the one built into [KnotPlot][6]).
smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;
DynamicModule[{p = {-1, 0, 0}, q = Normalize[{0, 1, 1}], a, b, n, M, pl, θ,
cols = RGBColor /@ {"#404b69", "#f73859", "#283149"}},
Manipulate[
θ = 2 π/3 smootheststep[t];
{n, b} = RotationMatrix[θ, {-1, -1, 1}].# & /@ {p, q};
a = Cross[b, n];
M = {a, b};
pl = M.# & /@ symmetrictrefoil;
Graphics[{
Thickness[.0052], cols[[1]], Line[Append[#, First[#]] &[pl]],
cols[[2]], Disk[M.#, .05] & /@ Sort[symmetrictrefoil, n.#1 > n.#2 &]},
ImageSize -> 540, PlotRange -> {{-2.75, 2.75}, {-2.5, 3}},
Background -> cols[[-1]]],
{t, 0, 1}]
]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=lt20q.gif&userId=610054
[2]: https://mathstodon.xyz
[3]: https://mathstodon.xyz/@11011110/101768975543746276
[4]: https://mathstodon.xyz/@11011110/101770193254542093
[5]: https://community.wolfram.com/groups/-/m/t/1634541
[6]: https://knotplot.comClayton Shonkwiler2019-03-24T20:43:19ZPlotting two graphs together and doing manipulation
https://community.wolfram.com/groups/-/m/t/1637789
I need help in plotting two graphs together and doing some sort of manipulation.
I have a sequence:
A=ListPlot[List, PlotRange -> {{0, 201}, {-0.01, 0.01}}]
, where
List=Table[a[n], {n, 200}] and a[n_]=(-1)^n/n^2
And I need two parallel lines which can be manipulated, so I have written sth like that, but I am not sure if it is correct:
B[z_] = Plot[{z,-z}, {x, 0, 200}, Filling -> {1 -> {2}}]
And I have written such a command to plot A and B and to be able to change values of 'z':
Manipulate[Show[A, B], {z, 0.000001, 0.02}]
But unfortunately, it doesn't work. It drew only a Listplot and skipped B.
Where did I make a mistake?Kamil Sokołowski2019-03-22T20:50:22ZAnalysing wikipedia articles per language & its native speakers population
https://community.wolfram.com/groups/-/m/t/1617437
![enter image description here][1]
Today (21st of February) is UNESCO International Mother Language Day and I decided to celebrate it by exploring a bit [LanguageData][2] function.
In particular, I will show how to create the top [BubbleChart][3] using two properties of LanguageData: "NativePopulation" and "WikipediaArticleCount". The goal behind using these properties is to explore the "fitness" of languages by measuring the ratio "number of wikipedia articles"/"number native speakers" which will be represented by the size and color of the bubbles.
This way I can easily illustrate how well-protected languages have a bigger internet presence (wikipedia articles counts per native speaker). And languages from poor countries like Tigrigna from Ethiopia and Eritrea (Africa) are underrepresented in wikipedia. Interestingly languages from small European countries like Sweden, Netherlands, Scotland, Catalonia, Basque Country,… are among the highest in terms of wikipedia activity.
For this purpose, I preselected languages that have at least some native speakers alive and some wikipedia articles. Here there is a list of such languages (Disclaimer: some languages fulfilling such conditions might be missing):
languages = {"Abkhaz", "Aceh", "Adyghe", "Afar", "Afrikaans", "Akan",
"AlbanianTosk", "Amharic", "Arabic", "ArabicEgyptianSpoken",
"Aragonese", "Armenian", "Assamese", "Asturian", "Atikamekw",
"Avar", "AzerbaijaniSouth", "Bamanankan", "Banjar", "Bashkir",
"Basque", "Bavarian", "Belarusan", "Beng", "Bengali",
"BicolanoCentral", "Bishnupriya", "Bislama", "Bosnian", "Breton",
"Bugis", "Bulgarian", "BuriatChina", "BuriatRussia", "Burmese",
"BwamuCwi", "CatalanValencianBalear", "Cebuano", "Chamorro",
"Chavacano", "Chechen", "Cherokee", "Cheyenne", "ChineseGan",
"ChineseHakka", "ChineseMandarin", "ChineseMinDong",
"ChineseMinNan", "ChineseWu", "ChineseYue", "Choctaw", "Chuvash",
"Corsican", "CrimeanTurkish", "Croatian", "Czech", "Danish",
"Dimli", "Dutch", "Dzongkha", "English", "Erzya", "Ewe",
"Extremaduran", "Faroese", "FarsiEastern", "Fijian", "Finnish",
"FrancoProvencal", "French", "FrisianEastern", "FrisianNorthern",
"Friulian", "Gagauz", "Galician", "Ganda", "Georgian", "German",
"GermanPennsylvania", "Gikuyu", "Gilaki", "Greek", "Gujarati",
"HaitianCreoleFrench", "Hausa", "Hawaiian", "Hebrew", "Hindi",
"HindustaniFijian", "Hungarian", "Icelandic", "Igbo", "Ilocano",
"Indonesian", "InuktitutGreenlandic", "IrishGaelic", "Italian",
"JamaicanCreoleEnglish", "Japanese", "Javanese", "Kabardian",
"Kabiye", "KalmykOirat", "Kannada", "KarachayBalkar", "Karakalpak",
"Kashmiri", "Kashubian", "Kazakh", "KhmerCentral", "Kirghiz",
"Kolsch", "KomiPermyak", "KonkaniGoanese", "Koongo", "Korean",
"KurdishCentral", "Kwanyama", "Ladino", "Lak", "Lao", "Lezgi",
"Ligurian", "Limburgisch", "Lingala", "Lithuanian", "Livvi",
"Lombard", "LuriNorthern", "Luxembourgeois", "Macedonian",
"Maithili", "Malayalam", "Maldivian", "Maltese", "Maori", "Marathi",
"MariEastern", "MariWestern", "Marshallese", "Mazanderani",
"Minangkabau", "Mingrelian", "MirandaDoDouro", "Moksha", "Muskogee",
"NahuatlCentral", "NapoletanoCalabrese", "Narom", "Nauruan",
"Navajo", "Ndonga", "Newar", "Nyanja", "OjibwaSevern", "Osetin",
"Pampangan", "Pangasinan", "PanjabiEastern", "PanjabiWestern",
"Papiamentu", "PashtoCentral", "Piemontese", "PitcairnNorfolk",
"Polish", "Pontic", "Portuguese", "Ravula", "Romanian",
"RomanianMacedo", "RomaniVlax", "Romansch", "Rundi", "Russian",
"Rusyn", "Rwanda", "SaamiNorth", "SaintLucianCreoleFrench",
"Samoan", "Sango", "Sanskrit", "Saterfriesisch", "SaxonLow",
"Schwyzerdutsch", "Scots", "ScottishGaelic", "Serbian", "Shona",
"Sicilian", "Sindhi", "Sinhala", "Slovak", "Slovenian", "Somali",
"SorbianLower", "SorbianUpper", "SothoNorthern", "SothoSouthern",
"Spanish", "Sranan", "Sunda", "Swahili", "Swati", "Swedish",
"Tagalog", "Tahitian", "Tajiki", "Tamil", "Tatar", "Telugu",
"Tetun", "Thai", "TibetanCentral", "Tigrigna", "TokPisin", "Tongan",
"Tsonga", "Tswana", "Tulu", "Tumbuka", "Turkish", "Turkmen",
"Tuvin", "Udmurt", "Ukrainian", "Urdu", "Uyghur", "Venda",
"Venetian", "Veps", "Vietnamese", "Vlaams", "Walloon", "WarayWaray",
"Welsh", "Wolof", "Xhosa", "Yakut", "YiddishEastern", "YiSichuan",
"Yoruba", "Zeeuws", "Zulu"};
Then, using LanguageData it's quite straightforward to get the native speakers population and the number of wikipedia articles. We can also easily compute the aforementioned ratio:
bubbles =
Map[Callout[{#[[2]], #[[3]], #[[3]]/#[[2]]}, #[[1]]] &,
LanguageData[
languages, {"Name", "NativePopulation", "WikipediaArticleCount"}]]
Finally we can plot the BubbleChart:
BubbleChart[ bubbles,
ScalingFunctions -> {"Log", "Log", Automatic},
ColorFunction -> Function[{x, y, z}, Hue[Log[1 + z]]],
ColorFunctionScaling -> False,
PlotLabel -> Style["Language Wikipedia Articles Per Native Speaker", Bold, 24],
FrameLabel -> {Style["Number Of Native Speakers", 20], Style["Number Of Wikipedia Articles", 20]},
PlotTheme -> "Detailed",
ImageSize -> 800]
(See Top BubbleChart)
It's really interesting to see that most of the biggest bubbles tend to be from languages spoken in developed countries but they don't have their own state yet; i.e. Basque, Scots, Catalan, Breton...
My mother tongue is [Catalan][4] and I'm quite happy to see that it's still quite healthy (at least according to its wikipedia activity).
PS: Two years ago [@Vitaliy Kaurov][at0] wrote a really nice post about the same celebration day. You can read it [here][5].
Happy International Mother Language Day!
[at0]: https://community.wolfram.com/web/vitaliyk
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bubblechart_Languages.png&userId=95400
[2]: https://reference.wolfram.com/language/ref/LanguageData.html
[3]: https://reference.wolfram.com/language/ref/BubbleChart.html
[4]: https://en.wikipedia.org/wiki/Catalan_language
[5]: https://community.wolfram.com/groups/-/m/t/1019123Jofre Espigule2019-02-22T01:45:41ZSplineToLine function from David Park's "Presentations" add-on?
https://community.wolfram.com/groups/-/m/t/1636443
What is the definition of the function `SplineToLine` that was at one time included in David Park's *Presentations* add-on application?
The current version of that proprietary add-on, which I have, does not seem to include that function, although it has a commented-out reference to it...
DeclarePackage["PresentationsD`SplineDrawing`",{"DrawIndexedPoints","SplineToLine"}];
... but I find no `SplineDrawing` package. And the "Free Presentations" version of the add-on, which is more or less a "run-time" version of the full add-on and omits documentation, contains no reference whatsoever in its packages to `SplineToLine`.
Or, can you tell me whether the function was superceded by a similar function with a different name, or whether somehow `BSplineCurve` or another built-in *Mathematica* function does the same thing?
Note: The function is used in the paper "Visualizing complex functions with the Presentations application," by David Park and myself, which appears in *The Mathematica Journal* vol. 11 (2009). The function is used in the form, e.g.,
circuit1 = SplineToLine[{{0.342528, -0.32536}, {0.369328, 0.492018}, {0.020937,
1.3094}, {-0.809841, 1.2826}, {-1.60042,
0.43842}, {-2.2436, -0.633552}, {-2.4044, -1.47773}, {-2.458, \
-2.20131}, {-1.52002, -2.5497}, {-0.421251, -2.05391}, {0.181733, \
-1.08914}, {0.342528, -0.32536}}, Cubic, 40];
and that is in turn used within a graphic expression in the form:
Arrow[circuit1]
I note that in Park's package *DrawGraphics*, which was a predecessor to part of *Presentations*, the `SplineToLine` function was defined by:
SplineToLine[pts : {{_, _}, {_, _} ..}, mode_,
numpts_Integer?Positive] :=
Module[{sfun, n = Length[pts] - 1},
sfun = SplineFit[pts, mode];
Line[Table[sfun[t], {t, 0, n, n/(numpts - 1)}]]
]
But that used the function `SplineFit`, formerly supplied with Mathematica but no longer included. So a substitute for `SplineFit` would suffice here. (See also https://mathematica.stackexchange.com/questions/193681/how-reproduce-old-splinefit-function.)Murray Eisenberg2019-03-20T22:32:39ZThe Chaos Game - Sierpinski triangles and beyond - part I
https://community.wolfram.com/groups/-/m/t/1025180
EDIT: See also the follow up posts [here.][1] and [here][2].
![enter image description here][3]
Roughly 8-9 years ago a friend of mine told me I could make the Sierpinski triangle by starting at one of the vertices of an equilateral triangle, and then repeatedly jump half-way to one of the (randomly chosen) vertices.
## 0 memory ##
The following code will accomplish that:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
pts=N@CirclePoints[3];
pts=FoldList[(#1+pts[[#2]])/2&,RandomChoice[pts],sequence[3,10]]
Graphics[{{FaceForm[],EdgeForm[Black],RegularPolygon[3]},Red,Arrow[Partition[pts,2,1]]}]
giving:
![enter image description here][4]
If one does this 1000s of time, and only mark the viewed points, one will get:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
pts=N@CirclePoints[3];
pts=FoldList[(#1+pts[[#2]])/2&,RandomChoice[pts],sequence[3,25000]];
Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[3],PointSize[0.001],Point[pts]}]
giving:
![enter image description here][5]
Which will indeed show that by randomly choosing a vertex we can still get structure! Quite a surprise! Of course we can do this with squares, pentagons, hexagons et cetera:
ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
Table[
circlepoints=N@CirclePoints[n];
pts=FoldList[(#1+circlepoints[[#2]])/2&,RandomChoice[circlepoints],sequence[n,50000]];
Rasterize[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.001],Point[pts]},ImageSize->500,PlotRange->1.1],"Image"]
,
{n,3,8}
] // Partition[#, 3] & // ImageAssemble
giving:
![enter image description here][6]
Very neat! (apart from 4, which just gives a homogeneous distribution of points). Here I run the pentagon many many points and high resolution to get:
![enter image description here][7]
Where now the gray-color represents the density of points.
## 0 memory - restricted ##
Now we can make the dynamics a bit more interesting by not moving to any other vertex but to only specific vertices. Imagine that we are at some position p, then we always have n choices (n being the number of sides): we can jump to the vertex 1 ahead, 2 ahead, .... n ahead (same as last time).
ClearAll[CreateSequence,CreateSequenceImage]
CreateSequence[n_,steps_,choices_]:=Mod[Accumulate[RandomChoice[choices,steps-1]~Prepend~1],n,1]
CreateSequenceImage[n_,m_,choices_]:=Module[{seq,pts},
seq=CreateSequence[n,m,choices];
pts=N@CirclePoints[n];
seq=FoldList[(#1+pts[[#2]])/2&,First[pts],seq];
Rasterize[Graphics[{PointSize[0.001],Point[seq]},ImageSize->500,PlotRange->1],"Image",RasterSize->{300,300}]
]
For a 3 sided polygon (i've been told these are called triangles) we can jump 1, 2, or 3 ahead or subsets of that:
Grid[Join@@@Partition[{#,CreateSequenceImage[3,10^5,#]}&/@Subsets[Range[3],{1,\[Infinity]}],UpTo[3]],Frame->All]
![enter image description here][8]
Some interesting structure can be seen for some of the subsets.
For squares:
Grid[Join@@@Partition[{#,CreateSequenceImage[4,10^5,#]}&/@Subsets[Range[4],{1,\[Infinity]}],UpTo[4]],Frame->All]
![enter image description here][9]
and for pentagons:
Grid[Join@@@Partition[{#,CreateSequenceImage[5,10^5,#]}&/@Subsets[Range[5],{1,\[Infinity]}],UpTo[4]],Frame->All]
![enter image description here][10]
the higher the number of sides, the more subsets we can choose. The number of subsets scales as 2^n -1 (minus one because the set can not be empty; we have to jump somewhere!).
Lastly, for hexagons:
Grid[Join@@@Partition[{#,CreateSequenceImage[5,10^5,#]}&/@Subsets[Range[5],{1,\[Infinity]}],UpTo[4]],Frame->All]
![enter image description here][11]
Ok, you can try polygons with large number of sides on your own, but note that the number of subsets doubles every time.
## 1 memory - restricted ##
We can even go beyond this, and consider the position of the penultimate vertex as well:
![enter image description here][12]
We can consider 5 cases for a pentagon (or, in general, n cases). We will consider the last point to be at position 0 (or n), now the penultimate vertex could be in 5 different positions. For each of these combinations we can choose a different subset of {1,2,3,4,5}. Just to get an idea how many possibilities we now have:
the number of subsets is 2^n - 1, and we have to choose n of these, so there will be (2^n-1)^n different systems to explore:
Table[{n, (2^n - 1)^n}, {n, 3, 8}] // Grid
![enter image description here][13]
as one can see, the combination grow very quickly.
ClearAll[Stamp,CreateSequence2,CreateSequenceImage2]
CreateSequence2[n_,m_,start:{start1_,start2_},choices_]:=Module[{out,last, penultimate,new,pos2},
{penultimate,last}=out=start;
out=Reap[Do[
pos2=Mod[penultimate-last,n,1];
new=Mod[last+RandomChoice[choices[[pos2]]],n,1];
penultimate=last;
last=new;
Sow[new]
,
{m-2}
]][[2,1]];
Join[start,out]
]
Stamp[n_,choices_]:=Module[{},
Image[Normal[SparseArray[Thread[Join@@MapThread[Thread[{#1,#2}]&,{Range[Length[choices]],choices}]->1],{n,n}]]]
]
CreateSequenceImage2[n_,m_,start:{start1_,start2_},choices_]:=Module[{seq,pts,ras,stamp},
seq=CreateSequence2[n,m,start,choices];
pts=N@CirclePoints[n];
seq=FoldList[(#1+pts[[#2]])/2&,First[pts],seq];
ras=Rasterize[Graphics[{PointSize[0.001],Point[seq]},ImageSize->500,PlotRange->1],"Image",RasterSize->{300,300}];
stamp=ImagePad[Stamp[n,choices],1,Red];
ImageCompose[ras,stamp,{Center,Bottom},{Center,Bottom}]
]
Before looking at the general case, we can look at a small subset, namely one can **not** jump i ahead from the last, and j ahead from the penultimate. Here the example for i=1, and j =3:
ClearAll[JumpPos2]
JumpPos2[n_,{d1_,d2_}]:=Module[{pos},
pos=Range[n];
pos=DeleteCases[pos,d1];
DeleteCases[pos,Mod[d2+#,n,1]]&/@Range[n]
]
CreateSequenceImage2[4,10^4,{1,2},JumpPos2[4,{1,3}]]
![enter image description here][14]
Very neat structure! Of course we can try all i and j from the set {1,2,3,4}:
delta=Tuples[Range[4],2];
deltas=JumpPos2[4,#]&/@delta;
Grid[Join@@@Table[{{i,j},CreateSequenceImage2[4,10^4,{1,2},JumpPos2[4,{i,j}]]},{i,4},{j,4}],Frame->All]
![enter image description here][15]
All very neat, but it is just a small subset of the 50625 possibilities. Here let's try 64 random ones:
sc=Reverse@Subsets[Range[4],{1,\[Infinity]}];
Table[
CreateSequenceImage2[4,10^4,{1,2},RandomChoice[sc,4]]
,
{64}
] // Partition[#,8]& // ImageAssemble
![enter image description here][16]
As you can see very nice and rich structure! Notice that I 'stamped' all of them with their 'input':
CreateSequenceImage2[4, 10^4, {1, 2}, {{1, 4}, {3}, {1, 3, 4}, {1, 2, 3}}]
![enter image description here][17]
And if one looks closely (save the image and zoom), one will see the 'stamp' (or the rule) at the bottom:
![enter image description here][18]
This can be read as follows:
- The first (top) line, the white pixels are in places 1 and 4, so if the penultimate vertex was '1', move 1 or 4 places from the last vertex
- The 2nd line, the white pixel is in place 3, jump the position 3 ahead compared to last vertex
- 3rd line, white pixel at 1,3, and 4.
- 4th line 1, 2, or 3.
Basically the nth line corresponds to the position of the penultimate vertex. and the white pixels corresponds to 'allowed' number of jumps.
I'll stop here for now. There are many more ideas to explore, I'll name a few:
- <s>3D positions, 3D images</s> See below the post of Henrik!
- Anything other than regular polygons
- Have different probabilities for each of the vertices...
- Move in the perpendicular direction
- ...
See also the follow up posts [here.][19] and [here][20] and some additional visualizations below!
[1]: http://community.wolfram.com/groups/-/m/t/1039030
[2]: http://community.wolfram.com/groups/-/m/t/1047603
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=opener.png&userId=73716
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial1.png&userId=73716
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial2.png&userId=73716
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3446trial3.png&userId=73716
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial4b.jpg&userId=73716
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial5.png&userId=73716
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial6.png&userId=73716
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial7.png&userId=73716
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial8.png&userId=73716
[12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=explanation-01.png&userId=73716
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial9.png&userId=73716
[14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial10.png&userId=73716
[15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial11.png&userId=73716
[16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5983trial12.png&userId=73716
[17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial13.png&userId=73716
[18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial14.png&userId=73716
[19]: http://community.wolfram.com/groups/-/m/t/1039030
[20]: http://community.wolfram.com/groups/-/m/t/1047603Sander Huisman2017-03-04T21:41:21ZThe Chaos Game - infinitygon and Markov-chains - part III
https://community.wolfram.com/groups/-/m/t/1047603
In case you missed the first two parts check them out before reading this post:
- [The Chaos Game - Sierpinski triangles and beyond - part I][1]
- [The Chaos Game - part II][2]
Today on the menu is to go from triangles, squares, pentagon, and hexagons all the way to a regular polygon with infinite vertices: the infinitygon, commonly known as a circle. So let's do the jumping again, but this time to a random point on a circle:
ClearAll[CreateSequence,CreateSequenceImage]
CreateSequence[steps_]:=RandomReal[{0,2Pi},steps]
CreateSequenceImage[m_,\[Alpha]_]:=Module[{seq,circlepoints,pts,plotdata,colors},
seq=CreateSequence[m];
seq=Transpose[{Cos[seq],Sin[seq]}];
pts=Rest@FoldList[(1-\[Alpha])#1+\[Alpha] #2&,seq];
Rasterize[Graphics[{FaceForm[],EdgeForm[Black],Circle[{0,0},1],PointSize[0.001],Point@pts,Text[NumberForm[\[Alpha],{\[Infinity],2}],{0,1.05}]},ImageSize->300,PlotRange->1.1],"Image",RasterSize->300]
]
here alpha is the step-factor, as before. Let's vary alpha from 0.1 to 0.9:
ImageAssemble[Partition[CreateSequenceImage[30000, #] & /@ Range[0.1, 0.9, 0.1], 3]]
![enter image description here][3]
For small alpha it just tends to go the center, and for large alpha we go towards the rim, while the center remains inaccessible.
Probability density function
----------------------------
Let's have a look at PDF of the radial position of the points to see how they are distributed for a range of alpha:
ClearAll[CreateSequence,CreateSequenceHistogram]
CreateSequence[steps_]:=RandomReal[{0,2Pi},steps]
CreateSequenceHistogram[m_,\[Alpha]_,\[Delta]_:0.01]:=Module[{seq,circlepoints,pts,plotdata,colors},
seq=CreateSequence[m];
seq=Transpose[{Cos[seq],Sin[seq]}];
pts=Rest@FoldList[(1-\[Alpha])#1+\[Alpha] #2&,seq];
Histogram[Norm/@pts,{0,1,\[Delta]},"PDF",Frame->True,PlotLabel->\[Alpha],ImageSize->300,PlotRange->{{0,1},{0,4.5}}]
]
Grid[Partition[CreateSequenceHistogram[10^6,#]&/@Range[0.1,0.8,0.1],UpTo[3]]]
![enter image description here][4]
Especially the cases around 0.7 look interesting because of its unexpected shape, let's make high-resolution PDF for that alpha:
CreateSequenceHistogram[10^7, 0.7, 0.001]
![enter image description here][5]
So we can calculate this more quickly? Well, let's first look at how a single jump works:
Clear[GetOverView,GetPlot\[Theta]r,GetCDFFunc,GetPDFFunc,r]
GetOverView[b_,\[Alpha]_]:=Graphics[{Circle[],Red,Point[{b,0}],Black,Circle[{(1-\[Alpha])b,0},\[Alpha]]}]
GetPlot\[Theta]r[b_,\[Alpha]_]:=Plot[Sqrt[\[Alpha]^2+(1-\[Alpha])^2 b^2+2\[Alpha] Cos[\[Theta]](1-\[Alpha])b],{\[Theta],0,2Pi},PlotRange->{0,1},AxesLabel->{"\[Theta]","r"},Ticks->{Range[0,2Pi,Pi/2]}]
GetCDFFunc[b_, \[Alpha]_] := \[Piecewise] {
{0, r < Abs[b (1 - \[Alpha]) - \[Alpha]]},
{1, r > b (1 - \[Alpha]) + \[Alpha]},
{((\[Pi] -
ArcCos[(b^2 - r^2 - 2 b^2 \[Alpha] + \[Alpha]^2 +
b^2 \[Alpha]^2)/(2 b (-\[Alpha] + \[Alpha]^2))])/\[Pi]), \!\(
TagBox["True",
"PiecewiseDefault",
AutoDelete->False,
DeletionWarning->True]\)}
}
GetPDFFunc[b_,\[Alpha]_]:=D[GetCDFFunc[b,\[Alpha]],r]
GetPDFFunc[b_, \[Alpha]_] := \[Piecewise] {
{0, r - Abs[b (1 - \[Alpha]) - \[Alpha]] <
0 || -b + r - \[Alpha] + b \[Alpha] > 0},
{-(r/(b \[Pi] (-\[Alpha] + \[Alpha]^2) Sqrt[
1 - (b^2 - r^2 - 2 b^2 \[Alpha] + \[Alpha]^2 +
b^2 \[Alpha]^2)^2/(
4 b^2 (-\[Alpha] + \[Alpha]^2)^2)])), \!\(
TagBox["True",
"PiecewiseDefault",
AutoDelete->False,
DeletionWarning->True]\)}
}
GetPlotCDF[b_,\[Alpha]_]:=Plot[GetCDFFunc[b,\[Alpha]],{r,0,1},AxesLabel->{"r","CDF(r)"},PlotRangePadding->None]
GetPlotPDF[b_,\[Alpha]_]:=Plot[GetPDFFunc[b,\[Alpha]],{r,0,1},AxesLabel->{"r","PDF(r)"},PlotRangePadding->None]
Manipulate[GraphicsGrid[Partition[{GetOverView[b,\[Alpha]],GetPlot\[Theta]r[b,\[Alpha]],GetPlotCDF[b,\[Alpha]],GetPlotPDF[b,\[Alpha]]},2],Spacings->Scaled[.5],ImageSize->600],{{b,0.78},0,1},{{\[Alpha],0.5},0,1}]
![enter image description here][6]
the red point shown above can jump to any position of the inner circle. Top right shows the radius (from the center) as a function of theta for that circle. Bottom left shows the CDF of the possible radial positions, and bottom right the PDF of the possible radial positions. For the shown example you can see it will end up somewhere with a radius between 0.2 and 0.9, and most likely at those edges as the PDF is very large there.
Starting from an initial flat PDF of equal probability as a function of radius we can iterate that PDF to get the next PDF if we 'jump those probabilities':
ClearAll[GetMatrix,DoPDFFind]
GetMatrix[binranges_,\[Alpha]_]:=Module[{midbins,func},
midbins=MovingAverage[binranges,2];
Transpose[Table[
func=GetCDFFunc[Subscript[midbins, [[i]]],\[Alpha]];
Differences[Table[func,{r,binranges}]]
,
{i,Length[midbins]}
]]
]
DoPDFFind[\[Alpha]_,bins_Integer,n_:25]:=Module[{binwidth,initprob,prob,binranges,tmp,mat,plotdata},
binwidth=1/bins;
initprob=1/bins;
prob=N[ConstantArray[initprob,bins]];
binranges=N[Range[0,1,binwidth]];
mat=Re[GetMatrix[binranges,\[Alpha]]];
tmp=bins Nest[mat.#&,prob,n];
plotdata={MovingAverage[binranges,2],tmp}\[Transpose];
plotdata=Mean/@Partition[plotdata,2];
ListLinePlot[plotdata,PlotRange->{{0,1},{0,All}},PlotStyle->Directive[Red,Thick]]
]
Now we check if the PDF matches:
\[Alpha]=0.7;
Show[{CreateSequenceHistogram[10^7,\[Alpha],0.001],DoPDFFind[\[Alpha],500]},ImageSize->500,AxesLabel->{"r","PDF(r)"},PlotLabel->Row[{"\[Alpha]=",\[Alpha]}],Frame->True]
![enter image description here][7]
We can actually see the convergence:
ClearAll[DoPDFFindAll]
DoPDFFindAll[\[Alpha]_,bins_Integer,n_:25]:=Module[{binwidth,initprob,prob,binranges,tmp,mat},
binwidth=1/bins;
initprob=1/bins;
prob=N[ConstantArray[initprob,bins]];
binranges=N[Range[0,1,binwidth]];
mat=GetMatrix[binranges,\[Alpha]];
mat=Re[mat];
tmp=bins NestList[mat.#&,prob,n];
tmp={MovingAverage[binranges,2],#}\[Transpose]&/@tmp;
tmp=(Mean/@Partition[#,2])&/@tmp;
ListLinePlot[tmp,PlotRange->{{0,1},{0,All}},Frame->True,PlotLegends->Automatic,ImageSize->600]
]
DoPDFFindAll[0.7,500,5]
![enter image description here][8]
As you can see, it quickly converges to its final form. What we've done here is called a Markov chain, and this entire procedure could've been simplified by using the **DiscreteMarkovProcess** function in the Wolfram Language:
bins=500;
binwidth=1/bins;
initprob=1/bins;
prob=N[ConstantArray[initprob,bins]];
binranges=N[Range[0,1,binwidth]];
mat=GetMatrix[binranges,0.7];
dmp=DiscreteMarkovProcess[prob,Transpose@mat];
sd=StationaryDistribution[dmp];
sdpdf=PDF[sd,x];
plotdata=Table[{x/bins,bins Chop[sdpdf]},{x,1,bins}];
ListPlot[plotdata,Joined->True,Frame->True,ImageSize->500,PlotRange->{0,4.5}]
giving the same result:
![enter image description here][9]
That is it for now...
[1]: http://community.wolfram.com/groups/-/m/t/1025180
[2]: http://community.wolfram.com/groups/-/m/t/1039030
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ChaosGame1.png&userId=73716
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ChaosGame2.png&userId=73716
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ChaosGame3.png&userId=73716
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ChaosGame4.png&userId=73716
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10684ChaosGame5.png&userId=73716
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ChaosGame6.png&userId=73716
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ChaosGame8.png&userId=73716Sander Huisman2017-03-29T22:52:21ZCreate 9 sided dice?
https://community.wolfram.com/groups/-/m/t/1632720
G'Day Folks,
I am interested in creating a (3d printed) sudoku board...
I wanted to start with (something like) a 9-sided dice.
I think that if you 'sliced' 9 flat faces into a sphere you'd get something like it. :)
The faces would need to be the same size and equidistant; which sounds simple.
But, my mathematical knowledge isn't good enough for this.
I've been using Open SCAD for modelling; and have created a Dodecahedron (12 sided regular polyhedron); and I guess this would be OK - with 3 "black" faces.
Does anyone have any suggestions!?
cheers
SteveStephen Peter2019-03-15T05:49:34Z[GIF] Minimal (Rotating minimal lattice trefoil knot)
https://community.wolfram.com/groups/-/m/t/1634541
![Rotating minimal lattice trefoil knot][1]
**Minimal**
This shows the trefoil knot lying on the simple cubic lattice with the fewest possible number of edges (it's [a theorem of Yuanan Diao][2] that the lattice stick number of the trefoil is 24), rotated, and projected to the plane.
The 3D vertex locations are in [KnotPlot][3]. At least in the MacOS version of KnotPlot, the data is contained in the app bundle at `/Applications/KnotPlot/KnotPlot.app/Contents/Resources/special/mscl/3.1`; if you don't have KnotPlot installed, you can download the data by going to <https://knotplot.com/download/> and clicking the link to download `kpdist.tar.gz`. If you do that and then unzip to get a directory called `kpsdist`, the following commands will import the vertices and mean center:
lattice31 = Import["kpdist/special/mscl/3.1", "Table"];
lattice31 = lattice31 - Table[Mean[lattice31], {Length[lattice31]}];
As usual for animations where I want to smoothly stop and start a motion, I'm going to use the [`smootheststep` function][4]:
smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;
Here, then, is the `Manipulate` for the above animation (the giant obnoxious `Which` is to switch between different axis rotations, which I obviously could have made a little cleaner with some extra work):
DynamicModule[{p, q, a, b, n, M, θ, pl,
cols = RGBColor /@ {"#fd5f00", "#05004e", "#fbfaf1"}},
Manipulate[
Which[t < 1 || t == 4,
{p, q} = RotationMatrix[ArcTan[1/Sqrt[2]]].{Normalize[{1, 1, 0}], {0, 0, 1}};
θ = -(ArcTan[1/Sqrt[2]] + π/2) smootheststep[Mod[t, 1]];
{n, b} = RotationMatrix[θ].{p, q};,
1 <= t < 2,
{p, q} = {{0, 0, 1}, {-(1/Sqrt[2]), -(1/Sqrt[2]), 0}};
θ = (π - ArcTan[Sqrt[23 - 16 Sqrt[2]]]) smootheststep[Mod[t, 1]];
{n, b} = RotationMatrix[-θ,
N@{Sqrt[1/17 (5 + 2 Sqrt[2])], Sqrt[1/17 (7 - 4 Sqrt[2])],
Root[1 - 10 #1^2 + 17 #1^4 &, 1]}].# & /@ {p, q};,
2 <= t < 3,
{p, q} = {{-1, 0, 0}, {0, 0, 1}};
θ = 3 π/4 smootheststep[Mod[t, 1]];
{n, b} = RotationMatrix[θ].{p, q},
3 <= t,
{p, q} = {{1/Sqrt[2], 0, -(1/Sqrt[2])}, {-(1/Sqrt[2]), 0, -(1/Sqrt[2])}};
θ = (π - ArcCot[(3 - 2 Sqrt[2] + 2 Sqrt[3] + Sqrt[6])/Sqrt[
13 - 4 Sqrt[3] + 2 Sqrt[6]]]) smootheststep[Mod[t, 1]];
{n, b} = RotationMatrix[-θ,
N@{Root[1 - 156 #1^2 + 1670 #1^4 - 5148 #1^6 + 4801 #1^8 &,
1], Root[1 - 52 #1^2 + 870 #1^4 - 5044 #1^6 + 4801 #1^8 &,
2], (2 + Sqrt[2])/Sqrt[
94 - 48 Sqrt[2] + 48 Sqrt[3] - 32 Sqrt[6]]}].# & /@ {p, q};
];
a = Cross[b, n];
M = {a, b};
pl = M.# & /@ lattice31;
Graphics[
{Thickness[.004], cols[[1]], Line[Append[#, First[#]] &[pl]],
FaceForm[cols[[-1]]],
EdgeForm[Directive[Thickness[.004], cols[[2]]]],
Disk[M.#, .05] & /@ Sort[lattice31, n.#1 > n.#2 &]},
ImageSize -> 540, PlotRange -> 2.2, Background -> cols[[-1]]],
{t, 0, 4}]
]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=lt7q.gif&userId=610054
[2]: https://doi.org/10.1142/S0218216593000234
[3]: https://knotplot.com
[4]: https://en.wikipedia.org/wiki/SmoothstepClayton Shonkwiler2019-03-17T23:11:24Z[✓] Use Epilog in Manipulate?
https://community.wolfram.com/groups/-/m/t/1635365
Hello,
Epilog with "No Points" in Manipulate are not working as it should be. Does anyone know what's wrong?
data2 = {{1, 10}, {2, 11}, {3, 20}, {4, 30}};
Manipulate[
ListLinePlot[data2
, Epilog -> If[points == "No Points", None
, If[points == "Points", {PointSize[0.04], Red, Point[data2]}]
]]
, {points, {"No Points", "Points"}}
]
Thank you in advance !
Regards,....JosJos Klaps2019-03-19T01:28:52Z[✓] Draw a bell curve with specified shading under the curve?
https://community.wolfram.com/groups/-/m/t/1635282
Pardon the newbie-type question, but I'm struggling with the Mathematica syntax for a bell curve. All I want to draw is a bell curve with mean 3 and SD of 0.3, but with the region between the graph, the x-axis, -2sigma and +1 sigma shaded (where sigma = standard deviation). Can someone help?
TIA
Geoffreygeoffrey Marnell2019-03-19T01:13:46ZCreate dynamic PlotLegends?
https://community.wolfram.com/groups/-/m/t/1635563
How to add dynamic `PlotLegends` to the below code?
DynamicModule[{inputData = 0, dataSet = {}},
Column[{
InputField[Dynamic[inputData]],
Button["Plot",
AppendTo[dataSet, Table[inputData + i^j, {i, 5}, {j, 2}]]],
Spacer[5],
Dynamic@ListPlot[dataSet, Joined -> True, ImageSize -> {300}]
}]]
I would like to have a `PlotLegends` which appears only when the `Button` is pressed and `ListPlot` prints the curve, otherwise it shouldn't be visible. Also every time the `Button` is pressed `ListPlot` appends the new curve to the old one, therefore the `PlotLegends` should print the name for every printed curve, but one at the time. How to achieve that?
I spent hours on searching some guidance which could give me at least an idea of how to start, but all I found is for the static `PlotLegends`. This is why I'm asking you for a help.Kamila Szklarczyk-Marshall2019-03-19T10:59:50ZSpecify the size of points and square in RandomPoint?
https://community.wolfram.com/groups/-/m/t/1635092
The following two lines generate almost exactly what I want:
pts = RandomPoint[Rectangle[], 250]
Graphics[{ImageSize->Small,PointSize[Tiny], Point[pts]}]
However, I want to be able to specify specific sizes for the points (i.e. diameter of 1.5 microns on a square that is 1000 um x 1000 um). Is there a way to do set these parameters?
If not, is there a good function in Python that would allow me to randomly plot circles of specific diameters on squares of specified size?Claire Ruddiman2019-03-18T19:36:50Z