https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Mathematics sorted by most likes. https://community.wolfram.com/groups/-/m/t/2458169 A new study group devoted to Cryptography begins next Monday! I will be leading this group daily, Monday to Friday, over the next three weeks, until February 18. The curriculum follows the upcoming Wolfram U course "[Introduction to Cryptography][1]". A list of daily topics can be found on the [Daily Study Groups][2] page. The study group sessions include videos and reading materials for the course and time for discussion and Q&A. After the study group will help you may complete the course quizzes and achieve the "Course Completion" certificate for the "[Introduction to Cryptography][3]" . > **REGISTER HERE:** > https://www.bigmarker.com/series/daily-study-group-intro-to-cryptography/series_details > **About This Study Group:** Cryptography has existed for thousands of years and currently is a fascinating topic to study because of the close ties it forges between theory and practice. It makes use of bitwise computations, advanced algebra, string operations and everything in between. The Wolfram Language, with functions that provide basic building blocks for modern cryptography, makes a great tool for hands-on understanding of various concepts. In this Study Group, you will follow video lessons from the new Wolfram U course Introduction to Cryptography and learn about the concepts, underlying math and connections to real-world scenarios. ![enter image description here][4] P.S: Don't worry if you are unable to attend every session live: the recordings will be sent out to those who registered! [1]: https://www.wolfram.com/wolfram-u/introduction-to-cryptography/ [2]: https://www.bigmarker.com/series/daily-study-group-intro-to-cryptography/series_details [3]: https://www.wolfram.com/wolfram-u/introduction-to-cryptography/ [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WolframUbanner.jpg&userId=20103 Dariia Porechna 2022-01-28T13:31:36Z https://community.wolfram.com/groups/-/m/t/3241186 A Wolfram U Daily Study Group on ["Introduction to Calculus"][1] begins on Monday, August 12, 2024. Join a cohort of fellow mathematics enthusiasts to learn about the fundamentals of calculus from the recent [Introduction to Calculus][2] ebook by John Clark and myself. Our topics will include functions and limits, differential and integral calculus, and practical applications of calculus. The study group will be led by expert Wolfram U instructor [Luke Titus][4], and I will stop by occasionally to check in with the group. It should be a lot of fun! No prior Wolfram Language experience is required. Please feel free to use this thread to collaborate and share ideas, materials and links to other resources with fellow learners. **Dates** August 12- September 6, 2024, 11am-12pm CT (4-5pm GMT) > **[REGISTER HERE][5]** ![enter image description here][6] [1]: https://www.bigmarker.com/series/introduction-to-calculus-wsg56/series_details?utm_bmcr_source=community [2]: https://www.wolfram-media.com/products/introduction-to-calculus/ [3]: https://www.wolfram.com/wolfram-u/courses/mathematics/introduction-to-calculus/ [4]: https://community.wolfram.com/web/luket [5]: https://www.bigmarker.com/series/introduction-to-calculus-wsg56/series_details?utm_bmcr_source=community [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wolframu-banner.png&userId=26786 Devendra Kapadia 2024-08-05T20:01:27Z https://community.wolfram.com/groups/-/m/t/3481794 ![enter image description here][1] Michael Trott was more than a brilliant scientist, he was a mentor, a friend, and a truly unique human being. For those of us lucky enough to work closely with him, his absence leaves a deep void. He brought an irreplaceable blend of curiosity, creativity, and humility to everything he did. Our long meetings, where we'd dive into unconventional ideas in physics and find ways to implement them in Mathematica, often stretched past hours, but no one ever minded. With Michael, even the most abstract idea could spark a new direction, a novel prototype, or an unexplored corner of science. He didn't just think outside the box, he rebuilt it entirely, quietly and kindly. His codes weren't always optimized for performance, but they were original and beautiful. I have never seen anyone so professional in prototyping novel ideas computationally; and this was our joint passion for Mathematica, as we believed it is one of the best tool, if not the best, for this purpose. One can find a few examples of Michael's style of thinking in the [Wolfram Blog][2], [Wolfram Demonstration Project][3], or [Wolfram Community][4]. He was also the author of four seminal books: "[The Mathematica GuideBooks][5]" (four volumes). He had a deep grasp of the history and architecture of Mathematica, with a passion for physics, especially quantum theory, and a genius for applying technology in unexpected ways. Michael Trott joined Wolfram Research in 1994 and was a cornerstone of the company for over 30 years. As Chief Scientist of Wolfram|Alpha, his fingerprints are on thousands of algorithms and innovations, from computational art to physical constants, from parsing human input to building bridges between theoretical physics and computation. The [Wolfram Quantum Framework][6], as a small example, would not have been possible without his support and contributions. Michael was encyclopedic in knowledge, yet endearingly humble. He read hundreds of papers, built massive daily digests on LLMs, mentored researchers across physics, math, and engineering; and still worried whether he had anything "original" to offer before a scheduled talk at the University of Vienna (see the material he'd prepared for this talk from [this link][7]; we even had a dry-run together, to discuss the content repeatedly). His presence was magnetic. He showed up early to Zoom calls (Wolfram Research has many remote employees, including myself, even before COVID pandemic) and sparked thoughtful conversation before meetings began. He didn't just build things but he shared them generously. He brought humanity to everything he touched. Whether discussing quantum fields or life under East Germany's Stasi, he made space for your story too. He helped others grow, quietly and consistently, always leading by example. Toward the end, we spoke about the multiverse; you were certain we'd meet again. In those final days, lying in your hospital bed, we found ourselves deep in conversation about the quantum-to-classical transition and nonlinearities. Thank you, Michael, for everything. You showed so many of us what it truly means to be both a scientist and a human being. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2025-06-18at9.36.32%E2%80%AFPM.png&userId=1539902 [2]: https://blog.wolfram.com/author/michael-trott/ [3]: https://demonstrations.wolfram.com/authors/michael-trott [4]: https://community.wolfram.com/web/mtrott [5]: https://www.amazon.com/stores/author/B001ITTUVM/allbooks [6]: https://resources.wolframcloud.com/PacletRepository/resources/Wolfram/%5C%20QuantumFramework/ [7]: https://amoeba.wolfram.com/index.php/s/Jbrt4q6cYTN7rC7 Mohammad Bahrami 2025-06-19T04:38:05Z https://community.wolfram.com/groups/-/m/t/1070264 [Wolfram Language][1] (WL) is a powerful multi-paradigm programing language. There is a set of common mistakes that repeatedly tend to entrap new users. **This is a call to describe such mistakes building a "black-listing" guide for novice coders.** Please consider contributing. I suggest following simple rules (with gratitude adapted from a [similar effort][2]): - One topic per answer - Focus on non-advanced uses (it is intended to be useful for beginners and as a question closing reference) - Include a self explanatory title in header style (example: "# Basic built-in function syntax"; see [syntax guide][3] ) - Explain the symptoms, the mechanism behind the scenes and all possible causes and solutions you can think of. Be sure to include a beginner's level explanation (and a more advance one too, if you can) *Please, use "**Reply**" to a specific comment for structured clarity of nested comments.* ---------- ## Table of Contents - [Basic syntax of built-in functions][4] - [Learn how to use the Documentation Center effectively][5] - [Sorting numerical data and the behavior of Sort][6] - [What does @#(%=<\[!} et cetera mean?][7] - [Consider Reap/Sow Instead of AppendTo][8] - [Alternatives to Reap/Sow][9] - [Case sensitivity and typos][10] - [Numerical vs Symbolic -- What to do when plots are blank][11] - [Import and "CurrencyTokens"][12] [1]: https://www.wolfram.com/language [2]: https://mathematica.stackexchange.com/q/18393/13 [3]: http://community.wolfram.com/groups/-/m/t/270507 [4]: http://community.wolfram.com/groups/-/m/t/1069885 [5]: http://community.wolfram.com/groups/-/m/t/1070285 [6]: http://community.wolfram.com/groups/-/m/t/1070705 [7]: http://community.wolfram.com/groups/-/m/t/1070946 [8]: http://community.wolfram.com/groups/-/m/t/1084289 [9]: http://community.wolfram.com/groups/-/m/t/1164555 [10]: http://community.wolfram.com/groups/-/m/t/1084920 [11]: http://community.wolfram.com/groups/-/m/t/1086929 [12]: http://community.wolfram.com/groups/-/m/t/1086969 Vitaliy Kaurov 2017-04-23T23:54:23Z https://community.wolfram.com/groups/-/m/t/1659553 Dear all, inspired by another [great post][1] of [@Anton Antonov][at0] and in particular there by a remark of [@Vitaliy Kaurov][at1] pointing to [the art of knitting images][2] I could not resist trying with Mathematica. Clearly - this problem is crying out loudly for **Radon transform**! ![enter image description here][3] I start by choosing some example image, convert it to inverse grayscale and perform the Radon transform. ClearAll["Global`*"] img0 = RemoveBackground[ ImageTrim[ ExampleData[{"TestImage", "Girl3"}], {{80, 30}, {250, 240}}], {"Background", {"Uniform", .29}}]; img1 = ImageAdjust[ColorNegate@ColorConvert[RemoveAlphaChannel[img0], "Grayscale"]]; {xDim, yDim} = {180, 400}; (* i.e. angles between 1\[Degree] and 180\[Degree] *) rd0 = Radon[img1, {xDim, yDim}]; ImageCollage[{img0, ImageAdjust@rd0}, Method -> "Rows", Background -> None, ImagePadding -> 10] ![enter image description here][4] Every column of the Radon image represents a different angle of projection. So next I separate these columns into (here 180) single Radon images and do an inverse Radon transform on each: maskLine[a_] := Table[If[a == n, 1, 0], {n, 1, xDim}]; maskImg = Table[Image[ConstantArray[maskLine[c], yDim]], {c, 1, xDim}]; rdImgs = rd0 maskImg; ProgressIndicator[Dynamic[n], {1, xDim}] invRadImgs = Table[{ImageApply[If[# > 0, #, 0] &, InverseRadon[rdImgs[[n]]]], -(n - 91) \[Degree]}, {n, 1, xDim}]; These data already represent the angle dependent intensities for backpropagation. Now one just has *somehow* to translate these intensities into discretely spaced lines (because this is the actual task in analogy to the above mentioned knitting ). Here is my simple attempt, which e.g. for 69° gives the following result (I am not really happy with this - there is definitely room for improvement!): ![enter image description here][5] valsAngle[invRads_] := Module[{img, angle, data, l2}, angle = Last@invRads; data = Max /@ (Transpose@*ImageData@*ImageRotate @@ invRads); l2 = Round[Length[data]/2]; data = MapIndexed[{First[#2] - l2, #1} &, data]; {Select[ Times @@@ ({#1, If[#2 > .0003, 1, 0]} & @@@ ((Mean /@ # &)@*Transpose /@ Partition[data, 5])), # != 0 &], angle} (* limiting value of 0.0003 is just empirical! *) ]; va = valsAngle /@ invRadImgs; graphicsData[va_] := Module[{u, angle}, {u, angle} = va; InfiniteLine[# {Cos[angle], -Sin[angle]}, {Sin[angle], Cos[angle]}] & /@ u]; gd = graphicsData /@ va; Graphics[{Thickness[.0003], gd}, ImageSize -> 600, PlotRange -> {{-170, 170}, {-220, 220}}] ... and the result is a bunch of lines: ![enter image description here][6] [at0]: https://community.wolfram.com/web/antononcube [at1]: https://community.wolfram.com/web/vitaliyk [1]: https://community.wolfram.com/groups/-/m/t/1555648?p_p_auth=T7A50bYl [2]: http://artof01.com/vrellis/works/knit.html [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ImageOfLines.gif&userId=32203 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img0rd0.jpg&userId=32203 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=linesample.png&userId=32203 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ImageOfLines.png&userId=32203 Henrik Schachner 2019-04-13T20:01:08Z https://community.wolfram.com/groups/-/m/t/2504513 A new study group on the topic "A Guide to Programming and Mathematics with the Wolfram Language" will begin soon. Join a cohort of fellow learners and expand your understanding of core programming topics as well as symbolic and applied mathematics functionality in the Wolfram Language with lessons by veteran instructor and developer [David Withoff][1]. A basic working knowledge of the Wolfram Language or introductory-level skill in any programming language is recommended. April 18–May 6 11am–12pm US CT (4–5pm GMT) [**REGISTER HERE**][2] ![enter image description here][3] [1]: https://www.wolfram.com/wolfram-u/instructors/withoff.html [2]: https://www.bigmarker.com/series/daily-study-group-a-guide-to-programming-and-mathematics/series_details?utm_bmcr_source=community [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WolframUBanner.jpeg&userId=130003 Abrita Chakravarty 2022-04-06T14:49:11Z https://community.wolfram.com/groups/-/m/t/326240 Triggered by the recent outbreak of Ebola India Bruckner, a pupil from Aberdeen's [St Margaret's School for Girls][1], and myself worked on a little model this summer to understand the basics of the spreading of diseases in populations and the relationship to transportation networks. The model is very basic, but shows some interesting features and is very straight forward to implement in Mathematica. When I was typing these lines I saw that Arnoud Buzing had posted something, reason enough to interrupt my typing and to check out what he had posted: [Visualizing the Ebola Outbreak][2]. I hope that my post is going to complement Arnoud's to some extent. So, my question is how the global air transport network might lead to a spreading of a disease. I will use a very standard SIR (susceptible-infected-recovered) model, which is certainly far from being ideal for Ebola; [but similar types of models are to too bad either][3]. It rather simulates an outbreak of some generic disease from which you recover. If we assumed that everyone died in an outbreak the SIR model might also be appropriate. I will introduce the equations below. I also need a list of all airports and all flight connections. On the website [Openflights.org][4] you will find all data we need. I saved the file "airports.dat" and the file "routes.dat". So that's the data. I first import the data: airports = Import["~/Desktop/airports.dat", "CSV"]; routes = Import["~/Desktop/routes.dat", "CSV"]; This is a plot of all airports in that database. GeoRegionValuePlot[Table[GeoPosition[airports[[i, {7, 8}]]] -> 1., {i, 1, Length[airports]}], PlotStyle -> PointSize[0.003], PlotRange -> 1, ImageSize -> Full] which gives ![enter image description here][5] Alright, now the routes. First, we create a list of rules for all airport IDs and their coordinates: codecoords = Table[airports[[i, 5]] -> GeoPosition[airports[[i, {7, 8}]]], {i, 1,Length[airports]}]; We then calculate the links: links = Monitor[Table[routes[[j, {3, 5}]] /. codecoords, {j, 1, Length[routes]}], ProgressIndicator[j, {1, Length[routes]}]]; and clean out missing data: linksclean = Select[links, Head[#[[1]]] == GeoPosition && Head[#[[2]]] == GeoPosition &]; Now comes a nice figure: With[{locations = RandomChoice[linksclean, 14000]}, GeoGraphics[{{Green, Opacity[0.3],AbsoluteThickness[0.0001], GeoPath[locations, "Geodesic"]}}, GeoRange -> "World", GeoProjection -> Automatic, GeoBackground -> GeoStyling["ReliefMap"], ImageSize -> {1200, 600}]] which gives ![enter image description here][6] Ok. Interestingly I can only plot 16000 max at a time. Somewhere between 16-17k the Kernel quits. That might be Integer related. Could be a limit in the programming of Geographics. Not sure. I have more than enough memory and can plot the remaining 2-3k airports in a second figure and use Show to display all. (It would be great if someone from WRI could comment.) Anyway, let's go to some modelling. The basic idea of an [SIR model][7] is that a population is modelled in three compartments Susceptibles (S), Infected (I) and Recovered (R). I will use a time-discrete model; there are continuous models around, too, and if anyone is interested I can provide the ODE model as well. Here are the three equations: sus[i_] := sus[i] = sus[i - 1] - [Rho] sus[i - 1] inf[i - 1]; inf[i_] := nf[i] = inf[i - 1] + [Rho] sus[i - 1] inf[i - 1] - [Lambda] inf[i - 1]; rec[i_] := rec[i] = rec[i - 1] + [Lambda] inf[i - 1]; The meaning of sus, inf and rec should be clear by now; they are given as percentages of the total population, their sum is 100%. The variable i represents time. $ ho$ is an infection rate and $lambda$ is a recovery rate. The infections increase with the product of susceptibles and infected. By adding the right hand sides it becomes clear that the population does not change over time. We come up with some values for the parameters and iterate: sus[1] = 0.95; inf[1] = 0.05; rec[1] = 0; [Rho] = 0.2; [Lambda] = 0.1; tcourse = Table[{sus[i], inf[i], rec[i]}, {i, 1, 100}]; The time course looks like this: ListPlot[Transpose[tcourse]] ![enter image description here][8] The monotonously decreasing function show susceptibles, the increasing function recovered, and the remaining curve the infected. We now need to do some cleaning up of the original airport data, before we proceed to a multi-airport/city model. (*Extract the names and GPS coordinates*) rawdata = Sort[Select[airports[[All, {5, 7, 8}]], #[[1]] != "" &]][[81 ;;]]; (*These are just the coordinates*) airportcoords = rawdata[[All, {2, 3}]]; (*These are just the names. *) names = rawdata[[All, 1]]; (*Here are the names to indices*) rules = MapThread[#1 -> #2 &, {names, Range[Length[names]]}]; (*The "population" is initially set to 1 for all airports, this allows us to take different airport sizes into consideration later.*) pop = Table[1., {j, 1, Length[names]}]; routesraw = Import["~/Desktop/routes.dat", "CSV"]; (*There are many links so this takes a while*) links = Select[routesraw[[All, {3, 5}]] /. rules, NumberQ[#[[1]]] && NumberQ[#[[2]]] &]; From that we now construct (a first guess at) the coupling or adjacency matrix: couplingdummy = Table[0, {i, 1, Length[names]}, {j, 1, Length[names]}]; For[k = 1, k <= Length[links], k++, couplingdummy[[links[[k, 1]], links[[k, 2]]]] = 1; couplingdummy[[links[[k, 2]], links[[k, 1]]]] = 1]; I do know about ConstantArray, but for some reason that does not work. The first line constructs a matrix full of zeros and the second adds ones where there are links. The problem is that apparently in that dataset some airports are not linked at all. We can sort them out by: indices = Select[Table[If[Total[couplingdummy[[i]]] > 0, i], {i, 1, Length[couplingdummy]}], NumberQ]; We now delete the columns and rows of the couplingdummy matrix intermed = couplingdummy[[#]] & /@ indices; transintermed = Transpose[intermed]; coupling = transintermed[[#]] & /@ indices; Again I had a much more elegant way of doing this, with the advantage that it did not work. To speed up the following calculations I use that the coupling matrix is sparse, but I like the original too much to throw it away just yet. coulinginterm = coupling; coupling = SparseArray[coulinginterm]; We adapt our "population/airport size" vector: pop = Table[1., {j, 1, Length[indices]}]; and set the following parameters: [Rho] = 0.2; [Lambda] = 0.1; Mairports = Length[indices]; [Mu] = 0.05; $\rho$ and $lambda$ are as before. Mairports is the number of airports that we model and $\mu$ is a "migration rate". It comes from the original model which we built for different cities were it describes the migration between different cities. Here is models the "propensity to fly". We now define an effective coupling matrix. It is the adjacency matrix times the population vector (i.e. people in the catchment area of the airport). In our case the vector has all ones, so it is just the adjacency matrix. It allows us later to model more general situations. meanNN = coupling.pop; When we want to model the outbreak as populations at the positions of all airports, each of which is described by an SIR model, we need to couple lots of populations, because there are lots of airports. The following uses the sparsity of the adjacency matrix to speed up the calculation. sumind = Table[Take[Flatten[ArrayRules[coupling[[k, All]]][[All, 1]]], Length[ArrayRules[coupling[[k, All]]]] - 1], {k, 1, Mairports}]; It generates a list of all airports that are coupled/linked to a given airport. Now we are ready to write down the central equations: sus[i_, j_] := sus[i, j] = (1 - [Mu]) (sus[i - 1, j] - [Rho] sus[i - 1, j] inf[i - 1, j]) + [Mu] Total[Table[sus[i - 1, sumind[[j, u]]]*pop[[sumind[[j, u]]]], {u, 1, Length[sumind[[j]]]} ] ]/meanNN[[j]]; inf[i_, j_] := inf[i, j] = (1 - [Mu]) (inf[i - 1, j] + [Rho] sus[i - 1, j] inf[i - 1, j] - [Lambda] inf[i - 1, j]) + [Mu] Total[Table[inf[i - 1, sumind[[j, u]]]*pop[[sumind[[j, u]]]], {u, 1, Length[sumind[[j]]]} ] ]/meanNN[[j]]; rec[i_, j_] := rec[i, j] = (1 - [Mu]) (rec[i - 1, j] + [Lambda] inf[i - 1, j]) + [Mu] Total[Table[rec[i - 1, sumind[[j, u]]]*pop[[sumind[[j, u]]]], {u, 1,Length[sumind[[j]]]} ] ]/meanNN[[j]]; The terms with the Total are "migration terms" that describe the travelling behaviour of the people in the catchment area of the airports. i is the time index and j labels the airports. Next come the initial conditions: For[i = 1, i <= Mairports, i++, sus[1, i] = 1.; inf[1, i] = 0.0; rec[1, i] = 0.;] sus[1, 1] = 0.95; inf[1, 1] = 0.05; rec[1, 1] = 0.0; In the catchment areas of all airports there are only susceptibles, apart from airport number 1, which will have 5% infected people. Now we can finally iterate the whole thing: tcourse = Monitor[Table[{sus[i, j], inf[i, j], rec[i, j]}, {i, 1, 500}, {j, 1,Mairports}], ProgressIndicator[i, {0, 500}]]; Great. Let's save that just in case your notebook tends to crash at this point, just l like mine did when I was playing with this. Export["~/Desktop/SIR-tcourse.csv", tcourse]; If you wish you can now plot the time course of some of the airport catchment areas: ListPlot[Flatten[Table[{tcourse[[All, j, 1]], tcourse[[All, j, 2]], tcourse[[All, j, 3]]}, {j, 1, 200}], 1], ImageSize -> Large] ![enter image description here][9] Now that is not very helpful yet. To generate nicer plots, i.e. to normalise, we first calculate the maximal number of sick people at any of the airports: maxsick = Max[Flatten[tcourse[[All, All, 2]]]]; We then generate movie frames, and go and get some coffee.... frames = Monitor[Table[GeoRegionValuePlot[Table[GeoPosition[airportcoords[[indices[[i]]]]] -> inf[k, i]/maxsick, {i, 1, Length[indices]}], PlotStyle -> PointSize[0.003], PlotRange -> 1, ImageSize -> Full,ColorFunction -> "Rainbow"], {k, 1, 300}], ProgressIndicator[k, {0, 300}]]; Actually, you might want to get another coffee when you want to export the frames: Export["~/Desktop/SIR-frames-World.gif", frames]; Alright. That gif is a bit large to embed it into this post, but you can download it from [here][10]. All I can do is show you some frames to get an idea of how this looks: ![enter image description here][11] Of course we can look at the network structure and try to understand the pattern of infections. This command is useful: CommunityGraphPlot[AdjacencyGraph[Normal[coupling]]] ![enter image description here][12] You clearly see the communities in North America, Europe and Asia. This one is also pretty: Show[TreePlot[Subgraph[grph, ConnectedComponents[grph][[1]]], Center, PlotStyle -> Directive[Gray, Opacity[0.02]]], TreePlot[Subgraph[grph, ConnectedComponents[grph][[1]]], Center, EdgeRenderingFunction -> None]] ![enter image description here][13] We have several enhancements of this. First we can easily look at different countries individually. What if an ebola patient arrives at some airport in the US? [See simulation here][14]. (Careful 50 MBs!) There is also something we can do if we want to go the the level of cities. The main problem is that the Wolfram database does not yet have data for all streets between cities. In one of the online conferences it was said that that will be introduced in some later version, which I cannot wait to play with. Until then we have to cheat. (or use some online database; I prefer cheating.) We developed a model of the spreading of a disease in Nigeria. So we could go about this like this: Clear["Global`*"] CountryData["Nigeria", "Population"] Graphics[CountryData["Nigeria", "Polygon"]] Then get city names, coords and population: names = CityData[{All, "Nigeria"}]; citypop = Table[CityData[names[[i]], "Population"], {i, 1, Length[names]}]; citycoords = Table[CityData[names[[i]], "Coordinates"], {i, 1, Length[names]}]; Here comes the cheat. Because we don't have the streets we use Delaunay triangulation: Needs["ComputationalGeometry`"] dtri = DelaunayTriangulation[citycoords]; list = {}; Table[ Do[AppendTo[list, {i, dtri[[All, 2]][[i, j]]}], {j, 1, Length[dtri[[All, 2]][[i, All]]]}], {i, 1, Length[dtri]}]; coupling = Table[0, {i, 1, Length[names]}, {j, 1, Length[names]}]; For[i = 1, i < Length[list] + 1, i++, coupling[[list[[i]][[1]], list[[i]][[2]]]] = 1;] coulinginterm = coupling; coupling = SparseArray[coulinginterm]; which gives the following network Graphics[Join[ Table[Circle[citycoords[[i]], 0.02], {i, 1, Length[names]}], DeleteCases[ Flatten[Table[ If[coupling[[i, j]] == 1, Line[{citycoords[[i]], citycoords[[j]]}]] , {i, 1, Length[names]}, {j, 1, i}], 1], Null]]] ![enter image description here][15] The point in the middle corresponds to the airport where it all starts; then come its neighbours and then their neighbours etc. You could now animate this and change the colours to see how the disease spreads through the different layers. It would be nice if someone could implement that. There are obviously some problems, i.e. "streets" leaving the country etc, but the general idea should work. The rest is quite the same as before: (*Paramters*) [Rho] = 0.2; [Lambda] = 0.1; Mcities = Length[names]; [Mu] = 0.05; (*Initiation*) For[i = 1, i <= Mcities, i++, sus[1, i] = 1.; inf[1, i] = 0.0; rec[1, i] = 0.;] (*Starting Outbrake at the following city*) sus[1, 1] = 0.95; inf[1, 1] = 0.05; rec[1, 1] = 0.0; meanNN = coupling.citypop; sumind = Table[ Take[Flatten[ArrayRules[coupling[[k, All]]][[All, 1]]], Length[ArrayRules[coupling[[k, All]]]] - 1], {k, 1, Mcities}]; sus[i_, j_] := sus[i, j] = (1 - [Mu]) (sus[i - 1, j] - [Rho] sus[i - 1, j] inf[i - 1, j]) + [Mu] Total[ Table[sus[i - 1, sumind[[j, u]]]*citypop[[sumind[[j, u]]]], {u, 1, Length[sumind[[j]]]} ] ]/meanNN[[j]]; inf[i_, j_] := inf[i, j] = (1 - [Mu]) (inf[i - 1, j] + [Rho] sus[i - 1, j] inf[i - 1, j] - [Lambda] inf[i - 1, j]) + [Mu] Total[ Table[inf[i - 1, sumind[[j, u]]]*citypop[[sumind[[j, u]]]], {u, 1, Length[sumind[[j]]]} ] ]/meanNN[[j]]; rec[i_, j_] := rec[i, j] = (1 - [Mu]) (rec[i - 1, j] + [Lambda] inf[i - 1, j]) + [Mu] Total[ Table[rec[i - 1, sumind[[j, u]]]*citypop[[sumind[[j, u]]]], {u, 1, Length[sumind[[j]]]} ] ]/meanNN[[j]]; This time we try to work in parallel: LaunchKernels[]; tcourse = ParallelTable[{sus[i, j], inf[i, j], rec[i, j]}, {i, 1, 500}, {j, 1, Mcities}]; // AbsoluteTiming (There is something strange here. This ran in MMA9 in 6.3 seconds- I still have data from the course I taught last year. MMA10 takes ages. After the installation of MMA10 also MMA9 seems to take longer 43 seconds. Is this a bug report?). Note that this time the population sizes of the cities are taken into account and are relevant. If you run Manipulate[ Graphics[{Line[Flatten[CountryData["Nigeria", "Coordinates"], 1]], Join[Table[{ RGBColor[tcourse[[t, i, 2]], tcourse[[t, i, 1]], tcourse[[t, i, 3]]], Disk[citycoords[[i]], 0.1]}, {i, 1, Length[names]}]]}], {t, 1, 500, 1}] or poly = Graphics[Polygon[Flatten[CountryData["Nigeria", "Coordinates"], 1]], ImagePadding -> None]; Animate[ImageSubtract[ Graphics[ListDensityPlot[ Join[{{4, 3.25, 0}, {4, 14, 0}, {14, 3.25, 0}, {14, 14, 0}}, Table[{citycoords[[k]][[1]], citycoords[[k]][[2]], 1. - tcourse[[t, k, 1]]}, {k, 1, Mcities}]], InterpolationOrder -> 3, ColorFunction -> "Rainbow", PlotRange -> All, Frame -> False, PlotRangePadding -> None]], poly], {t, 1, 500, 1}, DefaultDuration -> 20.] or better infmax = Max[tcourse[[All, All, 2]]]; frames = Table[ ImageSubtract[ Graphics[ ListDensityPlot[ Join[{{4, 3.25, 0}, {4, 14, 0}, {14, 3.25, 0}, {14, 14, 0}}, Table[{citycoords[[k]][[1]], citycoords[[k]][[2]], tcourse[[t, k, 2]]/infmax}, {k, 1, Mcities}]], InterpolationOrder -> 3, ColorFunction -> "Rainbow", PlotRange -> All, Frame -> False, PlotRangePadding -> None, ColorFunctionScaling -> False]], poly], {t, 1, 500, 6}]; you get nice animations like this one: ![enter image description here][16] I have noticed that Nigeria needs to be rotated, but I hope that the idea becomes clear. I am also aware that there are many flaws in this. SIR is certainly not the best way forward to model Ebola. Any population dynamicist and/or health expert can certainly come up with an endless list of problems. The network is not perfect. For more serious applications we actually use models for the cities, i.e. street connections among close cities and airport connections among countries etc. The problem is that if we simulate between 200-20000 cities per country plus the airports, a standard laptop runs into trouble. On the bright side, we have a cluster on which this kind of larger simulations work just fine. Hope that you like this anyway, Marco [1]: http://www.st-margaret.aberdeen.sch.uk [2]: http://community.wolfram.com/groups/-/m/t/325956 [3]: http://mtbi.asu.edu/files/Mathematical_Models_to_Study_the_Outbreaks_of_Ebola.pdf [4]: http://openflights.org/data.html [5]: /c/portal/getImageAttachment?filename=Airportsall.jpg&userId=48754 [6]: /c/portal/getImageAttachment?filename=Airports-world.jpg&userId=48754 [7]: http://en.wikipedia.org/wiki/Compartmental_models_in_epidemiology [8]: /c/portal/getImageAttachment?filename=SingleSIR.jpg&userId=48754 [9]: /c/portal/getImageAttachment?filename=SIR-airportstcourse.jpg&userId=48754 [10]: https://www.dropbox.com/s/9y6d16z82qjw261/SIR-frames.gif?dl=0 [11]: /c/portal/getImageAttachment?filename=SIR-airports-frames.jpg&userId=48754 [12]: /c/portal/getImageAttachment?filename=Airports-CommNetwork.jpg&userId=48754 [13]: /c/portal/getImageAttachment?filename=SIR-networkrings.jpg&userId=48754 [14]: https://www.dropbox.com/s/0qwgmi7ks8dpsjh/SIR-USA-frames.gif?dl=0 [15]: /c/portal/getImageAttachment?filename=SIR-Nigerianetwork.jpg&userId=48754 [16]: /c/portal/getImageAttachment?filename=SIR-movie.gif&userId=48754 Marco Thiel 2014-08-22T20:18:58Z https://community.wolfram.com/groups/-/m/t/2451238 ![enter image description here][1] ![enter image description here][2] An [n-gonal antiprism or n-antiprism][3] is a polyhedron composed of two parallel copies of an n-sided polygon, connected by a band of 2n triangles. Grid@Transpose@Table[PolyhedronData[{"Antiprism",k},#]&/@{"Image","Net"},{k,3,7}] ![enter image description here][4] To form an almost perfect ring of 4-antiprisms firstly we need a set of vertices and coordinates: offset =#+{0,0,Sqrt[1-1/4 Sec[π/8]^2]+4.05} &/@(2PolyhedronData[{"Antiprism",4}, "VertexCoordinates"]); face={{5,1,2,6},{8,4,7,3},{6,4,8},{2,7,4},{1,3,7},{5,8,3},{6,2,4},{2,1,7},{1,5,3},{5,6,8}}; Then we can make 13 copies: Graphics3D[ Table[GraphicsComplex[RotationMatrix[k 2 Pi/13,{0,1,0}].#&/@offset,Polygon/@face],{k,0,12}], Boxed-> False, SphericalRegion->True] ![13 antiprisms][5] This is **not** exact, but it's very close. ![13 antiprisms side][6] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=antiptism4.gif&userId=11733 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=asdf43qasdf.jpg&userId=11733 [3]: https://mathworld.wolfram.com/Antiprism.html [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sdfq3dfag43.jpg&userId=11733 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=13anti.jpg&userId=21530 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=13antiside.jpg&userId=21530 Ed Pegg 2022-01-20T20:12:49Z https://community.wolfram.com/groups/-/m/t/2411604 A new study group devoted to Differential Equations begins next Monday! A list of daily topics can be found on our [Daily Study Groups][1] page. This group will be led by one of our outstanding Wolfram certified instructors, Luke Titus, and will meet daily, Monday to Friday, over the next three weeks. Luke will share the excellent lesson videos created by him for the upcoming Wolfram U course "[Introduction to Differential Equations][2]". Study group sessions include time for exercises, discussion and Q&A. This study group will help you achieve the "Course Completion" certificate for the "Introduction to Differential Equations" course after you complete the course quizzes. Sign up: [Study group registration page][3] [1]: https://www.wolfram.com/wolfram-u/special-event/study-groups/ [2]: https://www.wolfram.com/wolfram-u/introduction-to-differential-equations/ [3]: https://www.bigmarker.com/series/daily-study-group-intro-to-differential-equations/series_details?utm_bmcr_source=community Devendra Kapadia 2021-11-22T16:35:30Z https://community.wolfram.com/groups/-/m/t/1569707 ![a very prime pencil][1] I just got a set of these pencils, from [Mathsgear][2]. The number printed on it is prime, and will remain so as you sharpen the pencil from the left, all the way down to the last digit, 7. Here is a recursive construction of all such *truncatable primes*. TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[9]))} ]; TruncatablePrimes[p_Integer] := {} The one on the pencil is the largest one, In[7]:= Take[Sort[Flatten[TruncatablePrimes /@ Range[9]]], -5] Out[7]= { 9918918997653319693967, 57686312646216567629137, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137} [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_20181212_120939.jpg&userId=143131 [2]: https://mathsgear.co.uk/products/truncatable-prime-pencil Roman Maeder 2018-12-12T12:01:36Z https://community.wolfram.com/groups/-/m/t/2825207 A Wolfram U Daily Study Group on Introduction to Probability begins on **February 27th 2023**. Join me and a group of fellow learners to learn about the world of probability and statistics using the Wolfram Language. Our topics for the study group include the characterisation of randomness, random variable design and analysis, important random distributions and their applications, probability-based data science and advanced probability distributions. The idea behind this study group is to rapidly develop an intuitive understanding of probability for a college student, professional or interested hobbyist. A basic working knowledge of the Wolfram Language is recommended but not necessary. We are happy to help beginners get up to speed with Wolfram Language using resources already available on Wolfram U. Please feel free to use this thread to collaborate and share ideas, materials and links to other resources with fellow learners. > [**REGISTER HERE**][1] ![enter image description here][2] ![Wolfram U Banner][3] [1]: https://www.bigmarker.com/series/daily-study-group-probability-wsg36/series_details [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=NormalConvergence.gif&userId=11733 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=banner.jpg&userId=2823613 Marc Vicuna 2023-02-07T01:15:38Z https://community.wolfram.com/groups/-/m/t/2342501 *MODERATOR NOTE: related resource function can be found here* https://resources.wolframcloud.com/FunctionRepository/resources/MandelbrotSetRemap ---- ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=frac_hero.jpg&userId=20103 [2]: https://www.wolframcloud.com/obj/17f4f067-3491-4d7a-bf84-5601782ad11e Mark Greenberg 2021-08-14T14:58:17Z https://community.wolfram.com/groups/-/m/t/2914219 A Wolfram U daily study group covering the implementation of Mathematica and Wolfram Language for mathematics topics ranging from function visualization to upcoming calculus functionality begins on May 22, 2023 and runs through June 1. This study group will run on weekdays from 11:00AM–12:00PM Central US time. (We will not meet on Memorial Day, May 29, and Friday sessions will start at 10:30AM for extra review time.) > [**REGISTER HERE**][1]. I hope to see you there! This study group is a fantastic way to learn about the amazing mathematical capabilities built into Wolfram Language. We will cover a *very* broad variety of topics, including but not limited to function visualization, linear algebra and graph theory, differential equations and even fascinating topics such as number theory and asymptotics. Several sessions will be led by the Wolfram developers who work on the mathematics functionality that we'll be covering! While this study group is aimed at mathematics students at roughly the graduate level, **no prior Wolfram Language experience is necessary**—the first day will be dedicated to getting you up to speed with the language itself. As usual, we will have questions, study materials, quizzes along the way to help you master the subject matter and functionality. ![enter image description here][2] [1]: https://www.bigmarker.com/series/daily-study-group-math-research-wsg40/series_details?utm_bmcr_source=community "REGISTER HERE" [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WolframUBanner%281%29%281%29.jpg&userId=1711324 Arben Kalziqi 2023-05-03T23:07:29Z https://community.wolfram.com/groups/-/m/t/148287 I am an artist, drawing and working with 3d. Since long time, I am missing a method to form realistic folds and wrinkles into virtual sheets of paper, metal or cloth. I found some attempts within 3d-programs, but I never saw something that was not very limited or looked like rubber. Because it is so easy at reality, but so difficult at the computer, I think there is just little mathematical base.First of all: Could anybody tell me, what field of mathematics this is? [img=width: 800px; height: 1132px; ]/c/portal/getImageAttachment?filename=Folds-01.jpg&userId=145842[/img] [img=width: 800px; height: 1132px; ]/c/portal/getImageAttachment?filename=Folds-02.jpg&userId=145842[/img] Dietmar Klein 2013-11-03T23:03:23Z https://community.wolfram.com/groups/-/m/t/1025046 This is a photo of some tree branches that I took at the park today. [<img src="http://community.wolfram.com//c/portal/getImageAttachment?filename=20170304_121322.jpg&userId=38370" width="500">](http://community.wolfram.com//c/portal/getImageAttachment?filename=20170304_121322.jpg&userId=38370) It looks like a fractal, and a nice candidate for measuring the fractal dimension. Here's how we can do that in Mathematica. Let us start by binarizing the image. img = Import["~/Downloads/20170304_121322.jpg"]; bin = LocalAdaptiveBinarize[ImageAdjust[img, 0.3], 200, {0.9, 0, 0}]; [<img src="http://community.wolfram.com//c/portal/getImageAttachment?filename=bin.png&userId=38370" width="300">](http://community.wolfram.com//c/portal/getImageAttachment?filename=bin.png&userId=38370) For a better result, I increased the contrast slightly (`ImageAdjust`), then used local adaptive binarization. This method chooses a different binarization threshold for each pixel based on its neighbourhood. It helps preserve small branches while avoiding including any part of the clouds (the weather was not very good today). The easiest way to measure fractal dimension is *box counting*: overlay a square grid, and see how many of the grid cells contain some of the object in the image. What would we get if the object is a line? Table[ Rasterize[Graphics[{Antialiasing -> False, Line[{{0, 0}, {1, 1}}]}], ImageSize -> 256, RasterSize -> k], {k, 2^Range[2, 8]} ] // ListAnimate The box count would double (i.e. multiply by $2^1$) every time the box size is halved. What would happen if the object is a filled disk? Table[ Rasterize[Graphics[{Antialiasing -> False, Disk[]}], ImageSize -> 256, RasterSize -> k], {k, 2^Range[2, 8]} ] // ListAnimate The box count would quadruple (i.e. multiply by $2^2$) every time the box size is halved. In general, for a $d$-dimensional object the box count $n$ is proportional to power $-d$ of the box size $l$:  $n \sim l^{-d}$. For some objetcs, $d$ can be a fractional (non-integer) number. Such objects are called fractals. Let's try it on the tree photo! First, let us choose box sizes in pixels so that an integer number of boxes fit in the image. seq = Reverse[Intersection @@ Divisors /@ ImageDimensions[img]] (* {1008, 504, 336, 252, 168, 144, 126, 112, 84, 72, 63, 56, 48, 42, 36, 28, 24, 21, 18, 16, 14, 12, 9, 8, 7, 6, 4, 3, 2, 1} *) Luckily, the image width and height had many small prime factors in common, so we have many box sizes to work with. Now let us count boxes. {width, height} = ImageDimensions[img] (* {3024, 4032} *) result = { width/#, Last@First@ImageLevels@Image[ BlockMap[Min, ImageData[bin], {#, #}], "Bit"] } & /@ seq; // AbsoluteTiming (* {9.79212, Null} *) [BlockMap][1] will partition the image data into blocks (i.e. boxes) and take the minimum of each. Since black pixels are represented by 0 and white pixels by 1, we get 0 only for those boxes that contain at least one black pixel, i.e. they contain a bit of the tree branches. `BlockMap` was introduced in Mathematica 10.2. Those using older versions can substitute `BlockMap[f, matrix, {k,k}]` by `Map[f, Partition[matrix, {k,k}], {2}]`. [ImageLevels][2] counts how many times each possible pixel value appears in an image. To make sure that the only possible pixel values are 0 and 1, we create a `"Bit"` image. Is the result really a power function of the form $n = \text{(const.)} l^d$? The easy way to test this is to plot it on a log-log plot. Power functions appear as a line when plotted on a logarithmic scale. ListLogLogPlot[result] ![enter image description here][3] The slope of the line will give the exponent: $\ln n = \ln\text{(const.)} + d \ln l$. fm = LinearModelFit[Log[result], {1, x}, x] It is about $\approx 1.85$. Despite the thick tree trunks, the image of the branches behaves as a *lower-than-two dimensional* structure. Let us plot the power law fit together with the original data: plot = Show[ Plot[fm[x], {x, Log[result[[1, 1]]], Log[result[[-1, 1]]]}, PlotStyle -> Black], ListLogLogPlot[result, PlotStyle -> Red], AspectRatio -> 1, Axes -> False, Frame -> True ] ![enter image description here][4] You can see that the power law is a pretty good fit. The slope of the curve is more or less the same at all size scales. This indicates a certain kind of scale invariance in the image. Indeed, it is clear that if we magnified a small part of the image, it would look similar to the whole: small branches are miniature copies of larger ones. This is a characteristic feature of fractals. To visualize the box counting method, we can show the series of finer and finer box-grids: sz = 252; imgs = Image[BlockMap[Min, ImageData[bin], {#, #}], "Bit"] & /@ seq Scaling them to the same size and animating them show how they approach the original image better and better: imgs = If[First@ImageDimensions[#] > sz, ImageResize[Image[#, Real], sz], (* downscale as grayscale *) ImageResize[#, sz, Resampling -> "Nearest"]] & /@ imgs; (* upscale as bitmap *) frm = Table[ ImageCompose[ImageResize[img, 252], {im, 0.5}], {im, imgs}]; ListAnimate[frm] ![enter image description here][5] We can show the animation alongside the scaling plot: frames = Table[ Row[{ Show[plot, AspectRatio -> 1, ImageSize -> 336, Epilog -> {AbsolutePointSize[10], Red, Point@Log[result[[i]]]}], Image[frm[[i]], Magnification -> 1] }], {i, Length[imgs]}]; With some extra styling it looks like this: ![enter image description here][6] I hope you enjoyed this small demonstration! [1]: http://reference.wolfram.com/language/ref/BlockMap.html [2]: http://reference.wolfram.com/language/ref/ImageLevels.html [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=plot.png&userId=38370 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=plot2.png&userId=38370 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif.com-gif-maker.gif&userId=38370 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=animation.gif&userId=38370 Szabolcs Horvát 2017-03-04T17:33:57Z https://community.wolfram.com/groups/-/m/t/1599255 *MODERATOR NOTE: a submission to computations art contest, see more:* https://wolfr.am/CompArt-22. *The complete notebook of this post is attached at the end.* ---------- ![starry_night_over_water][1] This cute little animation came to me while I was playing with [Dynamic](http://reference.wolfram.com/language/ref/Dynamic.html). I found it very lovely so would like to share it to the community. So I wanted to know how many Dynamic primitives my 5 years old laptop can handle in one scene (i.e. [Graphics](http://reference.wolfram.com/language/ref/Graphics.html)). This is my first test scenario: With[{num = 40, aspRatio = 3, splineOrder = 10}, With[{freqSet = Rescale @ Range @ num}, DynamicModule[ { y = 0, pts = Thread[ { Rescale[Range @ num, {1, num}, aspRatio * {-1, 1}], 0 } ] }, DynamicWrapper[ Graphics[ { { CapForm @ "Round", Hue[0.58, 0.45, 0.55], AbsoluteThickness @ 5, BSplineCurve[ Dynamic @ pts, SplineDegree -> splineOrder, SplineKnots -> "Unclamped" ] }, { CapForm @ "Round", JoinForm @ "Round", GrayLevel @ 0.7, AbsoluteThickness @ 3, Line @ Dynamic @ pts }, { Hue[0.1, 0.5, 0.95, 0.7], AbsolutePointSize @ 20, Point @ Dynamic @ pts } }, PlotRange -> {aspRatio * {-1, 1}, {-1.2, 1.2}}, PlotRangePadding -> Scaled[0.05], ImageSize -> 600 ], y = Clock[{0, Infinity, 1 / 60}]; pts = MapIndexed[ Function[ {freq, idx}, { Rescale[idx[[1]], {1, num}, aspRatio * {-1, 1}], Sin[2 * Pi * freq * y] } ], freqSet ] ] ] ] ] ![helix][2] Not too shabby! The motions are smooth, the points align perfectly. Now this one I call *Everlasting Tide*: With[ { winding = 8, corners = 6, radius = 1, shift = 2, gravityPower = 10, freqPower = 1 / 3, symmetricDir = Pi / 2 }, With[{num = (corners * winding) + 1}, With[ { ω = Function[Rescale[#, {0, 1}, {0.2, 1}]][ Function[ x, Plus[ 1, -(TriangleWave[{0, 2}, (x - 1) * x] ^ (1 / freqPower)) ] ][Rescale @ Range @ num] ] }, DynamicModule[ { t = 0, pts = Function[ Function[ {θ, d}, (radius + d) * {Cos[θ], Sin @ θ} ]@@@# ][ Thread[ { Rescale[ Range @ num, {1, num}, {0, winding * 2 * Pi} + symmetricDir ], 0 } ] ] }, DynamicWrapper[ Graphics[ { { Hue[0.1, 0.2, 0.9], AbsoluteThickness @ 1, Map[ Circle[{0, 0}, #]&, Rescale[ Rescale[Range[100]] ^ gravityPower, {0, 1}, {Max[0, radius + -shift], radius + shift} ] ] }, {GrayLevel @ 0.85, Line @ Dynamic @ pts}, { Hue[0, 0.55, 0.85, 0.3], AbsolutePointSize @ 10, Point @ Dynamic @ Most @ pts }, { GrayLevel[0.7, 0.4], EdgeForm @ {Black, AbsoluteThickness @ 1}, FilledCurve[BSplineCurve[Dynamic @ Most @ pts, SplineClosed -> True]] } }, PlotRange -> ((radius + shift) * {{-1, 1}, {-1, 1}}), PlotRangePadding -> Scaled[0.05], Axes -> False, ImageSize -> 500 ], t = Clock[{0, Infinity, 1 / 60}]; pts = Function[ Function[ {θ, d}, (radius + d) * {Cos[θ], Sin @ θ} ]@@@# ][ MapIndexed[ Function[ {ω, idx}, { Rescale[ idx[[1]], {1, num}, {0, winding * 2 * Pi} + symmetricDir ], Times[ shift, Subtract[ 2 * ((Sin[ω * t] + 1) / 2) ^ gravityPower, 1 ] ] } ], ω ] ] ] ] ] ] ] ![everlasting_tide][3] But back to my most beloved animation at the beginning. I introduce to you: *Starry Night over Water*. A winter night is painted by the palette of the cosmos. Each star whirls in its own delight, unknowingly lighting the quiet water below in a blurry expansion of everchanging hues. I'm really thrilled how such a lovely piece of animation can be created with a little more than 2000 character in code, and the background optimization done by *Mathematica* to make it run so smoothly. P.S. I have used explicit iteration here instead of [Clock](http://reference.wolfram.com/language/ref/Clock.html) to drive the animation, so that this small quiet world shall be immune from a certain overflow ;) **Things to try:** Playing with the parameters of the outmost [With](http://reference.wolfram.com/language/ref/With.html), say, changing `baseColorFunc` to `ColorData["SunsetColors"]`, or changing `aspRatio` to match your monitor then menu-bar > **Window** > **FullScreen**. With[ { (* time step of the animation: *) Δt = 0.05, (* number of stars: *) n = 50, (* maximal size of stars: *) radius = 1.5, (* color theme: *) baseColorFunc = ColorData @ "StarryNightColors", (* geometric properties of the water region: *) waterBase = -2, waterWidth = 5, (* geometric properties of the final drawing: *) height = 20, imageHeight = 700, aspRatio = 1 / GoldenRatio }, With[{width = (height + (-waterBase) + waterWidth) / aspRatio}, Apply[ Function[{θ0, ω, expr}, DynamicModule[{θ = θ0}, DynamicWrapper[ Deploy @ Activate @ expr, θ = Mod[θ + ω * Δt, 2 * Pi] ] ] ] ][ Module[{cx, cy, Δx, Δy, color}, { RandomReal[{0, Pi / 2}, n], RandomReal[{0.3, 1}, n], Inactive[Graphics][ { (* background: *) Module[ { h = height + (-waterBase) + waterWidth + 10, w = width + 5, m = 10, Δh, cf = baseColorFunc /* (Darker[#, 0.5]&) }, Δh = h / m; MapThread[ Function[ {y, c1, c2}, { EdgeForm[], Polygon[ { {-5, y}, {w, y}, {w, y + Δh}, {-5, y + Δh} }, VertexColors -> Map[cf, {c1, c1, c2, c2}] ] } ], { Function[ Rescale[ #, {1, m}, {(waterBase + -waterWidth) - 5, height + 5 + -Δh} ] ][Range @ m], Most[ Function[0.4 * (1 + -#) ^ 5][Rescale[Range[m + 1]]] ], Rest[ Function[0.4 * (1 + -#) ^ 5][Rescale[Range[m + 1]]] ] } ] ], (* foreground: *) MapThread[ Function[ {cpos, r, idx, shineShift}, {cx, cy} = cpos; {Δx, Δy} = cpos + -({width, height} / 2); (* base color: *) color = baseColorFunc[ 1 + -Norm[{Δx, Δy} / {width, height}, 1] ]; { (* one star: *) { FaceForm @ {Append[(* transparency: *) 0.7][color]}, EdgeForm[], Polygon[ Map[ Function[cpos + r * #], { {0, 1}, {Cos[Dynamic[θ[[idx]]]], 0}, {0, -1}, {-Cos[Dynamic[θ[[idx]]]], 0} } ] ] }, (* and its reflection: *) { RightComposition[ ColorConvert[#, "LAB"]&, (* adjust luminance according to shineShift (i.e. y-coords): *) ReplacePart[ 1 -> RightComposition[ Function[Cos[2 * #]], Function[((# + 1) / 2) ^ 0.5], Function[ Rescale[ #, {0, 1}, Plus[ (* mean luminance, lower the brighter: *) Rescale[shineShift, {-1, 1}, {0.4, 0.7}], (* luminance variation range, lower the more active: *) {-1, 1} * Rescale[shineShift, {-1, 1}, {0.3, 0.03}] ] ] ] ][Dynamic[θ[[idx]]]] ], (* transparency: *) Append[Function[Rescale[#, {-1, 1}, {0.2, 0.6}]][shineShift]] ][color], (* abstract blur: *) AbsoluteThickness[Function[Rescale[#, {-1, 1}, {10, 1}]][shineShift]], Line[ Function[ { { Plus[ cx, -(Times[ r, Times[ #3, Times[ 1 / 2, 1 + -(#2 * Cos[Dynamic[θ[[idx]]]]) ] ] ]) ], # }, { Plus[ cx, Times[ r, Times[ #3, (1 / 2) * (1 + #2 * Sin[Dynamic[θ[[idx]]]]) ] ] ], # } } ][ (* y-coords: *) Plus[ waterBase, waterWidth * ((Rescale[shineShift, {-1, 1}] ^ 0.5) - 1) ], (* variance: *) Rescale[shineShift, {-1, 1}, {1, 0.2}], (* mean radius: *) Rescale[shineShift, {-1, 1}, {2, 4}] ] ] } } ], { Join[ ScalingTransform[{3 / 4, 3 / 4}, {width, height} / 2][ RandomPoint[Rectangle[{0, 0}, {width, height}], Ceiling[n / 4]] ], RandomPoint[ Rectangle[{0, 0}, {width, height}], (n + -Ceiling[n / 4]) - 1 ], {{width, height} / 2} ], radius * RandomReal[{1 / height, 1}, n], Range @ n, RandomReal[{-1, 1}, n] } ] }, PlotRange -> {{0, width}, {waterBase + -waterWidth, height}}, PlotRangePadding -> {{2, 2}, {1, 2}}, Background -> None, ImageSize -> {Automatic, imageHeight} ] } ] ] ] ] ![starry_night_over_water][4] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1243starry_night_over_water.gif&userId=93201 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=helix32.gif&userId=93201 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=everlasting_tide_64.gif&userId=93201 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=starry_night_over_water.gif&userId=93201 Silvia Hao 2019-01-26T04:26:46Z https://community.wolfram.com/groups/-/m/t/2098696 deleted David Ameneyro 2020-10-21T05:05:58Z https://community.wolfram.com/groups/-/m/t/3092960 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ddfg54w6yhrsdfz_small.jpg&userId=20103 [2]: https://www.wolframcloud.com/obj/ae4bbae7-001f-4f1d-99a0-78c3168be06c Ed Pegg 2023-12-29T15:46:35Z https://community.wolfram.com/groups/-/m/t/138400 I must confess I hardly ever doubted that if there exists a “[b][url=http://www.oftenpaper.net/sierpinski.htm]Sierpinski Triangle page to end most Sierpinski Triangle pages[/url][/b]” it would be written with help of Mathematica. These 10 quoted words is how Antonio Marquez-Raygoza titled his recent [b][url=http://www.oftenpaper.net/sierpinski.htm]blog article[/url][/b]. That did sound intriguing and I must assure you, in my opinion, it lives up completely to the title. Knowing Antonio as an [b][url=http://demonstrations.wolfram.com/author.html?author=Antonio+Marquez-Raygoza]author of two exquisite Demonstrations[/url][/b] and as a skillful Mathematica programmer with a fine taste for visual design and elegance, I put everything aside and started reading. And was it a feast for my eyes! Some of you may know me as a person who enjoys coding visually appealing graphics. So imagine my joy in encountering something like this beautiful image and discovering it was produced with just a few lines of code (like so many things in Mathematica): [mcode]draw[v_, df_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, df[0, r], depth - 1] & /@ ps]]; Graphics[{EdgeForm[White], Opacity[.4], RGBColor[.4, 1, 1], ring[0., 1., n]}]]; Show[(*repeatedly draw to cover more possibilities*) draw[4, (#1 + #2)/RandomChoice[Prime[Range[4]]] &, RandomChoice[{.1, 1.5} -> {2, 3}]] & /@ Range[20], Background -> Black, ImageSize -> 600][/mcode] [img=width: 600px; height: 626px;]/c/portal/getImageAttachment?filename=siertron12.png&userId=11733[/img] The article produced a massive viral hurricane of event on Internet. Let me share a few bits I picked up in the aftermath.This post mad quite a boom on Reddit getting front-paged on several sub-Reddits: [list] [*][b][url=http://redd.it/1o1yd2]Reddit Programming: 1154 upvotes 149 comments[/url][/b] [*][b][url=http://redd.it/1o0dpo]Reddit Math: 387 upvotes 35 comments[/url][/b] [*][b][url=http://redd.it/1o9b9f]Reggit Biology: 60 upvotes 15 comments[/url][/b] [*][b][url=http://redd.it/1o87gm]Reddit Todayilearned: 50 upvotes 9 comments[/url][/b] [*][b][url=http://redd.it/1o2ydp]Reddit Fractals: 20 upvotes 2 comments[/url][/b] [/list]It was also posted on a few other Reddits. The article also [b][url=https://news.ycombinator.com/item?id=6516114]scored 327 points and 55 comments on Hacker News a.k.a. Ycombinator[/url][/b]. There was of course an ocean of tweets, Facebook posts, and other social media sharing. I was very happy to see such famous Twitter feeds as [b][url=https://twitter.com/TopologyFact/status/387909293842116608]Topology Fact sharing the link to the article[/url][/b]: [url=https://twitter.com/TopologyFact/status/387909293842116608][img=width: 465px; height: 281px;]/c/portal/getImageAttachment?filename=2013-10-14_03-03-08.png&userId=11733[/img][/url] This is an [b][url=https://tweetreach.com/share/reports/345f97fed534d7c341a57e1893515873aea838fc]impact report of only tweets containing exact title of the article[/url][/b], of course they were many more tweets with different content: [url=https://tweetreach.com/share/reports/345f97fed534d7c341a57e1893515873aea838fc][img=width: 747px; height: 561px;]/c/portal/getImageAttachment?filename=2013-10-14_03-21-09.png&userId=11733[/img][/url] And I must acknowledge the jazzy frisky humor of the piece – not once it made me smile in amazement or simply LOL. For example a quote: [quote]Note the cow cannot be spherical or it will roll off.[/quote]was also posted on Reddit in comments and earned more than 100 voteups! But it is not [i][b]just[/b][/i] funny - if you are not a physicist you probably will miss that this is most probably a reference to the [b][url=https://en.wikipedia.org/wiki/Spherical_cow]spherical cow joke[/url][/b]. I do not want to give you any spoilers but the poetic cow part with phrases like [quote]I think this is the first time I'm jealous of a cow. [/quote]is actually about built in Mathematica cow that can be accessed simply as[mcode]ExampleData[{"Geometry3D", "Cow"}][/mcode]and with some further brilliant codding you will get this and agree eventually that a spherical cow would indeed roll off: [img=width: 640px; height: 640px;]/c/portal/getImageAttachment?filename=siercowsine1.png&userId=11733[/img] Sometimes on a book cover one may find quotes from critics acclaiming the book. I think what critics to a book, Reddit and Hacker News are to a blog. This is why I would like to post here just a few URL-linked comments from Reddit and Hacker News discussions of the post as my small token of appreciation for the fascinating reading. [quote][url=http://www.reddit.com/r/programming/comments/1o1yd2/the_sierpinski_triangle_page_to_end_most/ccoler8]“This is fantastic. Not sure if it's programming or math, or even art, but it's the kind of thing the world needs more of. Pure exploration.”[/url] [url=http://www.reddit.com/r/programming/comments/1o1yd2/the_sierpinski_triangle_page_to_end_most/ccoecwo]“The sheer brilliance of the author had me reeling. I wish more of the posts here were like this…”[/url] [url=http://www.reddit.com/r/programming/comments/1o1yd2/the_sierpinski_triangle_page_to_end_most/ccohuxe]“I understand none of this, but it's beautiful and inspiring.”[/url] [url=http://www.reddit.com/r/programming/comments/1o1yd2/the_sierpinski_triangle_page_to_end_most/cco8a5m]“I enjoyed the [b]cowsine[/b] graph”[/url] [url=http://www.reddit.com/r/programming/comments/1o1yd2/the_sierpinski_triangle_page_to_end_most/ccqi3lc]“Hell, that's just a built-in cow Mathematica has.”[/url] [url=http://www.reddit.com/r/programming/comments/1o1yd2/the_sierpinski_triangle_page_to_end_most/ccoc8sy]“The code is all Mathematica. It's an amazing program.”[/url] [url=https://news.ycombinator.com/item?id=6518044]"Holy mother, this person is cool and this person's website is cool, too"[/url] [url=https://news.ycombinator.com/item?id=6517581]"This is amazingly cool and stimulating to think about. It's also a compelling reason to take another look at Mathematica."[/url] [url=https://news.ycombinator.com/item?id=6521409]"I'll also note that Mathematica looks quite awesome indeed."[/url] [url=http://www.reddit.com/r/math/comments/1o0dpo/the_sierpinski_triangle_page_to_end_most/ccnyiz1]“I have found someone whose irrational love for Mathematica puts me to shame.” [/url] [url=http://www.reddit.com/r/math/comments/1o0dpo/the_sierpinski_triangle_page_to_end_most/ccnw7wh]“I have never seen more tattoo ideas on one page...”[/url] [url=http://www.reddit.com/r/biology/comments/1o9b9f/mathematician_graphs_8m_bp_section_of_human/ccq2j09]“whoa where did those 2 hours go... this has been one of the most interesting things I've read in a long time. thanks for the post. ill be keeping up with this person from now on. it's posts like this that make the hundreds of hours I spend lurking the internet worth the while”[/url][/quote] Below I show a few images from that blog as a teaser. For complete visually unforgettable and code-enlightening experience please read [b][url=http://www.oftenpaper.net/sierpinski.htm]the original blog post[/url][/b]. [img=width: 730px; height: 624px;]/c/portal/getImageAttachment?filename=brahm2.png&userId=11733[/img] [img]/c/portal/getImageAttachment?filename=cowpinskiinv7.png&userId=11733[/img] Vitaliy Kaurov 2013-10-13T23:26:59Z https://community.wolfram.com/groups/-/m/t/3027093 A Wolfram U Daily Study Group on Introduction to Discrete Mathematics begins on **October 16th 2023**. Join me and a group of fellow learners to learn about the mathematics behind the innovations of computer science using the Wolfram Language. Our topics cover the most well-known branches of discrete mathematics, including logic, sets, discrete functions, sequences, combinatorics, algorithms, proofs, recursion and graphs. This study group aims to develop a broad understanding of discrete mathematics, with a focus on concepts useful in computer science, software engineering and programming, and make this rich and useful domain accessible for any college student, professional or interested hobbyist. A basic working knowledge of the Wolfram Language is recommended but not necessary. We are happy to help beginners get up to speed with Wolfram Language using resources already available on Wolfram U. Please feel free to use this thread to collaborate and share ideas, materials and links to other resources with fellow learners. > [**REGISTER HERE**][1] ![2 Dimensional Cellular Automaton rule 907486931][2] ![Wolfram U Banner][3] [1]: https://www.bigmarker.com/series/daily-study-group-discrete-math-wsg46/series_details [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=907486931.gif&userId=2311323 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=banner.jpg&userId=2823613 Marc Vicuna 2023-10-04T19:10:50Z