https://community.wolfram.com RSS Feed for Wolfram Community showing ideas tagged with Wolfram Science sorted by most replies. https://community.wolfram.com/groups/-/m/t/526743 [Wolfram Science Summer School][1] and [Wolfram Innovation Summer School][2] are happening now in Boston at Bentley University. The goal of this Code Jam is to post interesting code snippets that fit the Wolfram Language functionality described in detail below. By "interesting" I mean simple programs that generate complex patterns. We will be jamming with our students, but everyone is welcome to join. Let's have some fun! In this Code Jam we will take a look at the CellularAutomaton (CA) function and its syntax **for rules defined as functions**. This may sound a bit confusing, so let's take a look at some examples. First, if you haven't yet, you have to make yourself familiar with the [CellularAutomaton][3] function. The most well known cases are integer Wolfram indexes for [CA rules][4], for instance for the celebrated rule 30: ArrayPlot[CellularAutomaton[30, RandomInteger[1, 100], 50]] ![enter image description here][5] But CellularAutomaton can take a function as a rule. Below are some examples. Use an arbitrary symbolic function f as the rule to apply to range-1 neighbors: CellularAutomaton[{f[#] &, {}, 1}, {a, b, c}, 1] `{{a, b, c}, {f[{c, a, b}], f[{a, b, c}], f[{b, c, a}]}}` Set up a "Pascal's triangle cellular automaton": CellularAutomaton[{f[#] &, {}, 1/2}, {a, b, c}, 1] `{{a, b, c}, {f[{c, a}], f[{a, b}], f[{b, c}]}}` CellularAutomaton[{Total[#] &, {}, 1/2}, {{1}, 0}, 3] `{{1, 0, 0, 0}, {1, 1, 0, 0}, {1, 2, 1, 0}, {1, 3, 3, 1}}` Additive cellular automaton modulo 4: ArrayPlot[ CellularAutomaton[{Mod[Total[#], 4] &, {}, 1}, {{1}, 0}, 50], ColorFunction -> "Rainbow"] ![enter image description here][7] The second argument to the function is the step number: CellularAutomaton[{f[#1, #2] &, {}, 1}, {a, b, c}, 1] `{{a, b, c}, {f[{c, a, b}, 1], f[{a, b, c}, 1], f[{b, c, a}, 1]}}` CellularAutomaton[{f, {}, 1}, {a, b, c}, 1] `{{a, b, c}, {f[{c, a, b}, 1], f[{a, b, c}, 1], f[{b, c, a}, 1]}}` Change the rule at successive steps; #2 gives the step number: ArrayPlot[ CellularAutomaton[{Mod[Total[#] + #2, 4] &, {}, 1}, {{1}, 0}, 30], ColorFunction -> "Rainbow"] ![enter image description here][8] Use continuous values for cells: ArrayPlot[CellularAutomaton[{Mod[Total[#]/2, 1] &, {}, 1}, {{1}, 0}, 50]] ![enter image description here][9] Manipulate[ ArrayPlot[ CellularAutomaton[{Mod[s Total[#], 1] &, {}, 2}, {{1}, 0}, 50], ColorFunction -> "Rainbow", PixelConstrained -> 3] , {s, .01, .99}] ![enter image description here][10] Try different functions and different initial conditions. They can be strings, numbers, graphics or expressions. Try ArrayPlot but also try other visualization tools like Grid. Try them out. Post code, images, and text comments. You can also comment on other people's code. [1]: https://www.wolframscience.com/summerschool/ [2]: http://education.wolfram.com/summer/innovation/ [3]: http://reference.wolfram.com/language/ref/CellularAutomaton.html [4]: http://www.wolframscience.com/nksonline/page-53 [5]: /c/portal/getImageAttachment?filename=SSCJSS2015_1.png&userId=11733 [6]: /c/portal/getImageAttachment?filename=SSCJSS2015_2.png&userId=11733 [7]: /c/portal/getImageAttachment?filename=SSCJSS2015_3.png&userId=11733 [8]: /c/portal/getImageAttachment?filename=SSCJSS2015_4.png&userId=11733 [9]: /c/portal/getImageAttachment?filename=SSCJSS2015_5.png&userId=11733 [10]: /c/portal/getImageAttachment?filename=4926wsdaf345678iruyjtdhfgsdasrt4.gif&userId=11733 Vitaliy Kaurov 2015-07-09T08:46:23Z https://community.wolfram.com/groups/-/m/t/122095 The latest way I have found to use my expensive math software for frivolous entertainment is this. Here's is a way to describe it. [list] [*]1000 dancers assume random positions on the dance-floor. [*]Each randomly chooses one "friend" and one "enemy". [*]At each step every dancer [list] [*]moves 0.5% closer to the centre of the floor [*]then takes a large step towards their friend [*]and a small step away from their enemy. [/list] [*]At random intervals one dancer re-chooses their friend and enemy [/list] Randomness is deliberately injected. Here is the dance... [mcode]n = 1000; r := RandomInteger[{1, n}]; f := (#/(.01 + Sqrt[#.#])) & /@ (x[[#]] - x) &; s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r]; x = RandomReal[{-1, 1}, {n, 2}]; {p, q} = RandomInteger[{1, n}, {2, n}]; Graphics[{PointSize[0.007], Dynamic[If[r < 100, s]; Point[x = 0.995 x + 0.02 f[p] - 0.01 f[q]]]}, PlotRange -> 2][/mcode] [img]/c/portal/getImageAttachment?filename=OPTfnlfrnds.gif&userId=11733[/img] Thanks to Vitaliy for posting this on my behalf, complete with animations :-) Background: I had read somewhere that macro-scale behaviour of animal swarms (think of flocks of starlings or shoals of herring) is explained by each individual following very simple rules local to their vicinity, essentially 1) try to keep up and 2) try not to collide. I started trying to play with this idea in Mathematica, but it was rather slow to identify the nearest neighbours of each particle. So I wondered what would happen if each particle acted according to the locations of two other particles, regardless of their proximity. The rule was simply to move away from one and towards the other. The contraction (x = 0.995 x) was added to prevent the particle cloud from dispersing towards infinity or drifting away from the origin. I tweaked the "towards" and "away" step sizes to strike a balance between the tendency to clump together and to spread apart (if you make the step sizes equal you get something more like a swarm of flies). With each particle's attractor and repeller fixed, the system finds a sort of dynamic equilibrium, so to keep things changing I added a rule to periodically change the attractor and repeller for one of the particles. The final adjustment was to make the "force" drop towards zero for particles at very close range. This helps to stop the formation of very tight clumps, and also prevents a division-by-zero error when a particle chooses itself as its attractor or repeller. The description of the system as a dance was an attempt to explain the swirling pattern on the screen without using mathematical language. I'd love to see what other "dances" can be created with other simple rules. Simon Woods 2013-09-11T18:31:12Z https://community.wolfram.com/groups/-/m/t/1945186 Improved illustrations of the interweaving grid-graphs: An example of how to achieve a graph from which a 2D space with Euclidean distance emerges at a large scale, and therefore rotational also symmetry: ![Euclidean Plane Graph][1] Analogous example for a 2D SpaceTime with Lorentz symmetry: ![Minkowski Plane Graph][2] I noticed that Wolfram said in a live-stream, that you need to have random-looking connections as opposed to a grid-like structure in order to achieve the Euclidean non-Manhattan distances. But I found that you could instead just use a very large number of interweaving grids that are connected to each other in such a way that they each represent different angles of rotation while maintaining the same scale, which can actually be achieved by simple local rules on graphs. The long range graph distances would approximate Euclidean distance as the number of grids A,B,C,D... is growing. Analogous constructions can be made for a Minkowski space time, where the different grids represent frames of reference of different boosts. A very large number of such interweaving grids (called A,B,C...) then analogously leads to approximate Lorentz distance on the large scale and hence also to Lorentz symmetry. They can be arranged as a tree of girds or as a grid of grids. Note that this leads to a density of nodes that could be an astronomical number per plank cube, while the length of the edges could just be the plank length itself. Such 2D spaces that already contain rotational and Lorentz symmetries could then be used as building blocks to generate a 4D space time, but this would be more complicated and I would not be surprised if quantum phenomena emerge from these complications. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_2262.jpg&userId=1941950 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_2264.jpg&userId=1941950 Gabriel Leuenberger 2020-04-19T00:31:07Z 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/1950834 In collaboration with Johan-Tobias Schäg, we were able to create a rule producing an ordinary 2D-grid (https://community.wolfram.com/groups/-/m/t/1946413). Wolfram himself also mentions grids several times (see for example: https://www.wolframphysics.org/technical-introduction/limiting-behavior-and-emergent-geometry/recognizable-geometry/). It is often assumed in several of the texts I read on this subject (the last link is an example) that in the limit of making grids finer and finer we obtain the well known 2-dimensional continuous space. This is not correct, however. In fact, it seems quite complicated to come up with a graph structure that resembles classical 2D-space even remotely (the same is true for higher dimensions as well). It is important to solve this problem since any model resembling physics should look like ordinary continuous space on large scales. In order to illustrate this, I will consider the simplest case known to us all; the regular 2D-grid (see the figure below). I have drawn a piece of a 2D-grid, as well as four points on the grid labeled A, B, C, and D. ![enter image description here][1] In the texts, I have read so far, there is no mention of how we think about *distances* in graphs. However, there are indirect hints. For example, when the subject of dimension and curvature is discussed, the distance $r$ from a point plays a crucial role. In these cases, the distance between two vertices is indirectly defined as the *least* number of (hyper)edges you would have to cross in order to get from one point to the other. This is a very logical definition, and I will keep using it here. Now keep in mind, that the graphs we draw do *not* illustrate these distances correctly. They are only representations of the graph. For example, take another look at the picture of the grid above. The distance between A and B is 1 (you could call one edge for the fundamental length unit, or you could simply omit units for simplicity) and the distance between A and D is 5. The distance between B and C is also 1. However, as the graph is drawn on this picture, the distance between A and C should be $\sqrt{2}$, while the true answer is that the distance is 2! In fact, you could never create graphs with non-integer distances. Okay, this is weird, but not problematic yet. After all, the graph should only look like ordinary space on *large* scales, and my example here is on the absolutely smallest scale possible. However, even on large scales, the answer is still the same. Imagine a huge grid with point A. Choose a direction and go $n$ steps in only that direction (left, right, up, and down are the possibilities on a grid). Now denote the point you end up at by B. There is no shorter path between the two points, which means that the distance between A and B is $n$. Now choose a new direction away from B, which is not the same (or opposite) as before. If you chose to go to the right away from A, you could choose to go upward now, for example. Go another $n$ steps up and label this point C. We are now in the same case as before, but by varying $n$ we can vary the scale of the setup as much as we want. What is the distance between A and C? One path to take is to go from A to B and then from B to C as above. In fact, there is no shorter path than this either! So the distance is $2n$. In the usual 2D-space, we expect the *ratio* between the distance from A til B (denoted $d(A,B)$) and from A til C to fulfill the following identity: $$\frac{d(A,C)}{d(A,B)}=\sqrt{2}$$ A non-integer value like this is no problem anymore (irrational numbers are, however, but never mind that for now). What is the case for our graph? Well, that is easily calculated: $$\frac{d(A,C)}{d(A,B)}=\frac{2n}{n}=2$$ The result is 2 no matter how huge $n$ is! You can make the grid as fine as you ever want it, but you will never get to the usual 2D-space. You could also say that the Pythagorean Theorem doesn't apply, which we know it has to in any physical space. The same problem arises for any regular grid. There are two main points up until now: 1) do *not* believe in the distances drawn on a graph (even simple, regular ones), and 2) just because you get an infinitely fine grid, you do *not* automatically get continuous space. All is not lost, however. Up until now, I have only mentioned regular grids. It is, however, not surprising if nature is not regular on the smallest of scales. In fact, I would be very surprised if that was really the case. Instead, a graph that appears 2-dimensional on large scales could very well look quite chaotic on the small scales. The vertices and edges could have very complicated and seemingly random connections (I have heard rumors of Wolfram mentioning this, but I am not sure). This could solve the problem, but the natural question then is this: **How do we create a grid which obeys the Pythagorean Theorem on large scales?** Other natural questions to ask are: - **How do we deal with angles on large scales? How and when are they defined?** - **What happens to the irrational numbers that arise from the Pythagorean Theorem? Are they approximations?** - **Can we create a large scale isotropic graph?** [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=GridProblem.png&userId=1945692 Malthe Andersen 2020-04-22T15:01:20Z https://community.wolfram.com/groups/-/m/t/227651 Take a word and find its synonyms. Then find the synonyms of the synonyms from the previous step. And so on. [b]For how long will the number of synonyms continue to grow?[/b] Language structures can take peculiar shapes. Code can be quite simple to compute and automate informative visualizations. Below vertex size is larger if the vertex has more connections, meaning a word has a greater number of synonyms. Note GraphLayout -> {"BalloonEmbedding", "RootVertex" -> word} option to Graph is used to produce this specific layout. The code below is based on [url=http://wolfram.com/xid/0j49p2ci-ckbtad]an example from Documentation[/url]. Let’s define a function:[mcode]SynonymNetwork[word_String, depth_Integer, labels_: Tooltip] := Module[{ed, sz, g}, (* list of edges *) ed = Union[Sort /@ Flatten[Rest[NestList[Union[Flatten[ Thread[# <-> WordData[#, "Synonyms", "List"]] & /@ #[[All, 2]]]] &, {"" <-> word}, depth]]]]; (* size of vertices based on number of synonyms *) sz = Thread[VertexList[Graph[ed]] -> Map[{"Scaled", #} &, .05 (.01 + .99 N[Rescale[VertexDegree[g = Graph[ed]]]])^.5]]; (* graph *) SetProperty[g, {GraphLayout -> {"BalloonEmbedding", "RootVertex" -> word}, EdgeStyle -> Directive[Opacity[.2], Red], VertexStyle -> Directive[Opacity[.1], Black], VertexStyle -> {word -> Directive[Opacity[1], Red]}, VertexSize -> sz, VertexLabels -> Placed["Name", labels]}] ][/mcode] Here how it works:[mcode]SynonymNetwork["promise", 3][/mcode] [img=width: 479px; height: 727px;]/c/portal/getImageAttachment?filename=qw23rf5tef5gtbj7uyjthd.gif&userId=11733[/img] Now as I asked earlier: will the number of synonyms continue to grow? This of course depends on a particular thesaurus dictionary at hand. But once we settled on one, what can we find? Obviously some very specific words have no synonyms at all: [mcode]In[1]:= WordData["transmogrification", "Definitions"] Out[1]= {{"transmogrification", "Noun"} -> "the act of changing into a different form or appearance (especially a fantastic or grotesque one)"} In[2]:= WordData["transmogrification", "Synonyms"] Out[2]= {{"transmogrification", "Noun"} -> {}}[/mcode] Some words will have very trivial small finite networks (note network depth is set 20, while even 100 or greater will not change it):[mcode]SynonymNetwork["chemistry", 20, Above][/mcode] [img=width: 327px; height: 356px;]/c/portal/getImageAttachment?filename=sdf34erfdd43ergf.png&userId=11733[/img] And of course many words will have networks that grow very fast. This applies not only for very general words such as “fast” or “beautiful”, but also for strange rare words such as "discombobulate":[mcode]ParallelMap[Length[EdgeList[SynonymNetwork["discombobulate", #]]] &, Range[16]] Out[]= {9, 97, 1097, 7644, 26051, 46671, 59440, 65187, 67805, 68798, 69274, 69456, 69565, 69587, 69592, 69592} data = ParallelMap[Length[VertexList[SynonymNetwork["discombobulate", #]]] &, Range[16] {10, 73, 787, 4293, 11646, 18858, 22931, 24911, 25743, 26096, 26238, 26302, 26321, 26330, 26330, 26330} ListPlot[data, Filling -> Bottom, Joined -> True, Mesh -> All, AxesLabel -> {"Network depth", "Synonyms"}][/mcode] [img=width: 450px; height: 244px;]/c/portal/getImageAttachment?filename=ScreenShot2014-03-31at1.44.27AM.png&userId=11733[/img] So we see [b]"discombobulate" synonym network gets saturated at depth 15 and attains 26330 vertices and 69592 edges[/b]. Quite magnificent result I think ;-) This is, btw, very inefficient way of computing the convergence – we repeat same computations many times while building the graph. Ideally we should introduce counting synonyms part into our SynonymNetwork function. This is how “discombobulate” network looks "big" already at depth 3: [mcode]SynonymNetwork["discombobulate", 3] [/mcode][img]/c/portal/getImageAttachment?filename=df45t6576rteyrsgdfaaasdf.png&userId=11733[/img] How big do such networks get? Can we make some estimates? Well, lets first define set of all words that to belong to “discombobulate” network:[mcode]gr = SynonymNetwork["discombobulate", 15]; ver = VertexList[gr];[/mcode] Then lets find all unique words in “Alice in Wonderland”:[mcode]alice = Union[ToLowerCase[StringSplit[ExampleData[{"Text", "AliceInWonderland"}], RegularExpression["[\\W_]+"]]]]; alice // Length Out[]= 1484[/mcode] Then select, say, only nouns that have synonyms [mcode]nouns = Select[alice, MemberQ[WordData[#, "PartsOfSpeech"], "Noun"] && WordData[#, "Synonyms", "List"] =!= {} &]; nouns // Length Out[]= 809[/mcode] We see that more than half of these nouns belong to the “discombobulate” network: [mcode]MemberQ[ver, #] & /@ nouns // Tally Out[]= {{False, 223}, {True, 586}}[/mcode] I also would like to share some beautiful smaller CONVERGED (saturated) networks, which I found, - beautiful in structure and sets of words they gather (see below). They of course do not belong to huge "discombobulate" graph above. And as already mentioned I propose the following - comment if: [list] [*]you find some beautiful networks [*]you can figure out how we can make estimates on “large” networks or do any further digging  [*]you can optimize code [*]you have any ideas / comments at all ;-) [/list] [b]===> "dragonfly" - 23 synonyms, depth 3[/b] [mcode]ParallelMap[Length[VertexList[SynonymNetwork["dragonfly", #]]] &, Range[7]] Out[]= {8, 14, 23, 23} SynonymNetwork["dragonfly", 20, Above][/mcode] [img]/c/portal/getImageAttachment?filename=sdf43sfs7s683sdfs8239sf.png&userId=11733[/img] [b]===> "benevolent" - 27 synonyms, depth 7[/b] [mcode]ParallelMap[Length[VertexList[SynonymNetwork["benevolent", #]]] &, Range[9]] Out[]= {11, 15, 19, 23, 25, 26, 27, 27} SynonymNetwork["benevolent", 20, Below][/mcode] [img]/c/portal/getImageAttachment?filename=GMLO35FVFVFDffdfdzg.png&userId=11733[/img] Vitaliy Kaurov 2014-03-30T05:26:37Z https://community.wolfram.com/groups/-/m/t/2214623 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/e083449a-81bf-418b-83e9-c700f4a6938c José Manuel Rodríguez Caballero 2021-03-09T18:09:17Z https://community.wolfram.com/groups/-/m/t/1946413 The fundamental idea of the Wolfram model is having an initial graph $G_0$ together with a rule $r$ telling you how to "update" the graph. So far (unless I have missed something) the rule is of the following form: - A "left-hand side" which detects the part of the graph to be updated. - A "right-hand side" which tells you what the formerly detected part of the graph should be changed to. This can be generalized in order to be less restrictive. Instead of considered just *one* rule, it is possible to define the rule as an ordered set of *subrules*, which should all be applied in the right order each time the rule is applied. Thinking of rules as being operators on graphs, we could write it as a kind of product: $$r=r_n\cdots r_3r_2r_1,$$ where all the $r_i$ denote the subrules. A graph (and the left- and right-hand sides of rules) can essentially be thought of as subsets of $\mathbb{N}^2$ (or $\mathbb{Z}^2$ or maybe even $\mathbb{R}^2$ even though the real numbers are probably not suited for this in nature discrete theory). I will come back to this idea later, but for now, it is simply a motivation to use the notation $\{(a,b),(b,c)\}$ instead of the notation $\{\{a,b\},\{b,c\}\}$ when talking about rules. It also seems more readable to me, but this is of course simply a personal opinion. Also, note that everything I mention in this post is easily generalized to hypergraphs. I will add some more notation in order to make things easier (and one more addition to how we make rules). - A new bracket: $[a,b]=(a,b),(b,a).$ This means that the relation between the vertices goes both ways. - The notation $\overline{(a,b)}$ in a rule called a *negation* means that this relation should *not* exist in order for the rule to be applied. This generalizes the left-hand side of the rule to demands of existence *and* lag of existence. This notation only makes sense on the left-hand side of a rule. - The last notation only makes sense on the right-hand side of a rule. This is used when the rule only adds something new without removing anything, which would usually require writing the entire left-hand side again together with the new relations. In this case, I will simply right a "$+$" to represent the left-hand side (except the negated parts). For example $r: \{(a,b),(b,c)\}\rightarrow \{(a,b),(b,c),(c,d)\}$ is written as $r:\{(a,b),(b,c)\}\rightarrow \{+,(c,d)\}$ and $r: \{(a,b),(b,c),\overline{(c,d)}\}\rightarrow \{(a,b),(b,c),(c,d)\}$ is written as $r:\{(a,b),(b,c),\overline{(c,d)}\}\rightarrow \{+,(c,d)\}$. I want to motivate all these new definitions by creating an initial condition and a rule which generates a 2D-grid. For simplicity, I will make all relations between vertices go both ways and thus use $[\cdot,\cdot]$. The initial condition is simply a square: $$G_0=\{[1,2],[2,3],[3,4],[4,1]\}$$ The rule is a composition of three subrules $r=r_3r_2r_1$. I will not use letters but numbers in the rules, but this is still to be thought of as "place holders" and not specific vertices. The three rules are: - $r_1$: $\{[1,2],[2,3],[3,4],\overline{(2,5)},\overline{(3,6)}\}\rightarrow\{+,[2,5],[5,6],[6,3]\}$. This rule identifies two connected vertices of valency 2. That is, vertices with two edges. It then adds to these two vertices a new square. - $r_2$: $\{[1,2],[1,3],[1,4],[4,5],[4,6],[4,7],[5,8],\overline{(1,9)},\overline{(5,10)}\}\rightarrow\{+,[1,9],[10,5]\}$. This rule first identifies a valency 3 vertic, which is connected to a valency 2 vertex through one other vertex of valency 4 (a bit like a stair). It then adds a square to the stair. - $r_3$: $\{[1,2],[1,3],[1,4],[4,5],[5,6],[5,7],\overline{(1,8)},\overline{(5,9)}\}\rightarrow\{+,[1,8],[8,5]\}$. This rule does the same as rule $r_2$ except it adds a new square to two valency 3 vertices seperated by one vertex instead of valency 3 and 2 vertices. ![enter image description here][1] ![enter image description here][2] ![enter image description here][3] Let's see what this rule does to the square. Applying the entire rule means that we should apply $r_1$ first. This rule adds to all four edges a new square giving a "big plus" of squares. Since there are no valency 3 vertices in this graph, applying $r_2$ and $r_3$ changes nothing. Now apply the rule once more. Firstly, one more square is added above, below, and at both sides of the plus giving a longer plus. Subrule two does nothing again. Subrule three adds a square in each corner of the plus resulting in a diamond shape. The third time the rule is applied and henceforth, all three subrules matter. The diamond shape will simply keep growing, by first adding squares to the four ends and then all the way around. (Note: I might have made mistakes in the rule since it is all still new to me). The first three stages of the graph are (blue is $G_0$, black is generated by $r_1$, and red is generated by $r_3$ while $r_2$ is irrelevant in these steps): ![enter image description here][4] Lastly, I want to describe a different kind of initial conditions. One theory for the universe says that it is infinite and always was infinite. We can actually make infinite initial conditions. For example, the graph which is the line of all integers is simply the disjoint union of all succeeding integers and could be taken as an initial condition: $$\bigsqcup_{n=\infty}^{\infty}(n,n+1)=G_0$$ Representing each side of a rule as subsets of $\mathbb{Z}^2$ could also involve *equations*. For example: $$r:\{(x,x+1)\}\rightarrow\{+,(x+1,x)\}$$ This rule would replace all $(\cdot,\cdot)$-brackets with $[\cdot,\cdot]$-brackets if applied on the $G_0$ defined above. I think infinite initial conditions is both interesting and important to consider. They are, however, more complicated to compute and visualize. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=r1.png&userId=1945692 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=r2.png&userId=1945692 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=r3.png&userId=1945692 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=GridGeneration.png&userId=1945692 Malthe Andersen 2020-04-19T20:41:54Z https://community.wolfram.com/groups/-/m/t/833173 After reading about [this article][1] on testing the educational benefits of chess, I was wondering what would constitute a decent experiment for the benefits of learning [Wolfram Language][2]? Certainly there is a lot of common sense behind [Wolfram's educational initiatives][3] and [Computer based maths][4]. Teach some useful skills with powerful software, possibly even in place of traditional mathematical education. Among the range of alternatives to traditional education the possibility here is positive. More fun than memorizing facts and logical rules. One could just drop math altogether, but instead this is a way to still do math, just in a modern sort of way. I am not alone with anecdotal evidence that learning Wolfram language can make you smarter. I've seen a high school dropout who did not know the line-slope formula (or any formula) pick up Wolfram Language and become very productive. But how could one measure it? It would seem wrong to measure something like the learning of formulas that the student no longer needs to learn. [The article by Sala and Gobet][5] offers perhaps a bit of caution comes from its observation that the improvements might not be as great as other things, like learning music. [1]: http://www.sciencedirect.com/science/article/pii/S1747938X16300112 [2]: http://www.wolfram.com/language/ [3]: http://www.wolfram.com/education/ [4]: http://computerbasedmath.org/ [5]: http://www.sciencedirect.com/science/article/pii/S1747938X16300112 Todd Rowland 2016-04-04T00:52:19Z https://community.wolfram.com/groups/-/m/t/1802242 [![enter image description here][1]](https://writings.stephenwolfram.com/2019/10/announcing-the-rule-30-prizes) In case anyone wants to discuss the contest for Wolfram's rule 30 on Community, please respond on this thread. - https://writings.stephenwolfram.com/2019/10/announcing-the-rule-30-prizes - https://rule30prize.org It's about the center column of rule 30. There are three questions. The answer is a mathematical proof. There are cash prizes. ArrayPlot[CellularAutomaton[30, {{1},0},100]] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=r30-prize-website.png&userId=11733 Todd Rowland 2019-10-05T22:40:07Z https://community.wolfram.com/groups/-/m/t/2059389 We've added a new open listing of all universe models explored in 3d. [Hypergraph Universes][1] We've also been experimenting visualizations and video with the models. Here are some examples of the visualizations. >![6721 Wolfram Model All Edges Animation][2] <br> 6721 Wolfram Model All Edges Animated Video<br> Draws the path as animation based on indexed edge numbering, Model number: 6721, Generations: 1500 ![6721 Wolfram Model Animation][4] <br> 6721 Wolfram Model Detailed Path Video <br> Draws the path as animation based on indexed vertex numbering, does not use edge order in animation, Model number: 6721, Generations: 1500 ![6721 Wolfram Model][6] 6721 Wolfram Model Video<br> Colored based on mesh size and emission on all meshes, Model number: 6721, Generations: 1500, [Wolfram Model registry details][8] ---------- >![44586 Wolfram Model All Edges Animation][9]<br> 44586 Wolfram Model All Edges Animated Video<br> Draws the path as animation based on indexed edge numbering, Model number: 44586, Generations: 1200 ![44586 Wolfram Model][11] 44586 Wolfram Model Video<br> Colored based on mesh size and emission on all meshes, Model number: 44586, Generations: 1200, [Wolfram Model registry details][13] ---------- >![4758 Wolfram Model][14] 4758 Wolfram Model Video<br> Colored based on mesh size and low emission on all meshes, Model number: 4758, Generations: 400, [Wolfram Model registry details][16] ---------- >![1268 Wolfram Model][17] 1268 Wolfram Model Video<br> Colored based on mesh indexes and emission on all meshes, Camera path is from inside the model, Model number: 1268, Generations: 1198, [Wolfram Model registry details][19] ---------- >![1986 Wolfram Model][20] 1986 Wolfram Model Video<br> Colored based on mesh size range and emission based on a mesh size range, Model number: 1986, Generations: 198, [Wolfram Model registry details][22] ---------- >![1116 Wolfram Model][23] 1116 Wolfram Model Video<br> Meshes created on paths and colored based on mesh size and emission on sequence of sizes. Model number: 1116, Generations: 18, [Wolfram Model registry details][25] ---------- >![11114 Wolfram Model][26] 1st 11114 Wolfram Model Video<br> 2nd 11114 Wolfram Model Video Less details <br> Meshes created on paths and colored based on similar points length as red. Model number 11114, Generations: 14, [Wolfram Model registry details][29] ---------- >![1495 Wolfram Model][30] 1495 Wolfram Model Video<br> Two generations manually set to overlap, meshes created on paths and colored generation 50 as green and generation 200 as red. Model number 1495, Generations: 50 and 200, [Wolfram Model registry details][32] ---------- >![1381 Wolfram Model][33] 1381 Wolfram Model Video<br> Colored based on mesh size and emission based on a mesh size range, Projection in 2d, Model number: 1381, Generations: 1198, [Wolfram Model registry details][35] ---------- If there is an interest to build a video, image or 3d representation from certain models we are up for the task! You can contact here for a request. The 3d Model explorer tool is originated from this post https://community.wolfram.com/groups/-/m/t/1985729 [1]: https://github.com/gigabrainIO/HypergraphUniverses [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6721AllEdgesAnimated.gif&userId=2053745 [3]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/6721+Wolfram+Model+AllEdgesAnimated+1500+2k.mp4 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AnimatedModel2.gif&userId=2053745 [5]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/6721+WolframModel+FollowPath+1500+2k.mp4 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6721WolframModel1500gen2k.png&userId=2053745 [7]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/6721+Wolfram+Model+1500+gen+2k.mp4 [8]: https://www.wolframphysics.org/universes/wm6721/ [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=44586WolframModelPillow.gif&userId=2053745 [10]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/44586+WolframModel+Curves+follow+Path+1200+2k.mp4 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=44586WolframPhysics.png&userId=2053745 [12]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/44586+WolframPhysics+1080p.mp4 [13]: https://www.wolframphysics.org/universes/wm44586/ [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4758_bow_front2.png&userId=2053745 [15]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/4758_WolframPhysics1080p.mp4 [16]: https://www.wolframphysics.org/universes/wm4758/ [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1268_cactus_1080p.png&userId=2053745 [18]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/1268+WolframPhysics+1080p.mp4 [19]: https://www.wolframphysics.org/universes/wm1268/ [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1986WolframModel_gen1982k.png&userId=2053745 [21]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/1986+WolframPhysics+1080p.mp4 [22]: https://www.wolframphysics.org/universes/wm1986/ [23]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1116WolframModelgen181080p.png&userId=2053745 [24]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/1116+WolframModel+gen+18+1080p.mp4 [25]: https://www.wolframphysics.org/universes/wm1116/ [26]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1114WolframModelgeneration14.png&userId=2053745 [27]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/11114+Wolfram+Model+14+Details+2k.mp4 [28]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/11114+Wolfram+Model+14+2k.mp4 [29]: https://www.wolframphysics.org/universes/wm11114/ [30]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1495_gen50_200.png&userId=2053745 [31]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/1495+Wolfram+Model+gen50_200+2k.mp4 [32]: https://www.wolframphysics.org/universes/wm1495/ [33]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3086getImageAttachment.png&userId=20103 [34]: https://gigabrain.s3-eu-west-1.amazonaws.com/physics/1381+WolframPhysics+1080p.mp4 [35]: https://www.wolframphysics.org/universes/wm1381/ Tuomas Sorakivi 2020-08-17T14:55:12Z https://community.wolfram.com/groups/-/m/t/863933 Many of you have seen the strandbeest (from Dutch, meaning beach-beast). These PVC tube animals created by Theo Jansen walk along the beach and are wind powered: ![enter image description here][1] Years ago (2009 to be more exact) I made a post on my blog about the movement of the legs, as evidenced by the still-nicely-working Mathematica notebook: ![enter image description here][2] At the time the proportions of the legs were not known publicly so I meticulously studied frames of (low quality) YouTube videos. I made the following diagram in Illustrator of what I thought I saw: ![enter image description here][3] ![enter image description here][4] On the left the length of the legs in red, and in blue the numbers of the joints. On the right the trajectory of the joints that I calculated at the time in Mathematica. It's funny that my blog does not exist any more (for years actually), but these images live on, as I found out when I looked for strandbeest on Google Images: ![enter image description here][5] My images! But not on my website! Nice to see people still use it. Now, in 2016, I saw these files on my laptop, and thought: is there finally more known about them? Well yes, there is! The exact proportions are now known and there is tons and tons of videos, lectures, 3D-printable strandbeest models, interviews with Theo Jansen and other stuff! So now we can find the exact dimensions readily on the internet: ![enter image description here][6] Notice that I (wrongly) assumed that the legs had 'feet'! oops! I was very happy to see that my lengths were not that wrong though! Let's recreate the strandbeest. We do so by first creating a function that quickly finds the intersection of two circles: Clear[FindPoint, FindLines] FindPoint[p1 : {x1_, y1_}, p2 : {x2_, y2_}, R_, r_, side_] := Module[{d, x, y, vc1, vc2, p, sol, sol1, sol2, s1, s2, sr}, d = N@Sqrt[(x2 - x1)^2 + (y2 - y1)^2]; x = (d^2 - r^2 + R^2)/(2 d); y = Sqrt[R^2 - x^2]; vc1 = Normalize[{x2 - x1, y2 - y1}]; vc2 = Cross[vc1]; p = {x1, y1} + x vc1; {sol1, sol2} = {p + y vc2, p - y vc2}; s1 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol1 - p1), 0]]]]; s2 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol2 - p1), 0]]]]; sr = If[side === Left, 1, -1]; Switch[sr, s1, sol1 , s2 , sol2 ] ] This finds on the side 'side' (Left/Right) the intersection point of two circles positioned at p1 and p2, with radii R and r, respectively. And now we can easily compute all the little vertices/joints of our beast: FindLines[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15}, {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} = FindPoints[\[Theta]]; {{p1, p2}, {p2, p3}, {p3, p4}, {p1, p4}, {p2, p6}, {p4, p6}, {p3, p5}, {p4, p5}, {p5, p8}, {p6, p8}, {p6, p7}, {p7, p8}, {p1, p11}, {p10, p11}, {p2, p10}, {p2, p13}, {p11, p13}, {p10, p12}, {p11, p12}, {p12, p14}, {p13, p14}, {p13, p15}, {p14, p15}} ] FindPoints[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16}, p1 = {0, 0}; p4 = {38, -7.8}; p11 = {-38, -7.8}; p2 = 15 {Cos[\[Theta]], Sin[\[Theta]]}; p3 = FindPoint[p2, p4, 50, 41.5, Left]; p6 = FindPoint[p2, p4, 61.9, 39.3, Right]; p5 = FindPoint[p3, p4, 55.8, 41.5, Left]; p8 = FindPoint[p5, p6, 39.4, 36.7, Left]; p7 = FindPoint[p6, p8, 49, 65.7, Right]; p10 = FindPoint[p2, p11, 50, 41.5, Right]; p13 = FindPoint[p2, p11, 61.9, 39.3, Left]; p12 = FindPoint[p10, p11, 55.8, 41.5, Right]; p14 = FindPoint[p12, p13, 39.4, 36.7, Right]; p15 = FindPoint[p13, p14, 49, 65.7, Left]; {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} ] Now we can plot it easily: trajectoriesdata = (FindPoints /@ Subdivide[0, 2 Pi, 100])\[Transpose]; Manipulate[ Graphics[{Arrowheads[Large], Arrow /@ trajectoriesdata, Thick, Red, Line[FindLines[\[Theta]]]}, PlotRange -> {{-150, 150}, {-120, 70}}, ImageSize -> 800 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][7] We can also make an entire bunch of legs at the same time and make a 3D beast! Manipulate[ mp = 60; n = 12; \[CurlyPhi] = Table[Mod[5 \[Iota], n, 1], {\[Iota], 1, n}]; Graphics3D[{Darker@Yellow, Table[ Line[ Map[Prepend[mp \[Iota]], FindLines[\[Theta] + \[CurlyPhi][[\[Iota]]] (2 Pi/n)], {2}]], {\[Iota], n} ] , Black, Line[{{mp 1, 0, 0}, {mp n, 0, 0}}] } , Lighting -> "Neutral", PlotRangePadding -> Scaled[.1], PlotRange -> {{-mp, (n + 1) mp}, {-150, 150}, {-150, 150}}, Boxed -> False, ImageSize -> 700 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][8] From the side we can look at how the legs of 4-pair-legged and 6-pair-legged versions of the beasts work: ![enter image description here][9] ![enter image description here][10] Hope you enjoyed this! Perhaps someone else can make this thing actually walk over a (bumpy) surface? [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=LVDKumerus2.jpg&userId=73716 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.51.53.png&userId=73716 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_sketch.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_trajectories.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.16.23.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Strandbeest_Leg_Proportions-01.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3493strandwalk.gif&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3587strandwalk3D.gif&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4legged.gif&userId=73716 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6legged.gif&userId=73716 Sander Huisman 2016-05-28T23:02:16Z https://community.wolfram.com/groups/-/m/t/114911 How small can a description of a large prime number be? There are the Fermat primes 2^n-1 for certain n, and in base 2 these are a sequence of ones.  In base 10, if you have just zeros and two ones, then the only primes of that form are 11 and 101.  If there are three ones then it is divisible by three.  But what about four ones?  It seems wrong to me that there might be an unbounded number of such primes. That's what some brief experiments suggest though. [mcode]1+10^4+10^18+10^201 == 1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000010001[/mcode]is the largest one I found.  Also I don't notice any patterns, e.g. here in the first 200 such primes [img=width: 68px; height: 432px;]/c/portal/getImageAttachment?filename=primes-1111.jpg&userId=23275[/img] and here are the first 254 primes with nonzero digits {1,2,1} [img=width: 347px; height: 432px;]/c/portal/getImageAttachment?filename=primes-121.jpg&userId=23275[/img] the largest found is [mcode]1+2*10^14+10^201 == 1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000200000000000001[/mcode]Does anyone else have any primes which don't seem like they should be prime?  The more extreme the better. Todd Rowland 2013-09-03T04:50:53Z https://community.wolfram.com/groups/-/m/t/1890120 I was amused by the post [1-D Cellular Automata With a Twist][1], so I thought I'd take a look. ![enter image description here][2] Here's rule 420. Clear[a]; tab=Table[{a[0,k]=0, a[k,0]=0},{k,0,800}]; a[0,0]=1; rule=IntegerDigits[420,3,7]; a[n_,k_] := a[n,k]= rule[[1+ a[n-1,k -1]+a[n -1,k]+a[n ,k-1]]]; tab=Table[a[m,d-m],{d,2,729},{m,1,d-1}]; ArrayPlot[Table[a[x,y],{x,1,729},{y,1,729}], Frame-> False, PixelConstrained->1] ![rule 420][3] Here are some other nice rules: nice = {381, 382, 383, 384, 385, 386, 414, 415, 416, 417, 418, 419, 420, 421, 422, 424, 478, 613, 622, 623, 624, 625, 626, 657, 658, 663, 694, 717, 721, 864, 865, 866, 867, 868, 869, 870, 871, 872, 883, 903, 904, 906, 936, 937, 960, 1110, 1111, 1112, 1113, 1114, 1115, 1143, 1144, 1145, 1146, 1147, 1148, 1149, 1150, 1230, 1231, 1232, 1233, 1234, 1235, 1236, 1237, 1238, 1239, 1240, 1242, 1243, 1244, 1245, 1246, 1247, 1254, 1255, 1256, 1257, 1258, 1259, 1260, 1261, 1262, 1263, 1265, 1266, 1272, 1274, 1278, 1279, 1280, 1284, 1287, 1288, 1342, 1351, 1352, 1354, 1355, 1386, 1387, 1392, 1504, 1527, 1531, 1539, 1547, 1548, 1549, 1556, 1557, 1558, 1559, 1560, 1561, 1562, 1563, 1564, 1585, 1593, 1594, 1595, 1596, 1597, 1598, 1599, 1600, 1601, 1608, 1612, 1632, 1633, 1634, 1635, 1666, 1774, 1839, 1840, 1841, 1842, 1843, 1844, 1872, 1874, 1875, 1876, 1877, 1878, 1879, 1882, 2071, 2080, 2081, 2082, 2083, 2084, 2121, 2175} Here's 1504 ![rule 1504][4] Here's 1240 ![rule 1240][5] Here's 1263 ![rule 1263][6] [1]: https://www.reddit.com/r/math/comments/fagayt/1d_cellular_automata_with_a_twist/ [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=DEBlSIr.png&userId=11733 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rule420.png&userId=21530 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rule1504.png&userId=21530 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rule1240.png&userId=21530 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rule1263.png&userId=21530 Ed Pegg 2020-02-28T23:27:55Z https://community.wolfram.com/groups/-/m/t/437875 Three Years ago I came about Stephen Wolfram's book “A New Kind of Science”. It has taken me on a phantastic journey from which I returned with a vision to paint a cellular automaton, big in size and big in scope. I decided to generate and paint a one-dimensional, two nearest neighbours cellular automaton with 14 colors. The problem was, I have just rudimentary knowledge of programming and I knew that this task was beyond me. Taking a course in adult education and two educational books on this matter were to no avail. Then I bought Mathematica. Some Money for a risk. What, if I couldn’t handle it? Well I could, because of the excellent, interactive Help-section and that I could go to work just by using functions and brackets, no need to dive deeper into the realm of Mathematica. Also great the fast computation and visualization. What I had to do all by myself was to find in a set of 14(power14(power3)) the one rule which was worth to be painted. It took months of searching in colored deserts, no interesting structures to be found. Well, I think I finally found a good one, and I think it belongs to class three! (Right click on the image and select "View in new tab" to zoom.) ![enter image description here][1] The direction of evolution of the automaton is horizontally from the left to the right for aesthetical reasons. I have been a printer and I paint with printing ink on aluminium printing plates. The painting is composed of 12 Plates, overall size 2.1 x 4 m, The image is composed of photos of the 12 plates, which are not easy to take pictures from because of their glossy surface. ---------- ## Editor's Edit ## Below is the painting and the painter kindly shared by the author upon requests below in the comments: ![enter image description here][2] [1]: /c/portal/getImageAttachment?filename=Nr179CellularAutomaton2014.jpg&userId=11733 [2]: /c/portal/getImageAttachment?filename=WolframCasdweq53.jpg&userId=11733 Reinhard Danelzik 2015-02-08T13:06:14Z https://community.wolfram.com/groups/-/m/t/3502932 ![Modeling 3D Wildfire Spread Using Cellular Automata and Optimizing Fire Suppressant Placement][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=kellyAnim8-reduce.gif&userId=3502529 [2]: https://www.wolframcloud.com/obj/53b633f3-7f63-4371-aa22-02cab3732f8b Kelly Liu 2025-07-10T21:47:49Z https://community.wolfram.com/groups/-/m/t/1491903 The [Algorithmic Information Dynamics course][1] promoted and distributed by the Santa Fe Institute is coming to an end. Sponsored by Wolfram Research, the course students made heavy use of the **Wolfram Language** to follow lectures, read, write and share code from the cloud. This has been an enriching experience for both instructors and students and people may want to share their thoughts about it. [![enter image description here][2]][1] ### **About the Course:** Probability and statistics have long helped scientists make sense of data about the natural world — to find meaningful signals in the noise. But classical statistics prove a little threadbare in today’s landscape of large datasets, which are driving new insights in disciplines ranging from biology to ecology to economics. It's as true in biology, with the advent of genome sequencing, as it is in astronomy, with telescope surveys charting the entire sky. The data have changed. Maybe it's time our data analysis tools did, too. During this three-month online course, starting June 11th, instructors Hector Zenil and Narsis Kiani will introduce students to concepts from the exciting new field of Algorithm Information Dynamics to search for solutions to fundamental questions about causality — that is, why a particular set of circumstances lead to a particular outcome. Algorithmic Information Dynamics (or Algorithmic Dynamics in short) is a new type of discrete calculus based on computer programming to study causation by generating mechanistic models to help find first principles of physical phenomena building up the next generation of machine learning. The course covers key aspects from graph theory and network science, information theory, dynamical systems and algorithmic complexity. It will venture into ongoing research in fundamental science and its applications to behavioral, evolutionary and molecular biology. [1]: https://www.complexityexplorer.org/courses/63-algorithmic-information-dynamics-a-computational-approach-to-causality-and-living-systems-from-networks-to-cells [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-10-10at4.41.08PM.png&userId=20103 Hector Zenil 2018-10-03T09:15:56Z https://community.wolfram.com/groups/-/m/t/554194 The [CurlicueFractal][1] can be simplified with AnglePath. Graphics[Line[AnglePath[N[ (7 Sqrt[7] Khinchin Pi E EulerGamma) Range[-20000, 20000]]]]] ![curlicue fractal][2] Who else can find some nice ones? [1]: http://demonstrations.wolfram.com/CurlicueFractal/ [2]: /c/portal/getImageAttachment?filename=drxZkto.gif&userId=21530 Ed Pegg 2015-08-26T19:10:26Z https://community.wolfram.com/groups/-/m/t/2965206 ![Multiway graph][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Untitled.png&userId=2964459 [2]: https://www.wolframcloud.com/obj/b6ad5a15-e8d2-4359-ae89-b72d3e3d06d4 Eric Archerman 2023-07-13T23:11:59Z https://community.wolfram.com/groups/-/m/t/2856178 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Einsteinproblem.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/1711df4d-dd07-4e40-af7c-90c747e307d1 Ed Pegg 2023-03-21T13:59:14Z