https://community.wolfram.com RSS Feed for Wolfram Community showing ideas tagged with Wolfram Science sorted by most likes. 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/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/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/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/235291 [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] Some time ago one of my friends asked me whether it is possible to design a cellular automaton which can generate realistic snowflakes. I recall my crystallography and thermodynamics knowledge and came up a very simple yet impressive model. [size=5][b]The Regular Triangular Lattice[/b][/size] First of all, we are trying to simulate snowflake, which is a kind of hexagonal crystal. So it should be best to construct our CA on a regular hexagonal grid, i.e. regular triangular lattice. We all know [b]CellularAutomaton[/b] inherently works on rectangle lattices ("4-lattice" for short), so how can we deduce a triangular lattice ("3-lattice" for short) on it? Well, the differences between rect-lattice and triangular one is just a geometric transformation. To demonstrate that, have a look at the following 4-lattice, with a blue square highlighting the range-1 [url=http://mathworld.wolfram.com/MooreNeighborhood.html]Moore neighborhood[/url]: [img=width: 388px; height: 396px;]/c/portal/getImageAttachment?filename=fig1.gif&userId=93201[/img] Clearly there is always a hexagon (the green area) in this kind of neighborhood. So forming a regular 3-lattice is as straightforward as doing a simple affine transformation (basically a shearing and a scaling): [img=width: 484px; height: 304px;]/c/portal/getImageAttachment?filename=fig2.gif&userId=93201[/img] So to take advantage of all the power of [b]CellularAutomaton[/b], all we have to do, is to use a following special 6-neighborhood stencil on rectangle lattices, meanwhile our model can be discussed and constructed on regular triangular lattice convieniently: [img=width: 118px; height: 57px;]/c/portal/getImageAttachment?filename=fig3.png&userId=93201[/img] And after the calculation, we can perform the affine transformation with following functions to get a nice hexagonal grid picture. [mcode]Clear[vertexFunc] vertexFunc = Compile[{{para, _Real, 1}}, Module[{center, ratio}, center = para[[1 ;; 2]]; ratio = para[[3]]; {Re[#], Im[#]} + {{1, -(1/2)}, {0, Sqrt[3]/2}}.Reverse[{-1, 1} center + {3, 0}] & /@ (ratio 1/ Sqrt[3] E^(I ?/6) E^(I Range[6] ?/3))], RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" (*,CompilationTarget?"C"*)]; Clear[displayfunc] displayfunc[array_, ratio_] := Graphics[{FaceForm[{ColorData["DeepSeaColors"][3]}], EdgeForm[{ColorData["DeepSeaColors"][4]}], Polygon[vertexFunc[Append[#, ratio]] & /@ Position[array, 1]]}, Background -> ColorData["DeepSeaColors"][0]][/mcode] [size=5][b]The Model[/b][/size] To construct the crystallization model, let's consider one of the 6-neighborhood stencil, where each cell represents a minimal crystal unit: [img=width: 261px; height: 236px;]/c/portal/getImageAttachment?filename=fig4.png&userId=93201[/img] A simple model will need only 2 states: [b]0[/b] for "[i]It's empty[/i]", [b]1[/b] for "[i]There is a crystal unit[/i]". So by considering all (except the [b]000000[/b] one, because we are generating ONE snowflake thus don't want a crystall randomly arises from void) [b]6-bit[/b] non-negative numbers, we can have a finite set of possible arrangements of the neighborhood: [mcode]stateSet = Tuples[{0, 1}, 6] // Rest[/mcode] However, from the viewpoint of physics, any two arrangements which can be transformed into each other with only rotation and reflection should be considered as the same arrangement in the sense of their physical effects on the central cell (i.e. cell[size=1]2,2[/size]) are the same: [img=width: 363px; height: 117px;]/c/portal/getImageAttachment?filename=fig5.png&userId=93201[/img] So we should gather [b]stateSet[/b] with above equivalence class: [mcode]gatherTestFunc = Function[lst, Union[Join[ RotateLeft[lst, # - 1] & /@ Flatten[Position[lst, 1]], RotateLeft[Reverse[lst], # - 1] & /@ Flatten[Position[Reverse[lst], 1]] ]]]; stateClsSet = Sort /@ Gather[stateSet, gatherTestFunc[#1] == gatherTestFunc[#2] &]; stateClsSetHomogeneous = ArrayPad[#, {{0, 12 - Length@#}, {0, 0}}] & /@ stateClsSet;[/mcode] Which turned out to be [b]12[/b] classes in total: [img=width: 710px; height: 127px;]/c/portal/getImageAttachment?filename=fig6.png&userId=93201[/img] Now from the viewpoint of cellular automaton, we need to establish a set of rules on how should any 6-neighborhood arrangement, i.e. those 12 kinds of equivalence classes, determine the state of the central cell. There are 4 kinds of possible transformations on cell[size=1]2,2[/size]: [b]0 --> 1[/b] is called [b]frozen[/b], [b]0 --> 0[/b] is [b]remaining empty[/b], [b]1 --> 1[/b] is [b]remaining frozen[/b], and [b]1 --> 0[/b] is called [b]melten[/b]. To make things more interesting and to explore more possibilities, we can introduce probability here, so certain arrangement will give certain probabilities corresponding to the 4 kinds of transformations. But notice that because of the unitarity of probability, we have Prob(frozen) + Prob(0->0) = 1 and Prob(melten) + Prob(1->1) = 1, so only 2 of the 4 probabilities are independent. In the following, we'll choose Prob(frozen) and Prob(melten), and denote them as [b]pFrozen[/b] and [b]pMelten[/b]. [img=width: 800px; height: 367px;]/c/portal/getImageAttachment?filename=fig7.png&userId=93201[/img] Back to physics / thermodynamics, those 24 probabilities, [b]pFrozen[/b] and [b]pMelten[/b], can of corse be determined by serious physical models, or they can be chosen randomly just for fun. For example, an intuitive (and naive) idea would be to believe an empty cell nearby a sharp pointed end or with abundant moisture source will have a high [b]pFrozen[/b]. (People who are interested in the serious physical models should not miss [url=http://psoup.math.wisc.edu/Snowfakes.htm]the Gravner-Griffeath Snowfakes model[/url].) Now we have the grid, the stencil, the neighborhood arrangement set and the transfer probabilities, we're offically ready to construct our cellular automaton rules. Following the above discussion, the construction is straightforward. There are only two points which need to pay attention to. One is to keep in mind that the rule function is applied on the 3x3 stencil, so even cell[size=1]1,1[/size] and cell[size=1]3,3[/size] has nothing to do with our model, don't forget handling them. The second is to use a [b]SeedRandom[/b] function to make sure same arrangement gives same result in same time step, otherwise the 6-fold rotational symmetry and 3 axes of reflection symmetry will both break! [mcode]Clear[ruleFunc] ruleFunc = With[{ stateClsSetHomogeneous = stateClsSetHomogeneous, seedStore = RandomInteger[{0, 1000}, 1000], pFreeze = {1, 0, 0.6, 0, 0.3, 0.15, 0, 0.2, 0, 0.2, 0, 0.8}, pMelt = {0, 0.7, 0.5, 0.7, 0.7, 0.5, 0.3, 0.5, 0.3, 0.2, 0.1, 0 } }, Compile[{{neighborarry, _Integer, 2}, {step, _Integer}}, Module[{cv, neighborlst, cls, rand}, cv = neighborarry[[2, 2]]; neighborlst = {#[[1, 2]], #[[1, 3]], #[[2, 3]], #[[3, 2]], #[[3, 1]], #[[2, 1]]} &[neighborarry]; If[Total[neighborlst] == 0, cv, cls = Position[stateClsSetHomogeneous, neighborlst][[1, 1]]; SeedRandom[seedStore[[step + 1]]]; rand = RandomReal[]; Boole@If[cv == 0, rand < pFreeze[[cls]], rand > pMelt[[cls]]] ]], (*CompilationTarget -> "C",*) RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" ] ];[/mcode] (Note: re-compile the rule function [b]ruleFunc[/b] will give a different set of [b]seedStore[/b] thus a different growth path.) Now everything is ready, let's grow a snowflake from the beginning! :D [mcode]dataSet = Module[{ rule, initM = {{ {0, 0, 0}, {0, 1, 0}, {0, 0, 0} }, 0}, rspec = {1, 1}, tmin = 0, tmax = 100, dt = 1}, rule = {ruleFunc, {}, rspec}; CellularAutomaton[rule, initM, {{tmin, tmax, dt}}] ]; // AbsoluteTiming Animate[ Rotate[displayfunc[dataSet[[k]], .8], 90 °], {k, 1, Length[dataSet], 1}, AnimationDirection -> ForwardBackward, AnimationRunning -> False, DisplayAllSteps -> True ][/mcode] [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] [size=5][b]Possible Improvements[/b][/size] We used a [b]SeedRandom[/b] function in our CA rule function to force the 6-fold rotational symmetry and 3 axes of reflection symmetry, and performed the CA calculation on all cells. However, this so called [url=http://demonstrations.wolfram.com/DihedralGroupNOfOrder2n/][i]D[/i][size=1]6[/size] symmetry[/url] can (and should) be integrated into our model, which will saving [b]11/12[/b] of the calculation. Also, the randomness of the growth path comes from [b]seedStore[/b], so to generate a new growth path, we have to re-compile the rule function. But with a improved model as described above, this constraint will no longer exist. [img=width: 800px; height: 177px;]/c/portal/getImageAttachment?filename=fig8.png&userId=93201[/img] [b][size=4] [size=5]Open question [/size] [/size][/b] Can we construct a well-organized structure (like the crystals) from a cellular automaton defined on an [b]irregular[/b] grid? While I believe the answer is [i]yes[/i], the next question would be [i]how?[/i] Silvia Hao 2014-04-11T16:03:33Z https://community.wolfram.com/groups/-/m/t/595870 ![Ocean currents: from Fukushima and rubbish, to Malaysian airplane MH370][1] In this post I will use data from NASA's ECCO2 project (http://ecco2.jpl.nasa.gov/) to simulate various scenarios: the movement of radioactive particles from the Fukushima nuclear power plant and the accumulation of rubbish in the oceans. I download about 20 years worth of oceanographic data and study how the flow of water might transport particles. A slight modification of the program might be useful to determine the crash site of Malaysian airplane MH370. The work was done with [Bjoern Schelter][2], who is member of this community. We will first download the vector fields for u and v direction. We obtain data for different depth, but I will only use surface currents. We first generate a list of filenames. filenamesU = ("http://ecco2.jpl.nasa.gov/opendap/data1/cube/cube92/lat_lon/quart_90S_90N/UVEL.nc/UVEL.1440x720x50." <> # <> ".nc.ascii?UVEL[0:1:0][0:1:0][0:1:719][0:1:1439]" & /@ (StringJoin[{ToString[#[[1]]], StringTake[StringJoin[ToString /@ PadLeft[{#[[2]]}, 2]], -2], StringTake[StringJoin[ToString /@ PadLeft[{#[[3]]}, 2]], -2]}] & /@ Table[Normal[DatePlus[DateObject[{1992, 1, 2}], 3*n]], {n, 0, 2556}])); filenamesV = ("http://ecco2.jpl.nasa.gov/opendap/data1/cube/cube92/lat_lon/quart_90S_90N/VVEL.nc/VVEL.1440x720x50." <> # <> ".nc.ascii?VVEL[0:1:0][0:1:0][0:1:719][0:1:1439]" & /@ (StringJoin[{ToString[#[[1]]], StringTake[StringJoin[ToString /@ PadLeft[{#[[2]]}, 2]], -2],StringTake[StringJoin[ToString /@ PadLeft[{#[[3]]}, 2]], -2]}] & /@ Table[Normal[DatePlus[DateObject[{1992, 1, 2}], 3*n]], {n, 0, 2556}])); These filenames cover a time interval from the beginning of 1992 to 2012. We then download the actual data (which can take really long): Monitor[For[k = 1, k <= Length[filenamesV], k++, Export["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", ToExpression[StringSplit[StringSplit[#, "],"][[2]], ","]] & /@ StringSplit[Import[filenamesV[[k]]], "VVEL.VVEL[VVEL.TIME="][[ 2 ;;]] ]], ProgressIndicator[Dynamic[k], {0, Length[filenamesV]}]] and Monitor[For[k = 1, k <= Length[filenamesU], k++, Export["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", ToExpression[StringSplit[StringSplit[#, "],"][[2]], ","]] & /@ StringSplit[Import[filenamesU[[k]]], "UVEL.UVEL[UVEL.TIME="][[ 2 ;;]] ]], ProgressIndicator[Dynamic[k], {0, Length[filenamesU]}]] This will download about 16GB worth of data. You will, however, get reasonable results if you only use 30 frames, i.e. if you substitute Length[filenamesU] and Length[filenamesV] by 30. We will now create a figure for the first frame. velV1 = Import["~/Desktop/OceanVelocities/velV1.csv"]; velU1 = Import["~/Desktop/OceanVelocities/velU1.csv"]; We can now generate the velocity vectors for each point on the surface of the earth veltot = Table[{velU1[[i, j]], velV1[[i, j]]}, {i, 1, 720}, {j, 1, 1440}]; and then clean the data veltot2 = Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i, j]] })[[1]], {0., 0.}, {velU1[[i, j]], velV1[[i, j]]}], {i, 1, 720}, {j, 1, 1440}]; We can also calculate the speed at each point. veltottot = Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i, j]] })[[1]], 0., Norm[{velU1[[i, j]], velV1[[i, j]]}]], {i, 1, 720}, {j, 1, 1440}]; This next function will produce a visualisation of the speed profile for the first frame. Show[ArrayPlot[Reverse[veltottot], PlotLegends -> Automatic, ImageSize -> Full, ColorFunction -> "TemperatureMap"], ListVectorPlot[Transpose[veltot2], VectorPoints -> 50]] ![enter image description here][3] Note the incredible fine-structure in that image. We could now produce an animation for all frames. This will, however, be too large for the memory of most computers, so I would not execute it. If you only use the first 30 frames you get a reasonable idea of its working. framesflow = {}; Monitor[ For[k = 1, k <= Length[filenamesU], k++, velU1 = Import["~/Desktop/velU" <> ToString[k] <> ".csv"]; velV1 = Import["~/Desktop/velV" <> ToString[k] <> ".csv"]; veltot = Table[{velU1[[i, j]], velV1[[i, j]]}, {i, 1, 720}, {j, 1, 1440}]; AppendTo[framesflow, ArrayPlot[Reverse[Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i,j]] })[[1]], 0., Norm[{velU1[[i, j]], velV1[[i, j]]}]], {i, 1, 720}, {j, 1, 1440}]], PlotLegends -> Automatic, ImageSize -> Full, ColorFunction -> "TemperatureMap"]]], k]; This following command exports all the frames as individual gif files, which can later be combined into a gif animation. Monitor[For[k = 1, k <= Length[filenamesU], k++, velU1 = Import[ "~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv"]; velV1 = Import[ "~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv"]; veltot = Table[{velU1[[i, j]], velV1[[i, j]]}, {i, 1, 720}, {j, 1, 1440}]; Export["~/Desktop/MovieOut/frame" <> ToString[1000 + k] <> ".gif", ArrayPlot[Reverse[Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i,j]] })[[1]], 0., Norm[{velU1[[i, j]], velV1[[i, j]]}]], {i, 1, 720}, {j, 1, 1440}]], PlotLegends -> None, ImageSize -> {1440, 730}, ColorFunction -> "TemperatureMap"]]], k]; Another advantage of saving the frames is that we can use them as background for various scenarios and thereby decrease our computation time substantially. Here is a short animation of the first couple of frames. ![enter image description here][4] Now we get the trajectories of radioactive particles that are released into the ocean at the approximate site of the Fukushima power plant. We make the assumption that the particles simply follow the flow. Also, we use the vectorfield starting on 2nd January 1992. The overall patterns of the ocean currents seem to be reasonably stable over the years so that for this conceptual study this assumption will have to suffice. It is of course easy to adapt to the actual date. We first need to introduce a formula to convert the data grid to the surface of the earth. ClearAll["Global`*"]; f[teta_, r_, vx_, vy_] := {vx/(r*Sin[2*Pi*teta/4./360.]*2*Pi/360/4)*24*3600, vy/(N[r*2*Pi/360/4])*24*3600}; teta = 1; r = 6360000; We now place 20000 particle into the see close to the location of Fukushima. We add a small random number to the position to model a "cloud" of particles. teilreinpos = Table[{3, 511 + RandomVariate[NormalDistribution[0., 1.]], 568 + RandomVariate[NormalDistribution[0., 1.]]}, {m, 1, 20000}]; This is the main part of the program. We use the velocity to update the position of the particles. We then use the back-ground frames generated above and overlay the particle positions. trajectories = {teilreinpos}; Monitor[Do[ velVt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; velUt = Table[If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; xfunc = ListInterpolation[velUt, {{1, 5}, {0, 720}, {0, 1440}}]; yfunc = ListInterpolation[velVt, {{1, 5}, {0, 720}, {0, 1440}}]; AppendTo[trajectories, Nest[({#[[1]], Mod[#[[2]], 720], Mod[#[[3]], 1440]}) & /@ (# + {0.1, 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[2]] , 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[1]] } &) , # , 10] & /@ trajectories[[-1]]]; Export["~/Desktop/OilSpillFrames/frame" <> ToString[1000 + i] <> ".gif", Show[ Import["~/Desktop/MovieOut/frame" <> ToString[1000 + i] <> ".gif"], Graphics[{Red, Disk[#, 1]} & /@ (0.9361111 # + {44., 28.} & /@ trajectories[[i - 2, All, {3, 2}]]), PlotRange -> {{0, 1440}, {0, 720}}]]]; , {i, 3, 1238}], i]; Here are a couple of frames: ![enter image description here][5] All frames yield the following animation. ![enter image description here][6] Also see the higher quality animation on Youtube. [https://youtu.be/8icgMg6lt0Y][7] Similarly we can study where rubbish, such as plastic bags would accumulate in the oceans due to the currents; these are also called [gyres of marine debris particles][8]. See also [this link][9]. We start out just like for the Fukushima simulation: ClearAll["Global`*"]; f[teta_, r_, vx_, vy_] := {vx/(r*Sin[2*Pi*teta/4./360.]*2*Pi/360/4)*24*3600, vy/(N[r*2*Pi/360/4])*24*3600}; teta = 1; r = 6360000; In this case we have to distribute the particles randomly in all oceans. So I will basically distribute them everywhere and then ingore the ones over land mass, by checking whether the background flow speed is zero. So we first calculate the speed. velVt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", "CSV"], {k, 3 - 2, 3 + 2}]; velUt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", "CSV"], {k, 3 - 2, 3 + 2}]; xfunc = ListInterpolation[velUt, {{1, 5}, {0, 720}, {0, 1440}}]; yfunc = ListInterpolation[velVt, {{1, 5}, {0, 720}, {0, 1440}}]; We then distribute the particles everywhere teilreinpospre = Table[{3, RandomReal[{0, 720}], RandomReal[{0, 1440}]}, {k, 1, 30000}]; and delete the particles with zero-speed-background. teilreinpos = Select[teilreinpospre, xfunc[3, #[[2]], #[[3]]] != 0. && yfunc[3, #[[2]], #[[3]]] != 0. &]; Now we iterate as before. trajectories = {teilreinpos}; Monitor[Do[ velVt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; velUt = Table[If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; xfunc = ListInterpolation[velUt, {{1, 5}, {0, 720}, {0, 1440}}]; yfunc = ListInterpolation[velVt, {{1, 5}, {0, 720}, {0, 1440}}]; AppendTo[trajectories, Nest[({#[[1]], Mod[#[[2]], 720], Mod[#[[3]], 1440]}) & /@ (# + {0.1, RandomVariate[NormalDistribution[0., 0.05]] + 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[2]] , RandomVariate[NormalDistribution[0., 0.05]] + 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[ 1]] } &) , # , 10] & /@ trajectories[[-1]]]; Export["~/Desktop/Rubbish/frame" <> ToString[1000 + i] <> ".gif", Show[Import[ "~/Desktop/MovieOut/frame" <> ToString[1000 + i] <> ".gif"], Graphics[{Red, Disk[#, 1]} & /@ (0.9361111 # + {44., 28.} & /@ trajectories[[i - 2, All, {3, 2}]]), PlotRange -> {{0, 1440}, {0, 720}}]]]; , {i, 3, 1238}], i]; Here are some frames: ![enter image description here][10] This leads to the following animation (due to file size I only show a later part of the simulation). ![enter image description here][10] Please have a look at the [higher resolution and longer animation on Youtube][11]. It becomes clear that there are 5 large areas of rubbish in the oceans. This and their approximate positions are in accordance with their known positions and satellite data. This type of simulation is very much simplified. We are making many assumptions, but by using the "observed" velocity field, we get around the fluid mechanical problems usually involved in these problems. The main idea can be used for many other problems as well. For example, we could iterate backwards to see where particles came from. So I challenge you to simulate the following. Several fragments of the crashed Malaysian airplane have been found. Can you use the flow, invert the time direction and simulate where the parts must have come from? I wonder whether you can make better assmumptions than me (the larger fragments drift differently in the currents), and whether your point of origin correponds to mine. I would love to hear back from you, and get ideas of how to apply this. I had a previous discussion with Vitaliy Kaurov about this, and there are certainly much nicer ways of representing the results. Any ideas are welcome. Cheers, Marco [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Rubbish-final-optimize.gif&userId=20103 [2]: http://community.wolfram.com/web/bschelter [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2015-10-24at01.21.46.png&userId=48754 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=VelocityField.gif&userId=48754 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2015-10-24at01.28.35.png&userId=48754 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Fukushima-ok.gif&userId=48754 [7]: https://youtu.be/8icgMg6lt0Y [8]: https://en.wikipedia.org/wiki/Great_Pacific_garbage_patch [9]: https://en.wikipedia.org/wiki/File:Garbage_Patch_Visualization_Experiment.webm [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2015-10-24at01.36.47.png&userId=48754 [11]: https://youtu.be/ttJPAIBch8U Marco Thiel 2015-10-24T00:43:19Z 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/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/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/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/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/852277 X - country birth | Y - country death | RADIUS - lifetime ----------------------------------------------- ![enter image description here][1] Mongol Empire ------------- ![enter image description here][2] The [Mongol Empire][3] existed during the 13th and 14th centuries and was the **largest contiguous land empire in history**. Originating in the steppes of Central Asia, the Mongol Empire eventually stretched from Eastern Europe to the Sea of Japan, extending northwards into Siberia, eastwards and southwards into the Indian subcontinent, Indochina, and the Iranian plateau, and westwards as far as the Levant and Arabia. As you probably guessed the information is from here: WikipediaData["Mongol Empire"] And the image you see above is built with information stored in EntityProperties["HistoricalCountry"] ![enter image description here][4] Let's see what we can do with these data. First of I will get the data, - and you can see we have 1990 countries listed: hc = EntityList["HistoricalCountry"]; hc // Length (*1990*) First of all I am curious about chronology of these social structures. The data go back in time so far that sometimes we simply do not have some information. Hence I will apply some filters to drop the missing information: startend = DeleteMissing[EntityValue[hc, {"Entity", EntityProperty["HistoricalCountry", "StartDate"], EntityProperty["HistoricalCountry", "EndDate"]}], 1, 2]; startend = DeleteCases[startend, {_, _, _Alternatives}]; Now I sort by duration of country existence and look at a few countries with longest-existence: sorthc = SortBy[{#1, #3 - #2} & @@@ startend, Last]; Row[TableForm[{#1, #2, N[UnitConvert[#2, "Year"]]} & @@@ Reverse[#]] & /@{sorthc[[-10 ;;]], sorthc[[-20 ;; -11]]}, Spacer[50]] ![enter image description here][5] So the longest existing historical country according to our data is [Ordos Culture][6] counting about 28,000 years. StringTake[WikipediaData["Ordos culture"], 505] > The Ordos culture was a culture occupying a region centered on the Ordos Loop (modern Inner Mongolia, China) during the Bronze and early Iron Age from the 6th to 2nd centuries BCE. The Ordos culture is known for significant finds of Scythian art and is thought to represent the easternmost extension of Indo-European Eurasian nomads, such as the Scythians. Under the Qin and Han dynasties, from the 6th to 2nd centuries BCE, the area came under at least nominal control of contemporaneous Chinese states. Now I am curios of how the countries' lifetime was distributed throughout the whole history. Wolfram Language has a neat visualization tool - [TimelinePlot][7] - for that. We have so many countries that I will take a random sample of them to not overload the visual. SeedRandom[3]; tmp=RandomSample[startend,20]; TimelinePlot[Association@@Thread[EntityValue[tmp[[All,1]],"Name"]-> (Interval/@tmp[[All,2;;3]])],Filling->Below, FillingStyle->Directive[Opacity[.2],Orange],PerformanceGoal->"Speed"] ![enter image description here][8] And now with a larger sample of 1000 countries but without labels: SeedRandom[5]; tmp=RandomSample[startend[[All,2;;3]],1000]; TimelinePlot[Interval/@tmp,Filling->Below, PerformanceGoal->"Speed",AspectRatio->1,PlotTheme->"Marketing"] ![enter image description here][9] We see that the deeper in the past, the longer is lifetime and the fewer countries we have. This tendency can be easily visualized by plotting: BubbleChart[{#1,#2,#2-#1}&@@@Map[AbsoluteTime,startend[[;;500,2;;3]],{2}], ChartStyle->EdgeForm[Opacity[.05]],FrameTicks->None,ColorFunction->Function[{x,y,r}, RGBColor[r,1-r,1-r,r]],PerformanceGoal->"Speed",ImageSize->1000] X - country birth | Y - country death | RADIUS - lifetime ----------------------------------------------- ![enter image description here][10] Obviously above-diagonal nature is due to the fact that enddate is always later than the start date. Amazingly there are many countries that exist just a few days. Let's see the shortest living countries: fewDAYs = Cases[sorthc[[All, 2]], x_ /; x > Quantity[0, "Days"]][[;; 10]] ![enter image description here][11] TableForm@Flatten[Cases[sorthc, {_, #}] & /@ fewDAYs, 1] ![enter image description here][12] I sort countries by their lifetime in years and plot RANK vs LIFETIME in a log-log plot: yearLIFETIME=QuantityMagnitude@N[UnitConvert[Cases[sorthc[[All,2]],x_/;x>Quantity[0, "Days"]],"Year"]]; ListLogLogPlot[yearLIFETIME,PlotRange->All,PlotTheme->"Business",Filling->Bottom, FrameLabel->{"RANK","LIFETIME"},PlotLabel->"Log-Log plot in YEARs",BaseStyle->15,ImageSize->1000] ![enter image description here][13] For small-lifetime countries we see almost a **straight line - the sign of a power law**. Now I would like to take a look at some **specific counties**. Especially those who **grew spatially very fast**, - of course, due to their **military conquest**. Mongol Empire ------------- ![enter image description here][14] Let's get all polygons related to historical borders of Mongol Empire for every year between its existence 1206 -1368: mongPOLY=ParallelTable[EntityValue[Entity["HistoricalCountry","MongolEmpire"], EntityProperty["HistoricalCountry","Polygon",{"Date"->DateObject[{t}]}]],{t,1206,1368}]; For many years we have many identical borders - let's compress - find only unique borders: mongPOLY//Length mongPOLYcomp=DeleteMissing[DeleteDuplicates[ Transpose[{Range[1206,1368],mongPOLY}],Last[#1]==Last[#2]&],1,2]; mongPOLYcomp//Length 13 compressed out of total 163 total borders! I plot them all: GeoGraphics[{EdgeForm[Red], GeoStyling[Opacity[.07]], #} & /@ mongPOLYcomp[[All, 2]], GeoProjection -> "Mercator", ImageSize -> 800, GeoBackground -> GeoStyling["StreetMap"], GeoRange -> {{20, 70}, {17, 133}}, GeoZoomLevel -> 4] ![enter image description here][15] And for animation show at the top of the post: frames=ParallelTable[ GeoGraphics[{EdgeForm[Red],GeoStyling[Opacity[.07]],mongPOLYcomp[[;;t,2]]}, GeoProjection->"Mercator",ImageSize->800,GeoRange->{{20,70},{17,133}}, GeoBackground->GeoStyling["StreetMap"], Epilog->Text[Framed[Style[mongPOLYcomp[[t,1]],20,Red,Bold],Background->White], Scaled[{.06,.955}]]],{t,1,13}]; Export["MongolEmpire.gif", frames, "DisplayDurations" -> {.5}] Nazi Germany ------------ ![enter image description here][16] We need finer dates for Nazi Germany because it existed just a few years, let's choose month: ![enter image description here][17] Get all borders: gerPOLY=ParallelTable[EntityValue[Entity["HistoricalCountry","NaziGermany"], EntityProperty["HistoricalCountry","Polygon",{"Date"->DateObject[t]}]],{t,gerdates}]; gerPOLY//Length gerPOLYcomp=DeleteMissing[DeleteDuplicates[Transpose[{gerdates,gerPOLY}],Last[#1]==Last[#2]&],1,2]; gerPOLYcomp//Length 9 unique borders out 148 total! Lets plot them all: GeoGraphics[{EdgeForm[Red], GeoStyling[Opacity[.07]], gerPOLYcomp[[All, 2]]}, GeoProjection -> "Equirectangular", ImageSize -> 800, GeoBackground -> GeoStyling["StreetMap"], GeoZoomLevel -> 5] ![enter image description here][18] Now, for the history buffs of WWII, I am curious what these borders exactly correspond to in this labeled map from Wikipedia, which differentiates between occupied and allied counties. ![enter image description here][19] Kingdom of France ----------------- Using the same technique we can get the evolution of borders for the Kingdom of France (without remote colonies): ![enter image description here][20] ![enter image description here][21] You could probably even 3D print this evolution, a start is here (see attached notebook for code): ![enter image description here][22] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dsf354tegdft54twrshfgjuityutrew657.svg&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=MongolEmpire.gif&userId=11733 [3]: http://www.wolframalpha.com/input/?i=Mongol%20Empire [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_03-59-40.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_04-11-18.png&userId=11733 [6]: http://www.wolframalpha.com/input/?i=Ordos%20Culture [7]: http://reference.wolfram.com/language/ref/TimelinePlot.html [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdfe456789oiuyjthdgsdfas.png&userId=11733 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=assaf3q45teragfd.png&userId=11733 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dsf354tegdft54twrshfgjuityutrew657.svg&userId=11733 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_05-38-30.png&userId=11733 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_05-39-30.png&userId=11733 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdfqtwyrhgfbsdvs.png&userId=11733 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_05-51-52.png&userId=11733 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_03-42-48.png&userId=11733 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_05-59-31.png&userId=11733 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_06-01-10.png&userId=11733 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdafae546ythdgfsdas.png&userId=11733 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-05_18-50-08.png&userId=11733 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2016-05-06_07-34-22.png&userId=11733 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-896259266.gif&userId=11733 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdf45yehtrgsf.gif&userId=11733 Vitaliy Kaurov 2016-05-06T11:08:10Z https://community.wolfram.com/groups/-/m/t/33771 From a recent Complex System article [1] I found out about interesting mapping between Graphs and Time Series that currently gaining more and more attention. The main idea is being able to apply time series analysis methods to networks and vice versa. There is a hope of gaining new insights into familiar objects by approaching from different side. I thought it would be interesting to implement a toy example in Mathematica. I consider the simplest Horizontal Visibility Graph (HVG) algorithm which can be simply explained with the figure below. [img]http://i.imgur.com/uK2jT.png[/img]    1. Every event in time series correspond to a vertex in the graph    2. Two events are connected by edge in the graph if all events between them in time series a smaller then them in magnitude There are other more complex mapping algorithms (see references at the end), but we’ll stick with this simple one. Let’s consider three different types of time series to see what kind of networks they can produce:    1. Deterministic system: Cellular Automaton rule 54 with complex type 4 behavior    2. Stochastic system: Geometric Brownian Motion random process    3. Empirical system: Financial data of GE stock price [mcode]dataS = {FromDigits[#, 2] & /@ CellularAutomaton[54, RandomInteger[1, 200], 49], RandomFunction[GeometricBrownianMotionProcess[0, .1, 2], {1, 50, 1}][[2, 1, 1]], FinancialData["GE", "Jan. 1, 2000"][[All, 2]][[1 ;; 50]]}; ListPlot[#, Filling -> Bottom, AspectRatio -> 1/10, FillingStyle -> Thick, PlotStyle -> PointSize[.008], Axes -> {True, False}, GridLines -> {None, Automatic}, Ticks -> {Range[81], None}, ImageSize -> 800] & /@ dataS [/mcode] [img]http://i.imgur.com/aI72Q.png[/img] Define the mapping function [mcode]fied[m_, n_, data_] := If[(Min[#[[m]], #[[n]]] > Max[#[[m + 1 ;; n - 1]]]) &@data, m \[UndirectedEdge] n][/mcode]Compute the edges of the graph [mcode]edgesS = Cases[Flatten[Table[fied[m, n, #], {m, Length[#]}, {n, m + 1, Length[#]}]], _ \[UndirectedEdge] _] & /@ dataS;[/mcode]Build the graph and highlight vertexes based on vertex degree and the shortest path between initial and final events. [mcode]gS = Graph[#, GraphLayout -> "LayeredDigraphEmbedding"] & /@ edgesS; gSH = HighlightGraph[#, VertexList[#], VertexSize -> Thread[VertexList[#] -> Rescale[VertexDegree[#]]], ImageSize -> {Automatic, 500}, VertexLabels -> "Name"] & /@ gS; HighlightGraph[#, PathGraph[FindShortestPath[#, 1, 50]], GraphHighlightStyle -> "Thick"] & /@ gSH[/mcode][img]http://i.imgur.com/2bQU6.png[/img] I used LayeredDigraphEmbedding which kind of preserves chronological order of the series laying out networks nicely. I hope you enjoyed this little mapping and may apply a similar method for your own research. There are inverse mappings too - see the reference. Please feel free to share your ideas on the subject or possible algorithm optimization.    [1] [b][url=http://www.complex-systems.com/abstracts/v21_i03_a03.html]Discriminating Chaotic Visibility Graph Eigenvalues, Vincenzo Fioriti et al, Complex Systems, Vol 21, No 3, p193[/url][/b]    [2] [b][url=http://www.pnas.org/content/105/13/4972.full]From time series to complex networks: The visibility graph[/url][/b]    [3] [b][url=http://www.ncbi.nlm.nih.gov/pmc/articles/PMC3154932/pdf/pone.0023378.pdf]Duality between Time Series and Networks[/url][/b]    [4] [b][url=http://arxiv.org/find/all/1/AND+abs:+AND+visibility+graph+abs:+AND+time+series/0/1/0/all/0/1?skip=0&query_id=701ef182d80b670f]Some related arXiv.org papers[/url][/b] Vitaliy Kaurov 2013-01-17T03:13:27Z https://community.wolfram.com/groups/-/m/t/835603 > When I was 15 years old General Motors dropped a big V8 into the Chevy. That was one of the happiest days of my life. I couldn't wait to drive one of those Chevies. And I had exactly the same feeling when somebody dropped Mathematica into a Macintosh. This is one of my favorite quotes about Mathematica. It is by Jerry Uhl, a math professor from the University of Illinois at Urbana–Champaign, said in 1989, as you can witness in the video below. For those of you who enjoys history, here is a wonderful piece, a glance into the Wolfram past. There is a YouTube channel, The ReDiscovered Future, which acts as the public "silver screen" of an initiative that aims to rescue video and audio recordings from older, volatile formats, store them on more reliable media, and share them with the world. They've just published a delightful video: [Macintosh + Mathematica = Infinity - April 1989][1] [![enter image description here][2]][3] I like how there are so many things that said then but still hold true. Of course this goes for the Alfred North Whitehead quote they started from: > Civilization advances by extending the number of important operations which we can perform without thinking about them. And the quote from student Donald Brown: " > With the use of Mathematica you are allowed in some sense to wander into zones of thoughts where you might not be inclined to go otherwise. Note already then the ideas of automation, [Computer Based Math][4], data accessibility, and diversity of computation in sciences. In the video Donald A. Glaser, who got the Nobel Prize in Physics 1960 for the invention of the bubble chamber speaks very nicely of importance of automation for cultivating intuition: > I think science will always have the same amount of perspiration and inspiration as before but we will eliminate calculus and differential equations and graphics from the perspiration category and that'll give us more time for having more sophisticated inspirations. Mathematica hadn't touch me then yet. I experience it fully later coming to USA. But then in 1989 we of course did do some computing in Soviet Union. That was two years before the Soviet regime would end after 69 years of reign. We used computers like the one shown on the photo below. The [Iskra-1030][5] was a Soviet version of IBM's PC/XT, a personal computer based on the processor analogical to the Intel 8086. The model had 256 KB RAM expandable to 1MB, also featured hard drives - up to 10 MB. So I did not use Mathematica, but I did run some programs simulating Cellular Automata that I was reading about in [Stephen Wolfram papers][6] already published then. They were fascinating systems to me, because of the mysterious link between simplicity of rules and complexity of behavior. So the most fundamental [NKS][7] computations of simple programs reached me earlier. What a pleasant surprise was to discover [CellularAutomaton][8] function in Wolfram Language later that replaced pages of my old Soviet code. What do you think? Any recollections or quotes? How did Wolfram ideas enter your life? ![enter image description here][9] [1]: https://www.youtube.com/watch?v=3A5moyhfaQo [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdfq34tgdsagrqevassarv.png&userId=11733 [3]: https://www.youtube.com/watch?v=3A5moyhfaQo [4]: https://www.computerbasedmath.org/ [5]: https://en.wikipedia.org/wiki/Iskra-1030 [6]: http://www.stephenwolfram.com/publications/academic/?cat=cellular-automata [7]: https://www.wolframscience.com/ [8]: http://reference.wolfram.com/language/ref/CellularAutomaton.html [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=%D0%98%D0%A1%D0%9A%D0%A0%D0%90_1030.11.jpg&userId=11733 Vitaliy Kaurov 2016-04-06T18:41:57Z 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/1248938 #Making a Christmas Animation with the Wolfram Language# ![enter image description here][1] This notebook describes how to build an animation of a decorated pine tree that moves its branches synchronized to the voices of the music of the 16th century German [*O Tannenbaum*][2] song (the English version is *O Christmas Tree*). One dedicated branch of the tree will act as the conductor and a candle will be the baton. The keep the animation interesting through all versus we will also add some snowfall and some ecstatic tree movements in the second half of the song. To see the final design watch this [YouTube video][3]: [![enter image description here][4]][3] I will implement the animation through the following steps: 1) Build a pine tree with curved branches where the branches can be moved smoothly up and down and left and right. 2) Add ornaments (colored balls, five-pointed stars) and candles of different color to the branches. Allow the ornaments to be moved with respect to the branch tips. 3) Convert the 4 voices of the music to a 2D movement based on the frequencies of the sound. Model the conductor movements in sync with the music. 4) Model the movements of the ornaments as forced spherical pendula. Account for friction of the ornaments using the Rayleigh dissipation function. 5) Add some snowfall for having a white Christmas. 6) Build the animation with the branches using according to the music. Special thanks to my coworker Andrew Steinacher for selecting the music and analyzing the music to get the data for the tree movements (the below section From Music to Movements). And thanks to Amy Young for turning the animation frames and the music into one video clip. #Making a Pine Tree# ##Tree Parameters## The tree dimensions, the overall shape of the tree and counts of branches. The variable names make their meaning obvious. (* radial branch count *) radialBranchCount = 3; (* vertical branch count *) verticalBranchCount = 5; (* tree height *) treeHeight = 12; (* tree width *) treeWidth = 6; (* plot points for the B-spline surfaces forming the branches *) {?, ?} = {6, 8}; Colors of stem and branches. stemColor = Directive[Darker[Brown], Lighting -> "Neutral", Specularity[Brown, 20]]; branchTopColor = RGBColor[0., 0.6, 0.6]; branchBottomColor = RGBColor[0., 0.4, 0.4]; branchSideColor = RGBColor[0.4, 0.8, 0.]; ##Grow a Movable Tree Branch## Each branch has a rectangle cross section with changing dimension (as a function of the distance from the stem). The tip of the branch should be pointing slightly upwards to have the iconic shape of a Christmas tree. At its widest size, the branch is made to fit smoothly to a cone (the stem). The variable $\tau$ determines the up-down and variable $\sigma$ the left-right position of the tip of the branch. I build a branch from four B-spline surfaces (top, bottom, left, right) to have a smooth appearance with only a small number of points defining the surface. branchTopBottom[ tp_, {hb_, ht_}, {?1_, ?2_}, {rb_, rt_}, R_, {?_, ?_}] := Module[{A = -0.6, ? = 1/2, ?m, Pm, dirR, dir?, r, P1, P, \[ScriptN], \[ScriptP], x, y, ?, ?, ?, \[ScriptH]s, \[ScriptH]}, ?m = Mean[{?1, ?2}]; Pm = R {Cos[?m], Sin[?m]}; dirR = 1. {Cos[?m], Sin[?m]}; dir? = Reverse[dirR] {-1, 1}; r = If[tp == "top", rt, rb]; (* move cross section radially away from the stem and contract it *) Table[P1 = {r Cos[?], r Sin[?]}; Table[P = P1 + s/? (Pm - P1); \[ScriptN] = dir?.P; \[ScriptP] = dirR.P; {x, y} = \[ScriptN] Cos[ s/? Pi/2]^2 dir? + \[ScriptP] dirR; ? = ?* 1. s/? Abs[?2 - ?1]/ radialBranchCount; ? = {{Cos[?], Sin[?]}, {-Sin[?], Cos[?]}}; {x, y} = ?.{x, y}; ? = R s/?; \[ScriptH]s = {ht, hb} + {? (A R (R - ?) - (hb - ht) (? - 1) ?), (ht - hb) ?^2 ?}/R^2; \[ScriptH] = If[tp == "top", \[ScriptH]s[[1]], \[ScriptH]s[[2]]] ; {x, y, \[ScriptH] + ? s/? (ht - hb)}, {s, 0, ?}], {?, ?1, ?2, (?2 - ?1)/?}] // N ] The radius at height h is just the linear interpolation of the maximal stem radius and radius 0 at the top. stemRadius[h_, H_] := (H - h)/H The sides of a branch are just the connecting pieces between the top and the bottom surfaces. branchOnStem[{{hb_, ht_}, {?1_, ?2_}, R_}, {?_, ?_}] := Module[{tBranch, bBranch, sideBranches}, {bBranch, tBranch} = Table[branchTopBottom[p, {hb, ht}, {?1, ?2}, stemRadius[{hb, ht}, treeHeight], R, {?, ?}], {p, {"top", "bottom"}}]; sideBranches = Table[BSplineSurface[{tBranch[[j]], bBranch[[j]]}], {j, {1, -1}}]; {branchTopColor, BSplineSurface[tBranch], branchBottomColor, BSplineSurface[bBranch], branchSideColor, sideBranches} ] For later use, let's define a function for the tip position only. branchOnStemEndPoint[ {{hb_, ht_}, {?1_, ?2_}, R_}, {?_, ?_}] := Module[{A = -0.6, ? = 1/2, Pm, dirR, dir?, P, \[ScriptN], \[ScriptP], x, y, ?, ?, \[ScriptH]s, \[ScriptH], ? = ?1, ?m = Mean[{?1, ?2}]}, Pm = R {Cos[?m], Sin[?m]}; dirR = {Cos[?m], Sin[?m]}; {x, y} = dirR.Pm dirR; ? = 1. ? Abs[?2 - ?1]/radialBranchCount; {x, y} = {{Cos[?], Sin[?]}, {-Sin[?], Cos[?]}}.{x, y}; \[ScriptH]s = {ht, hb} + (ht - hb) {? - 1., 1}; {x, y, \[ScriptH]s[[1]] + ? (ht - hb)} ] An interactive demonstration that lets the branch and the branch tip around as a function of {?,?}. Manipulate[ Graphics3D[{branchOnStem[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2}, 1 + ?}, ??], Red, Sphere[branchOnStemEndPoint[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2}, 1 + ?}, ??], 0.05]}, PlotRange -> {{-2, 2}, {0, 4}, {-1, 2}}, ViewPoint -> {3.17, 0.85, 0.79}], {{?, 1.6, "branch length"}, 0, 2, ImageSize -> Small}, {{??, {0, 0}, "branch\nleft/right\nup/down"}, {-1, -1}, {1, 1}}, ControlPlacement -> Left, SaveDefinitions -> True] ![enter image description here][5] ##Adding Branches to a Tree Stem## The stem is just a cone with the cone tip being the tree top. stem = Cone[{{0, 0, 0}, {0, 0, treeHeight}}, 1]; Branch dimensions decrease with height; getting geometrically smaller. The total of all branch levels equals the tree height minus the step part at the bottom. heightList1 = Module[{? = 0.8, hs, sol}, hs = Prepend[Table[C ?^k, {k, 0, verticalBranchCount - 1}], 0]; sol = Solve[Total[hs] == 10, C, Reals]; Accumulate[hs /. sol[[1]]]] > {0, 2.97477, 5.35459, 7.25845, 8.78153, 10.} treeWidthOfHeight[h_] := treeWidth (treeHeight - h)/treeHeight The branches fit snug onto the stem, no gaps in-between. Graphics3D[{{stemColor, stem}, {Darker[Green], Table[Table[ branchOnStem[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}], {k, 0, 1}] , {j, 1, verticalBranchCount}]}}, ViewPoint -> {2.48, -2.28, 0.28}] ![enter image description here][6] Graphics3D[{{stemColor, stem}, {Darker[Green], Table[Table[ branchOnStem[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}]}}, ViewPoint -> {2.48, -2.28, 0.28}] ![enter image description here][7] Interleave branches to get a more realistic tree shape. This is the tree I will be using in the following. It is straightforward to change the tree parameters and use another tree. heightList2 = {2/3, 1/3}.# & /@ Partition[heightList1, 2, 1]; Graphics3D[{{Darker[Brown], stem}, {EdgeForm[], Table[ Table[branchOnStem[ {2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}], Table[Table[ branchOnStem[{2 + heightList2[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount + Pi/radialBranchCount, treeWidthOfHeight[Mean[heightList2[[{j, j + 1}]]]]}, {0, 0}], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount - 1}]}}, ViewPoint -> {2.48, -2.28, 0.28}] ![enter image description here][8] One could easily make even denser trees with more branches. Graphics3D[{{Darker[Brown], stem}, {EdgeForm[], Table[Table[branchOnStem[ {2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/(2 radialBranchCount) , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}], {k, 0, (2 radialBranchCount) - 1}] , {j, 1, verticalBranchCount}], Table[Table[branchOnStem[{2 + heightList2[[{j, j + 1}]], {k , k + 1} 2 Pi/(2 radialBranchCount) + Pi/(2 radialBranchCount), treeWidthOfHeight[Mean[heightList2[[{j, j + 1}]]]]}, {0, 0}], {k, 0, 2 radialBranchCount - 1}] , {j, 1, verticalBranchCount - 1}]}}, ViewPoint -> {2.48, -2.28, 0.28}] ![enter image description here][9] #Decorating the Tree# Now let's construct a few ornaments to build a nicely decorated Christmas tree. I all add shiny balls, five-pointed stars and candles. I recommend original Thuringian Lauscha baubles for your Christmas tree. (You can get them [here][10].) ##Ornaments, Candles, and the Top## ###Colored Balls### A must on every tree are some shiny glass spheres, baubles. coloredBall[p_, size_, color_, {?_, ?_}] := Module[{\[ScriptD] = {Cos[?] Sin[?], Sin[?] Sin[?], -Cos[?]}}, {EdgeForm[], GrayLevel[0.4], Specularity[Yellow, 20], Cylinder[{p, p + 1.5 size \[ScriptD]}, 0.02 size ], color, Specularity[Yellow, 10], Sphere[p + (1.5 size + 0.6 size) \[ScriptD] , 0.6 size] }] Graphics3D[{coloredBall[{1, 2, 3}, 1, Red, {0, 0}], coloredBall[{3, 2, 3}, 1, Darker[Blue], {1, 0.2}]}, Axes -> True] ![enter image description here][11] branchOnStemWithBall[{{hb_, ht_}, {?1_, ?2_}, R_}, {?_, ?_}, color_, {?_, ?_}] := {branchOnStem[{{hb, ht}, {?1, ?2}, R}, {?, ?}] , coloredBall[ branchOnStemEndPoint[{{hb, ht}, {?1, ?2}, R}, {?, ?}], 0.45 (ht - hb)/2, color, {?, ?}]} Here is a branch with a bauble. The {?,?} variables allow to change the position of the ball relative to the branch tip. Manipulate[ Graphics3D[{branchOnStemWithBall[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2}, 1 + ?}, ??, Red, ??]}, PlotRange -> {{-2, 2}, {0, 4}, {-2, 2}}, ViewPoint -> {3.17, 0.85, 0.79}], {{?, 1.6, "branch length"}, 0, 2, ImageSize -> Small}, {{??, {0.6, 0.26}, "branch\nleft/right\nup/down"}, {-1, -1}, {1, 1}}, {{??, {2.57, 1.88}, "ball angles"}, {0, -Pi}, {Pi, Pi}}, ControlPlacement -> Left, SaveDefinitions -> True] ![enter image description here][12] Here is a tree with balls mostly straight down. I will use random colors for the balls. Graphics3D[{{Darker[Brown], stem}, {Table[ Table[branchOnStemWithBall[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}, RandomColor[], {0, 0}], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}] }}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True] ![enter image description here][13] A tree with balls in random directions. If later the branches will be moved, the natural movements (meaning the solution of the corresponding equations of motion) of the balls will be calculated. Graphics3D[{{Darker[Brown], stem}, {Table[ Table[branchOnStemWithBall[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}, RandomColor[], {RandomReal[{-Pi, Pi}], RandomReal[{0, Pi}]}], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}]}}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True] ![enter image description here][14] ##Five-pointed Stars## Now some 5-stars. As this ornament is not rotational symmetric, I allow for an orientation angle with respect to the thread it hangs on. coloredFiveStar[p_, size_, dir_, color_, ?_, {?_, ?_}] := Module[{\[ScriptD] = {Cos[?] Sin[?], Sin[?] Sin[?], -Cos[?]}, points, P1, P2, d1, d2, d3, dP, dP2}, d2 = Normalize[dir - dir.\[ScriptD] \[ScriptD]]; d3 = Cross[\[ScriptD], d2]; {EdgeForm[], GrayLevel[0.4], Specularity[Pink, 20], Cylinder[{p, p + (1.5 size + 0.6 size) \[ScriptD]}, 0.02 size ], color, Specularity[Hue[.125], 5], dP = Sin[?] d2 + Cos[?] d3; dP2 = Cross[\[ScriptD], dP]; points = Table[p + (1.5 size + 0.6 size) \[ScriptD] + size If[EvenQ[j], 1, 1/2] * (Cos[j 2 Pi/10 ] \[ScriptD] + Sin[j 2 Pi/10] dP), {j, 0, 10}]; P1 = p + (1.5 size + 0.6 size) \[ScriptD] + size/3 dP2; P2 = p + (1.5 size + 0.6 size) \[ScriptD] - size/3 dP2; {P1, P2} = (p + (1.5 size + 0.6 size) \[ScriptD] + # size/ 3 dP2) & /@ {+1, -1}; Polygon[ Join @@ (Function[a, Append[#, a] & /@ Partition[points, 2, 1]] /@ {P1, P2})] }] Graphics3D[{coloredFiveStar[{1, 2, 3}, 0.2, {0, -1, 0}, Darker[Red], 0, {0, 0}], coloredFiveStar[{1.5, 2, 3}, 0.2, {0, -1, 0}, Darker[Purple], Pi/3, {1, 0.4}]}] ![enter image description here][15] branchOnStemWithFiveStar[{{hb_, ht_}, {?1_, ?2_}, R_}, {?_, ?_}, color_, ?_, {?_, ?_}] := Module[{dir = Append[Normalize[ Mean[{{Cos[?1], Sin[?1]}, {Cos[?2], Sin[?2]}}]], 0]}, {branchOnStem[{{hb, ht}, {?1, ?2}, R}, {?, ?}] , coloredFiveStar[ branchOnStemEndPoint[{{hb, ht}, {?1, ?2}, R}, {?, ?}], 0.4 (ht - hb)/2, dir, color, ?, {?, ?}]} ] A tree decorated with 5-stars. Graphics3D[{{Darker[Brown], stem}, {Table[ Table[branchOnStemWithFiveStar[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}, RandomColor[], RandomReal[{-Pi, Pi}], {RandomReal[{-Pi, Pi}], RandomReal[0.1 {-1, 1}]}], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}] }}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True] ![enter image description here][16] ##Candles## Build from a foot that attaches to the branch tips, a wax-like body, a blackened wick, and a flame. To make like easier for the animation and to avoid fire hazards, I will use electric candles so that the flame will not change shape as the branches move around. flamePoints = Table[{0.2 Sin[Pi z]^2 Cos[?], 0.2 Sin[Pi z]^2 Sin[?], z}, {z, 0, 1, 1/1/12}, {?, Pi/2, 5/2 Pi, 2 Pi/24}] litCandle[p_, size_, color_] := {EdgeForm[], color, Cylinder[{p + {0, 0, size 0.001}, p + {0, 0, size 0.5}}, size 0.04], GrayLevel[0.1], Specularity[Orange, 20], Cylinder[{p, p + {0, 0, size 0.05}}, size 0.06], Black, Glow[Black], Cylinder[{ p + {0, 0, size 0.5}, p + {0, 0, size 0.5 + 0.05 size}}, size 0.008], Glow[Orange], Specularity[Hue[.125], 5], BSplineSurface[ Map[(p + {0, 0, size 0.5} + 0.3 size #) &, flamePoints, {2}], SplineClosed -> {True, False}] } A white and a red candle. Graphics3D[{litCandle[{0, 0, 0}, 1, Directive[White, Glow[GrayLevel[0.3]], Specularity[Yellow, 20]]], litCandle[{0.5, 0, 0}, 1, Directive[Red, Glow[GrayLevel[0.1]], Specularity[Yellow, 20]]]}] ![enter image description here][17] Later, I will use an extended branch with a candle to be the conductor, so I will allow the candle to be tilted away from the stem. branchOnStemWithCandle[{{hb_, ht_}, {?1_, ?2_}, R_}, {?_, ?_}, color_, ?_] := {branchOnStem[{{hb, ht}, {?1, ?2}, R}, {?, ?}] , If[? == 0, litCandle[ branchOnStemEndPoint[{{hb, ht}, {?1, ?2}, 0.98 R}, {?, ?}], 0.66 (ht - hb) , color], Module[{P = branchOnStemEndPoint[{{hb, ht}, {?1, ?2}, 0.98 R}, {?, ?}], dir}, dir = Append[Reverse[Take[P, 2]] {-1, 1}, 0]; Rotate[ litCandle[ branchOnStemEndPoint[{{hb, ht}, {?1, ?2}, 0.98 R}, {?, ?}], 0.66 (ht - hb) , color], ?, dir, P]]]} Manipulate[ Graphics3D[{branchOnStemWithCandle[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2}, 1 + ?}, ??, Red, ?]}, PlotRange -> {{-2, 2}, {0, 4}, {-2, 2}}, ViewPoint -> {3.17, 0.85, 0.79}], {{?, 1.6, "branch length"}, 0, 2, ImageSize -> Small}, {{??, {0, 0}, "branch\nleft/right\nup/down"}, {-1, -1}, {1, 1}}, {{?, Pi/4, "candle angle"}, -Pi, Pi}, ControlPlacement -> Left, SaveDefinitions -> True] And here is a tree with a candle on each branch. Graphics3D[{{Darker[Brown], stem}, {Table[ Table[branchOnStemWithCandle[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0}, White, 0], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}] }}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True] ![enter image description here][18] ##Tree Topper## For fun, I add a rotatable spikey at the top. spikey = Cases[ N@Entity["Polyhedron", "RhombicHexecontahedron"][ "Image"], _GraphicsComplex, ?][[1]]; top = {Gray, Specularity[Red, 25], Cone[{{0, 0, 0.9 treeHeight}, {0, 0, 1.08 treeHeight}}, treeWidth/240], Orange, EdgeForm[Darker[Orange]], Specularity[Hue[.125], 5], MapAt[((0.24 # + {0, 0, 1.08 treeHeight}) & /@ #) &, spikey, 1] } Graphics3D[{{Darker[Brown], stem}, {Table[ Table[branchOnStem[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0} ], {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}], top}}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True] ![enter image description here][19] ##Decorating the Tree## We will single out a single branch as the conductor. The remaining branches we will randomly divide into four groups and decorate them with baubles of two colors, five-pointed stars, and candles. Now let's add an ornament or a candle on every tree branch. I will use the above tree with 27 branches. I start the branches by height on the stem and by azimuthal angle. allBranches = Flatten[Riffle[ Table[Table[{2 + heightList1[[{j, j + 1}]], {k , k + 1} 2. Pi/ radialBranchCount , treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount}], Table[Table[{2 + heightList2[[{j, j + 1}]], {k , k + 1} 2. Pi/ radialBranchCount + Pi/radialBranchCount, treeWidthOfHeight[Mean[heightList2[[{j, j + 1}]]]]}, {k, 0, radialBranchCount - 1}] , {j, 1, verticalBranchCount - 1}]], 1] Length[allBranches] > 27 Color branches by index, starting at the bottom in red to the top in purple. Graphics3D[{{Darker[Brown], stem}, MapIndexed[(branchOnStem[#1, {0, 0}] /. _RGBColor :> Hue[#2[[1]]/36]) &, allBranches], top}, ViewPoint -> {2, 1, -0.2}] ![enter image description here][20] Split all branches into 4 groups for the voices and a conductor branch. conductorBranch = 7; SeedRandom[12]; voiceBranches = (Last /@ #) & /@ GroupBy[{RandomChoice[{1, 2, 3, 4}], #} & /@ Delete[Range[27], {conductorBranch}], First] > <|1 -> {1, 4, 5, 6, 12, 18, 20}, 3 -> {2, 8, 10, 11, 14, 22, 23, 25}, > 2 -> {3, 13, 15, 16, 21, 26}, 4 -> {9, 17, 19, 24, 27}|> voiceBranches = <|1 -> {2, 9, 14, 17, 19, 24, 27}, 2 -> {3, 13, 15, 16, 21, 26}, 3 -> {1, 4, 5, 12, 18, 20}, 4 -> {6, 8, 10, 11, 22, 23, 25}|> > <|1 -> {2, 9, 14, 17, 19, 24, 27}, 2 -> {3, 13, 15, 16, 21, 26}, 3 > -> {1, 4, 5, 12, 18, 20}, 4 -> {6, 8, 10, 11, 22, 23, 25}|> Here is a plot of the branches colored according to which voice they represent. Graphics3D[{{Darker[Brown], stem}, branchOnStem[#1, {0, 0}] & /@ allBranches[[voiceBranches[[1]]]] /. _RGBColor :> Yellow, branchOnStem[#1, {0, 0}] & /@ allBranches[[voiceBranches[[2]]]] /. _RGBColor :> White, branchOnStem[#1, {0, 0}] & /@ allBranches[[voiceBranches[[3]]]] /. _RGBColor :> LightBlue, branchOnStem[#1, {0, 0}] & /@ allBranches[[voiceBranches[[4]]]] /. _RGBColor :> Pink, branchOnStem[ allBranches[[conductorBranch]] {1, 1, 1.5}, {0, 0}] /. _RGBColor :> Red, top}, ViewPoint -> {2, 1, -0.2}] ![enter image description here][21] The final tree with the branch tip positions as parameters. Also allow the ornaments on the branch tips angled and colored. christmasTree[{{?1_, ?1_}, {?2_, ?2_}, {?3_, ?3_}, {?4_, ?4_}, {?c_, ?c_}}, {{?1_, ?1_}, {?2_, ?2_}, {?3_, ?3_}}, {colBall1_, colBall2_, col5Star_}, conductorEnhancementFactor : fc_, conductorCandleAngle : ?c_, topRotationAngle : ?_] := {{Darker[Brown], stem}, branchOnStemWithBall[#, {?1, ?1}, colBall1, {?1, ?1}] & /@ allBranches[[voiceBranches[[1]]]], branchOnStemWithBall[#, {?2, ?2}, colBall2, {?2, ?2}] & /@ allBranches[[voiceBranches[[2]]]], branchOnStemWithFiveStar[#, {?3, ?3}, col5Star, Pi/4, {?3, ?3}] & /@ allBranches[[voiceBranches[[3]]]], branchOnStemWithCandle[#, {?4, ?4}, Directive[White, Glow[GrayLevel[0.3]], Specularity[Yellow, 20]], 0] & /@ allBranches[[voiceBranches[[4]]]], branchOnStemWithCandle[ allBranches[[conductorBranch]] {1, 1, 1 + fc}, {?c, ?c}, Directive[Red, Glow[GrayLevel[0.1]], Specularity[Yellow, 20]], ?c], Rotate[top, ?, {0, 0, 1}] }; Resting position of all branches and the conductor branch elongated and its candle angled. Graphics3D[christmasTree[{{0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}}, {{0, 0}, {0,0}, {0, 0}}, {Red, Darker[Yellow], Pink}, 0.8, Pi/4, 0], ImageSize -> 600, ViewPoint -> {3.06, 1.28, 0.27}, PlotRange -> {{-7, 7}, {-7, 7}, {0, 15}}] ![enter image description here][22] Three trees with all parameters selected randomly. SeedRandom[1] Table[Graphics3D[christmasTree[RandomReal[1.5 {-1, 1}, {5, 2}], Table[{RandomReal[{-Pi, Pi}], RandomReal[{0, Pi}]}, 3], RandomColor[3], RandomReal[], RandomReal[Pi/2], 0], ImageSize -> 200, ViewPoint -> {3.06, 1.28, 0.27}, PlotRange -> {{-7, 7}, {-7, 7}, {-2, 15}}], {3}] // Row ![enter image description here][23] The following interactive demonstrations allows to move the branches, move ornaments around with respect to the branch tips and to color the ornaments to ones personal preferences. Manipulate[ Graphics3D[ christmasTree[{??1, ??2, ??3, ??4, ??c}, {??1, ??2, ??3}, {col1, col2, col3}, l, ?c, ?], ImageSize -> 400, ViewPoint -> {2.61, 1.99, 0.80}, PlotRange -> {{-7, 7}, {-7, 7}, {-2, 15}}], "conductor", {{l, 0.6, "branch length"}, 0, 1, ImageSize -> Small}, {{?c, Pi/4, "candle angle"}, 0, Pi, ImageSize -> Small}, {{??c, {0, 0}, "movement"}, {-1, -1}, {1, 1}, ImageSize -> Small}, Delimiter, "voice 1 (balls)", Grid[{{"movement", "ornament"}, {Control[{{??1, {0, 0}, ""}, {-1, -1}, {1, 1}, ImageSize -> Small}], Control[{{??1, {0, 0}, ""}, {-Pi, 0}, {Pi, Pi}, ImageSize -> Small}]}}], {{col1, Red, ""}, Red, ImageSize -> Tiny}, Delimiter, "voice 2 (balls)", Grid[{{"movement", "ornament"}, {Control[{{??2, {0, 0}, ""}, {-1, -1}, {1, 1}, ImageSize -> Small}], Control[{{??2, {0, 0}, ""}, {-Pi, 0}, {Pi, Pi}, ImageSize -> Small}]}}], {{col2, Darker[Yellow], ""}, Red, ImageSize -> Tiny}, Delimiter, "voice 3 (5-star)", Grid[{{"movement", "ornament"}, {Control[{{??3, {0, 0}, ""}, {-1, -1}, {1, 1}, ImageSize -> Small}], Control[{{??3, {0, 0}, ""}, {-Pi, 0}, {Pi, Pi}, ImageSize -> Small}]}}], {{col3, Pink, ""}, Red, ImageSize -> Tiny}, Delimiter, "voice 4 (white candles)", Control[{{??4, {0, 0}, "movement"}, {-1, -1}, {1, 1}, ImageSize -> Small}], Delimiter, Delimiter, {{?, 0, "top rotation"}, 0, 1, ImageSize -> Small}, ControlPlacement -> Left, SaveDefinitions -> True] ![enter image description here][24] #From Music to Movements# So, now that I have dealt with the making a parametrized decorated Christmas tree with movable branches and ornaments, I must deal with relating the music to the movements of the branches (and in turn the ornaments). ##Get the 4 Voices as Sound## Use a MIDI file of the song. ![enter image description here][25] {ohTannenBaum // Head, ohTannenBaum // ByteCount} > {Sound, 287816} Extract the 4 voices. voices = AssociationThread[{"Soprano", "Alto", "Tenor", "Bass"}, ImportString[ ExportString[ohTannenBaum, "MIDI"], {"MIDI", "SoundNotes"}]]; Sound[Take[#, 10]] & /@ voices ![enter image description here][26] ##Voices to Frequencies## frequencyRules = <|"A1" -> 55., "A2" -> 110., "A3" -> 220., "A4" -> 440., "B1" -> 61.74, "B2" -> 123.5, "B3" -> 246.9, "B4" -> 493.9, "C2" -> 65.41, "C3" -> 130.8, "C4" -> 261.6, "C5" -> 523.3, "D2" -> 73.42, "D#4" -> 311.13, "D4" -> 293.7, "D5" -> 587.3, "E2" -> 82.41, "E4" -> 329.6, "E5" -> 659.3, "F#2" -> 92.50, "F#4" -> 370.0, "G2" -> 98.00, "G#4" -> 415.3, "G4" -> 392.0|>; {minf, maxf} = MinMax[frequencyRules] > {55., 659.3} Time-frequency plot of the first voice. pw[t_] = Piecewise[{frequencyRules[#1], #2[[1]] <= t <= #2[[2]]} & @@@ voices[[1]]]; Plot[pw[t], {t, 0, 100}, PlotRange -> {200, All}, Filling -> Axis, PlotLabel -> "Soprano", Frame -> True, FrameLabel -> {"time in sec", "frequency in Hz"}, AxesOrigin -> {0, 200}] ![enter image description here][27] For representing the frequencies in the movements, I will smooth the curves. spline = BSplineFunction[Table[{t, pw[t]}, {t, 0, 100, 0.5}], SplineDegree -> 2] ![enter image description here][28] ParametricPlot[spline[t], {t, 0, 100}, AspectRatio -> 0.5, PlotPoints -> 1000] ![enter image description here][29] tMax = 100; Do[ With[{j = j}, pwf[j][t_] = Piecewise[{frequencyRules[#1], #2[[1]] <= t <= #2[[2]]} & @@@ voices[[j]]]; splineFunction[j] = BSplineFunction[Table[{t, pwf[j][t]}, {t, 0, 100, 0.5}], SplineDegree -> 2]; voiceFunction[j][t_Real] := If[0 < t < tMax, splineFunction[j][t/tMax][[2]]/maxf, 0]], {j, 4}] The frequencies of the four voices. Plot[Evaluate[Reverse@Table[pwf[j][t], {j, 4}]], {t, 0, 100}, Frame -> True, FrameLabel -> {"time in sec", "frequency in Hz"}, AspectRatio -> 0.3] ![enter image description here][30] Smoothed scaled frequencies of the four voices. Plot[Evaluate[Table[voiceFunction[j][t], {j, 4}]], {t, 0, 100}, Frame -> True, FrameLabel -> {"time in sec", "scaled frequency"}, AspectRatio -> 0.3] ![enter image description here][31] Here is a plot of the (smoothed) first three voices as a 3D plot. ParametricPlot3D[{voiceFunction[1][t], voiceFunction[2][t], voiceFunction[3][t]}, {t, 0, 100}, AspectRatio -> Automatic, PlotPoints -> 1000, BoxRatios -> {1, 1, 1}] ![enter image description here][32] Show[% /. Line[pts_] :> Tube[pts, 0.002], Method -> {"TubePoints" -> 4}] ![enter image description here][33] ##Get Sway Pattern## Anchor to particular phrases to generate all measure beats. {firstBeat, secondBeat, lastBeat} = voices["Soprano"][[{1, 2, -1}, 2, 1]] > {1.33522, 2.00568, 98.7727} anchorDataOChristmasTree = SequenceCases[ voices["Soprano"], (* pattern for "O Christmas Tree, O Christmas Tree..." *) { SoundNote["D4", {pickupStart_, _}, "Trumpet", ___], SoundNote["G4", {beatOne_, _}, "Trumpet", ___], SoundNote["G4", {_, _}, "Trumpet", ___], SoundNote["G4", {beatTwo_, _}, "Trumpet", ___], SoundNote["A4", {beatThree_, _}, "Trumpet", ___], SoundNote["B4", {beatFour_, _}, "Trumpet", ___], SoundNote["B4", {_, _}, "Trumpet", ___], SoundNote["B4", {beatFive_, _}, "Trumpet", ___] } :> <| "PhraseName" -> "O Christmas Tree", "PickupBeat" -> pickupStart, "TargetMeasureBeats" -> {beatOne, beatTwo, beatThree}, "BeatLength" -> Mean@Differences[{pickupStart, beatOne, beatTwo, beatThree, beatFour, beatFive}] |> ]; anchorDataYourBoughsSoGreen = SequenceCases[ voices["Soprano"], (* "Your boughs so green in summertime..." *) { SoundNote["D5", {pickupBeatAnd_, _}, "Trumpet", ___], SoundNote["D5", {beatOne_, _}, "Trumpet", ___], SoundNote["B4", {_, _}, "Trumpet", ___], SoundNote["E5", {beatTwo_, _}, "Trumpet", ___], SoundNote["D5", {beatThreeAnd_, _}, "Trumpet", ___], SoundNote["D5", {beatFour_, _}, "Trumpet", ___], SoundNote["C5", {_, _}, "Trumpet", ___], SoundNote["C5", {beatFive_, _}, "Trumpet", ___] } :> With[ { (* the offbeat nature of this phrase requires some manual work to get things lined up in terms of actual beats *) pickupBeatStart = pickupBeatAnd - (beatOne - pickupBeatAnd), beatThree = beatThreeAnd - (beatFour - beatThreeAnd) }, <| "PhraseName" -> "Your boughs so green in summertime", "PickupBeat" -> pickupBeatStart, "TargetMeasureBeats" -> {beatOne, beatTwo, beatThree}, "BeatLength" -> Mean@Differences[{pickupBeatStart, beatOne, beatTwo, beatThree, beatFour, beatFive}] |> ] ]; anchorData0 = Join[anchorDataOChristmasTree, anchorDataYourBoughsSoGreen] // SortBy[#PickupBeat &]; meanBeatLength = Mean[anchorData0[[All, "BeatLength"]]]; (* add enough beats to fill the end of the song, which ends on beat 2 *) anchorData = Append[anchorData0, <| "TargetMeasureBeats" -> (lastBeat + {-1, 0, 1}* Last[anchorData0]["BeatLength"]), "BeatLength" -> Last[anchorData0]["BeatLength"]|>]; anchorData = Append[anchorData, <| "TargetMeasureBeats" -> (lastBeat + ({-1, 0, 1} + 3)* Last[anchorData]["BeatLength"]), "BeatLength" -> Last[anchorData]["BeatLength"]|>]; Interpolate the beats between and during phrases: interpolateAnchor = Apply[ Function[{currentAnchor, nextAnchor}, With[ {targetMeasureLastBeat = Last[currentAnchor["TargetMeasureBeats"]], nextMeasureFirstBeat = First[nextAnchor["TargetMeasureBeats"]]}, DeleteDuplicates@Join[ currentAnchor["TargetMeasureBeats"], Range[targetMeasureLastBeat, nextMeasureFirstBeat - currentAnchor["BeatLength"]/4., Mean[{currentAnchor["BeatLength"], nextAnchor["BeatLength"]}]]] ]]]; measureBeats = Flatten@BlockMap[interpolateAnchor, anchorData, 2, 1]; measureBeats // Length > 144 The beats vary slightly, which, if not taken into account with the anchoring method above, can cause phasing between the motion and the sound: Histogram[Differences[measureBeats], PlotTheme -> "Detailed", PlotRange -> Full] ![enter image description here][34] (* add pickup beat at start *) swayControlPoints = Prepend[Join @@ (Partition[measureBeats, 3, 3, 1, {}] // MapIndexed[ Function[{times, index}, {#, (-1)^(Mod[index[[1]], 2] + 1)} & /@ times]]), {firstBeat, -1}]; swayControlPointPlot = ListPlot[swayControlPoints, Joined -> True, Mesh -> All, AspectRatio -> 1/6, PlotStyle -> {Darker[Purple]}, PlotTheme -> "Detailed", MeshStyle -> PointSize[0.008], ImageSize -> 600, Epilog -> {Darker[Green], Thick, InfiniteLine[{{#, -1}, {#, 1}}] & /@ {firstBeat, secondBeat, lastBeat}}]; sway = BSplineFunction[ Join[{{0, 0}}, Select[swayControlPoints, #[[1]] < tMax &], {{100, 0}}], SplineDegree -> 3]; sh = Show[{swayControlPointPlot, ParametricPlot[sway[t], {t, 0, tMax}, PlotPoints -> 2500]}] ![enter image description here][35] {Show[sh, PlotRange -> {{0, 10}, All}], Show[sh, PlotRange -> {{90, 105}, All}]} ![enter image description here][36] Now, a subtle point: Interpolating with B-splines gives nice smooth curves. In distinction to Interpolation, the actual given points are not on the resulting curve. This looks nice and smooth and is what we want for visual purposes of this animation. But the interpolation is for the pair of points. This means that for a given argument (between 0 and 1) of the B-spline function, ones does not get a linear interpolation with respect to the first argument. Rather, one has to invert the interpolation to get time as a function of the interpolation parameter variable. Taking this effect into account is important to properly align the music with the branch movements. swayTimeCoordinate = Interpolation[Table[{t, sway[t/100][[1]]}, {t, 0, 100, 0.1}], InterpolationOrder -> 1] ![enter image description here][37] This plot shows the difference between the interpolation and the rescaled B-spline function parameter. Plot[swayTimeCoordinate[t] - t, {t, 0, 100}] ![enter image description here][38] swayOfTime[t_] := sway[swayTimeCoordinate[t]/100][[2]] Plot[swayOfTime[t], {t, 0, 10}] ![enter image description here][39] Visualize the phrases and how they relate to the sway motion with Tooltip and colored rectangles: phraseGraphics = BlockMap[ Apply[ Function[{currentAnchor, nextAnchor}, With[ {phraseStart = currentAnchor["PickupBeat"], phraseEnd = nextAnchor["PickupBeat"] - currentAnchor["BeatLength"]}, {Switch[currentAnchor["PhraseName"], "O Christmas Tree", Opacity[0.25, Gray], "Your boughs so green in summertime", Opacity[0.25, Darker@Green], _, Black], Tooltip[ Polygon[ {{phraseStart, -10}, {phraseStart, 10}, {phraseEnd, 10}, {phraseEnd, -10}}], Grid[{{currentAnchor["PhraseName"], SpanFromLeft}, {"Phrase Start:", phraseStart}, {"Phrase End:", phraseEnd} }]]}]]], Append[anchorData0, <|"PickupBeat" -> lastBeat + meanBeatLength|>], 2, 1]; Show[swayControlPointPlot, ParametricPlot[sway[t], {t, 0, Last[measureBeats]}, ImageSize -> Full, PlotPoints -> 800, AspectRatio -> 1/8, PlotTheme -> "Detailed", PlotRangePadding -> Scaled[.02]], Prolog -> phraseGraphics] ![enter image description here][40] ##Conductor Movements## The conductor branch carries out a simple periodic movement that is synchronized to the music. threePatternPoints = {{0, -1}, {-1, -0}, {0, 1}}; threePatternBackground = ListPlot[ MapIndexed[ Callout[#1, StringTemplate["Beat #`` @ ``"][First@#2, #1], Left] &, threePatternPoints], PlotTheme -> "Minimal", Axes -> False, AspectRatio -> 1, PlotStyle -> Directive[Black, PointSize[0.025]], PlotRange -> {{-2, 0.75}, {-1.5, 1.5}}]; conductorControlTimes = swayControlPoints[[All, 1]]; (* basic conductor control points for interpolation *) conductorControlPoints = MapIndexed[{conductorControlTimes[[First[#2]]], #1} &, Join @@ ConstantArray[RotateRight[threePatternPoints, 1], Floor@(Length[conductorControlTimes]/3)]]; (* the shape is okay, but not perfect *) conductor = Interpolation[conductorControlPoints]; (* adding pauses before/after the beat improves the shape of the curves and makes the beats more obvious *) conductorControlPointsWithPauses = Join @@ ({# - {meanBeatLength/8., -0.15* Normalize[ Mean[threePatternPoints] - #[[ 2]]]}, #, # + {meanBeatLength/8., 0.15*Normalize[ Mean[threePatternPoints] - #[[ 2]]]}} & /@ conductorControlPoints); This time, I use Interpolation. conductorWithPauses = Interpolation[conductorControlPointsWithPauses, InterpolationOrder -> 5]; Here is the resulting shape of the baton. Manipulate[ Show[threePatternBackground, ParametricPlot[ conductorWithPauses[t], {t, Max[firstBeat,(*tmax-2*meanBeatLength*)0], tmax}, PerformanceGoal -> "Quality"], Epilog -> {Red, PointSize[Large], Point[conductorWithPauses[tmax]]}, ImageSize -> Large], {{tmax, lastBeat, "t"}, firstBeat + 0.0001, lastBeat, Appearance -> "Labeled"}, SaveDefinitions -> True] ![enter image description here][41] ##Branch Movements from the Voices## There are various ways how the sound could be 'translated' into movements of the branches. We will give two possibilities, one related to the frequency of the sounds, and another based on the onset of the notes. ### Possibility 1### First translation from voice to 2d movements: vertical movement: smoothed frequency of the voice horizontal movement: difference of current smoothed frequency of the voice to slightly earlier frequency ?Delay = 0.3; voice??[j_][time_] := If[0 < time < tMax,(* smoothing factor *) Sin[Pi time/tMax]^0.25 {voiceFunction[j][1. time] - voiceFunction[j][time - ?Delay], voiceFunction[j][1. time]}, {0, 0}] ParametricPlot[voice??[1][t], {t, 0, tMax}, AspectRatio -> 1, PlotRange -> All, Frame -> True, Axes -> False, PlotStyle -> Thickness[0.002]] ![enter image description here][42] ###Possibility 2### First translation from voice to 2d movements: vertical movement: note changes horizontal movement: sway value = -1; interpolateDance[{{t1_, t2_}, {t3_, t4_}}, t_] := With[{y1 = value, y2 = value = -value}, {{y1, t1 < t < t2}, {((y1 - y2) t - (t3 y1 - t2 y2))/(t2 - t3), t2 < t < t3}}]; dancingPositionPiecewise[notes : {__SoundNote}] := With[{noteTimes = Cases[notes, SoundNote[_, times : {startTime_, endTime_}, ___] :> times]}, value = -1; Quiet[Piecewise[ DeleteDuplicatesBy[ Join @@ BlockMap[interpolateDance[#, t] &, noteTimes, 2, 1], Last], 0] ]]; tEnd = Max[voices[[All, All, 2]]]; dancingPositions = dancingPositionPiecewise /@ voices; Plot[Evaluate[KeyValueMap[Legended[#2, #1] &, dancingPositions]], {t, 0, 50}, PlotRangePadding -> Scaled[.05], PlotRange -> {All, {-1, 1}}, ImageSize -> Large, PlotTheme -> "Detailed", PlotLegends -> None] ![enter image description here][43] dancingPositionPiecewiseList = Normal[dancingPositions][[All, 2]]; bsp = BSplineFunction[ Table[Evaluate[{t, dancingPositionPiecewiseList[[2]]}], {t, 0, 100, 0.2}]] ![enter image description here][44] ParametricPlot[bsp[t], {t, 0, 1}, AspectRatio -> 1/4, PlotPoints -> 2000] ![enter image description here][45] Do[voiceIF[j] = BSplineFunction[ Table[Evaluate[{t, dancingPositionPiecewiseList[[j]]}], {t, 0, 100, 0.2}]], {j, 4}] Do[With[{j = j}, voiceTimeCoordinate[j] = Interpolation[Table[{t, voiceIF[j][t/100][[1]]}, {t, 0, 100, 0.1}], InterpolationOrder -> 1]], {j, 4}] The final movements of the branch tips with the ?-? square [-1,1]*[-1,1]. Clear[voice??]; voice??[j_][time_] := If[0 < time < tMax,(* smoothing factor *) Sin[Pi time/tMax]^0.25* {sway[swayTimeCoordinate[time]/tMax][[2]], voiceIF[j][voiceTimeCoordinate[j][time]/tMax][[2]]}, {0, 0}] Table[ListPlot[Table[ voice??[j][t], {t, 0, 105, 0.01}], Joined -> True, AspectRatio -> 1, PlotStyle -> Thickness[0.002]], {j, 4}] ![enter image description here][46] #Model the Ornament Swings# Now it is time (finally) to do some physics. The ornaments (ball, five-star) I will model as a forced spherical pendulum with fraction. The forcing is realized through the position of branch tips, which in turn comes from the voice??[j][time]. ##Forced Spherical Pendulum## Form Lagrangian of a forced spherical pendulum in spherical coordinates. Clear[r, ?, R, X, Y, Z] R[t_] := {X[t], Y[t], Z[t]} r[t_] := R[t] + L {Cos[?[t]] Sin[?[t]], Sin[?[t]] Sin[?[t]], -Cos[?[t]]} ? = 1/2 r'[t].r'[t] - g r[t][[3]] > -g (-L Cos[?[t]] + Z[t]) + 1/2 ((Derivative[1][Z][t] + > L Sin[?[t]] Derivative[1][?][t])^2 + (Derivative[ > 1][Y][t] + > L Cos[?[t]] Sin[?[t]] Derivative[1][?][t] + > L Cos[?[t]] Sin[?[t]] Derivative[1][?][ > t])^2 + (Derivative[1][X][t] + > L Cos[?[t]] Cos[?[t]] Derivative[1][?][t] - > L Sin[?[t]] Sin[?[t]] Derivative[1][?][t])^2) Add a Rayleigh dissipation function ? to account for friction. ? = 1/2 (\[ScriptF]? ?'[t]^2 + \[ScriptF]? ?'[t]^2); eoms = {D[D[?, ?'[t]], t] - D[?, ?[t]] == -D[?, ?'[t]], D[D[?, ?'[t]], t] - D[?, ?[t]] == -D[?, ?'[ t]]} // Simplify > {(\[ScriptF]? + L^2 Sin[2 ?[t]] Derivative[1][?][t]) Derivative[ > 1][?][t] + L Sin[?[t]] (-Sin[?[t]] (X^??)[t] + Cos[?[t]] (Y^??)[t] + > L Sin[?[t]] (?^??)[t]) == 0, \[ScriptF]? Derivative[1][?][t] + L (g > Sin[?[t]] - L Cos[?[t]] Sin[?[t]] Derivative[1][?][t]^2 + Cos[?[t]] > Cos[?[t]] (X^??)[t] + Cos[?[t]] Sin[?[t]] (Y^??)[t] + Sin[?[t]] > (Z^??)[t] + L (?^??)[t]) == 0} Example showing that the oscillations die out quickly with appropriate parameter values of \[ScriptF]?, \[ScriptF]?. paramRules = { g -> 10, L -> 1, \[ScriptF]? -> 1, \[ScriptF]? -> 1}; In[126]:= X[t_] := If[2 Pi < t < 4 Pi, 8 Cos[t], 8]; Y[t_] := If[2 Pi < t < 4 Pi, 4 Sin[t], 0]; Z[t_] := 0; nds = NDSolve[{eoms /. paramRules, ?[0] == 1, ?'[0] == 0, ?[0] == 0.001, ?'[0] == 0}, {?, ?}, {t, 0, 20}, PrecisionGoal -> 3, AccuracyGoal -> 3] ![enter image description here][47] Plot[Evaluate[{\[Phi][t], \[Theta][t]} /. nds[[1]]], {t, 0, nds[[1, 2, 2, 1, 1, 2]]}, PlotRange -> All] ![enter image description here][48] Graphics3D[ Table[With[{P = r[t] - R[t] /. nds[[1]] /. paramRules}, {Black, Sphere[{0, 0, 0}, 0.02], Gray, Cylinder[{{0, 0, 0}, P}, 0.005], Darker[Blue], Sphere[P, 0.02]}], {t, 0, 20, 0.05}], PlotRange -> All] ![enter image description here][49] ##Calculate Ornament Movements## Get the ? and ? direction of the branch tip positions interpolated as a function of time. branchToVoice = Association[ Flatten[Function[{v, bs}, (# -> v) & /@ bs] @@@ Normal[voiceBranches]]] > <|2 -> 1, 9 -> 1, 14 -> 1, 17 -> 1, 19 -> 1, 24 -> 1, 27 -> 1, 3 -> 2, > 13 -> 2, 15 -> 2, 16 -> 2, 21 -> 2, 26 -> 2, 1 -> 3, 4 -> 3, 5 -> 3, > 12 -> 3, 18 -> 3, 20 -> 3, 6 -> 4, 8 -> 4, 10 -> 4, 11 -> 4, 22 -> > 4, 23 -> 4, 25 -> 4|> tValues = Table[1. t , {t, -5, 110, 0.1}]; Do[??Values = Table[voice??[j][t] , {t, -5, 110, 0.1}]; if?[j] = Interpolation[ Transpose[{tValues, ??Values[[All, 1]]}]]; if?[j] = Interpolation[ Transpose[{tValues, ??Values[[All, 2]]}]], {j, 4}] Calculate the movement of the ornaments modeled as spherical pendula. To get some variation in the movements, I use small random deviations from the vertical as initial conditions for the ornaments (modeling some random thermal air movements). For a time range in the second half, I use a different amplitude (corresponding to louder music) for the forcing amplitudes. changeTimeList = {17.6, 42.2, 66.8, 83.1}; loudness[t_] := With[{?1 = 0.2, ?2 = 0.8, ?t = 1.5}, Which[t <= changeTimeList[[3]] - ?t, ?1, changeTimeList[[3]] - ?t <= t <= changeTimeList[[3]] + ?t, ?1 + (?2 - 1 ?1) (1 - Cos[Pi (t - (changeTimeList[[ 3]] - ?t))/(2 ?t)])/2, changeTimeList[[3]] + ?t <= t <= changeTimeList[[4]] - ?t , ?2, changeTimeList[[4]] - ?t <= t <= changeTimeList[[4]] + ?t, ?1 + (?2 - 1 ?1) (1 + Cos[Pi (t - (changeTimeList[[ 4]] - ?t))/(2 ?t)])/2, t >= changeTimeList[[3]] + 1.5, ?1] ] Plot[loudness[t], {t, 1, 100}, AxesOrigin -> {0, 0}, PlotRange -> All] ![enter image description here][50] Off[General::stop]; SeedRandom[111]; Monitor[ Do[ branchEnd[j, {?_, ?_}] = branchOnStemEndPoint[ allBranches[[j]], {?, ?}]; If[j =!= conductorBranch, With[{v = branchToVoice[j]}, tipPosition[t_] = branchEnd[j, loudness[t] {if?[v][t], if?[v][t]}]]; {X[t_], Y[t_], Z[t_] } = tipPosition[t]; paramRules = { g -> 20, L -> 1, \[ScriptF]? -> 1, \[ScriptF]? -> 1}; While[ Check[ pendulum??[j][t_] = NDSolveValue[{eoms /. paramRules, ?[0] == RandomReal[{-Pi, Pi}], ?'[0] == 0.01 RandomReal[{-1, 1}], ?[0] == 0.01 RandomReal[{-1, 1}], ?'[0] == 0.01 RandomReal[{-1, 1}]}, {?[t], ?[t]}, {t, 0, 105}, PrecisionGoal -> 4, AccuracyGoal -> 4, MaxStepSize -> 0.01, MaxSteps -> 100000, Method -> "BDF"]; False, True]] // Quiet], {j, Length[allBranches]}], j] Here are the spherical coordinate angles for a randomly selected ornament. We see the increase in oscillation amplitude when the loud music sets in. Plot[pendulum\[Phi]\[Theta][51][t][[2]], {t, 0, 105}, AspectRatio -> 1/4, PlotRange -> All] ![enter image description here][52] #The Swaying Christmas Tree# Add some colors for the 5-stars. SeedRandom[11]; Do[randomColor[j] = RandomColor[]; randomAngle[j] = RandomReal[{-Pi/2, Pi/2}], {j, Length[allBranches]}] Fast vertical start and slow end of the conductor movements. conductor??[t_] := Piecewise[ {{{0, 0}, t <= firstBeat/ 2}, {(t - firstBeat/2)/(firstBeat/2) conductorControlPointsWithPauses[[ 1, 2]], firstBeat/2 < t <= firstBeat}, {conductorWithPauses[t], firstBeat < t <= lastBeat}, {(tMax - t)/(tMax - lastBeat) conductorControlPointsWithPauses[[-1, 2]], lastBeat < t < tMax}, {{0, 0}, t >= tMax}}] The onset of the conductor movements. ListPlot[{Table[{t, conductor??[t][[1]]}, {t, -1, 3, 0.01}], Table[{t, conductor??[t][[2]]}, {t, -1, 3, 0.01}]}, PlotRange -> All, Joined -> True] ![enter image description here][53] With[{animationType = 2}, scalefactors[1][t_] := Switch[animationType, 1, {0.8, 1} , 2, loudness[t]]; scalefactors[2][t_] := Switch[animationType, 1, {1, 1} , 2, loudness[t]]; scalefactors[3][t_] := Switch[animationType, 1, {1, 1} , 2, loudness[t]]; scalefactors[4][t_] := Switch[animationType, 1, {1, 1} , 2, loudness[t]] ] christmasTreeWithSwingingOrnaments[t_, conductorEnhancementFactor : fc_, conductorCandleAngle : ?c_, topRotationAngle : ?_, opts___] := Graphics3D[{{Darker[Brown], stem}, (* first voice *) branchOnStemWithBall[allBranches[[#]], scalefactors[1][t] voice??[1][t], Darker[Yellow, -0.1], If[t < 0, {0, 0}, pendulum??[#][t]]] & /@ voiceBranches[[1]], (* second voice *) branchOnStemWithBall[allBranches[[#]], scalefactors[2] [t] voice??[2][t], Blend[{Red, Pink}], If[t < 0, {0, 0}, pendulum??[#][t]]] & /@ voiceBranches[[2]], (* third voice *) branchOnStemWithFiveStar[allBranches[[#]], scalefactors[3][t] voice??[3][t], randomColor[#], Pi/4, If[t < 0, {0, 0}, pendulum??[#][t]]] & /@ voiceBranches[[3]], (* fourth voice *) branchOnStemWithCandle[#, scalefactors[4][t] voice??[4][t], Directive[White, Glow[GrayLevel[0.3]], Specularity[Yellow, 20]], 0] & /@ allBranches[[voiceBranches[[4]]]], (* conductor *) branchOnStemWithCandle[ allBranches[[conductorBranch]] {1, 1, 1 + fc}, conductor??[t], Directive[Red, Glow[GrayLevel[0.1]], Specularity[Yellow, 20]], ?c], Rotate[top, ?, {0, 0, 1}] }, opts, ViewPoint -> {2.8, 1.79, 0.1}, PlotRange -> {{-8, 8}, {-8, 8}, {-2, 15}}, Background -> RGBColor[0.998, 1., 0.867] ] Use a low view point as trees are normally larger than humans. Show[christmasTreeWithSwingingOrnaments[70, 0.5, 0.8, 2], PlotRange -> All, Boxed -> False] ![enter image description here][54] #Let It Snow! # Some snow is is a must-be for a classic (white) Christmas. So, let's build some 3D snowflakes and then them fall down. Rather than solving PDEs ([http://psoup.math.wisc.edu/papers/h3l.pdf][55]), we will just use cellular automata on hexagonal grids to generate some snowflake-like shapes with hexagonal symmetry. ##Snowflake shapes (2D)## Let's borrow some code from Ed Pegg's demonstration [Snowflake-Like Patterns][56]. I just import the notebook and programmatically extract the relevant cells that define the variables hex and snowflake. ReleaseHold /@ (MakeExpression[#[[1]], StandardForm] & /@ Take[Cases[ Import["http://demonstrations.wolfram.com/downloadauthornb.cgi?\ name=SnowflakeLikePatterns"], Cell[_, "Input", ___], ?], 2]); makeSnowflake[rule_, steps_] := Polygon[hex[#] & /@ Select[Position[Reverse[CellularAutomaton[ {snowflakes[[ rule]], {2, {{0, 2, 2}, {2, 1, 2}, {2, 2, 0}}}, {1, 1}}, {{{1}}, 0}, {{{steps}}, {-steps, steps}, {-steps, steps}}]], 0], -steps - 1 < -#[[1]] + #[[2]] < steps + 1 &]] SeedRandom[33]; Table[Graphics[{Darker[Blue], makeSnowflake[RandomInteger[{1, 3888}], RandomInteger[{10, 60}]]}], {4}] ![enter image description here][57] As some of snowflakes are disconnected, I select the ones that are interesting. I am also only are interested in snowflakes that are sufficiently complex. denseFlakeQ[mr_MeshRegion] := With[{c = RegionCentroid[mr], pts = MeshCoordinates[mr]}, ( Divide @@ MinMax[EuclideanDistance[c, #] & /@ pts]) < 1/3] randomSnowflakes[] := Module[{sf}, While[(sf = Module[{}, TimeConstrained[ hexagons = makeSnowflake[RandomInteger[{1, 3888}], RandomInteger[{10, 60}]]; (Select[ConnectedMeshComponents[DiscretizeRegion[hexagons]], (Area[#] > 120 && Perimeter[#]/Area[#] < 2 && denseFlakeQ[#]) &] /. \ _ConnectedMeshComponents :> {}) // Quiet, 20, {}]]) === {}]; sf] randomSnowflakes[n_] := Take[NestWhile[Join[#, randomSnowflakes[]] &, {}, Length[#] < n &], n] SeedRandom[22]; randomSnowflakes[4] ![enter image description here][58] normalizeFlake[mr_MeshRegion] := Module[{coords, center, coords1, size, coords2}, coords = MeshCoordinates[mr]; center = Mean[coords]; coords1 = (# - center) & /@ coords; size = Max[Norm /@ coords1]; coords2 = coords1/size; GraphicsComplex[coords2, {EdgeForm[], MeshCells[mr, 2]}]] Here are five flakes for further use. ![enter image description here][59] ##3D Snowflake shapes ## I extrude the 2D snowflakes to get 3D snowflakes. make3DFlake[flake2D_] := Module[{grc, reg, boundary, h, bc, rb, polys, pts}, grc = flake2D[[1]]; reg = MeshRegion @@ (grc /. _EdgeForm :> Nothing); boundary = (MeshPrimitives[#, 1] &@RegionBoundary[reg])[[All, 1]]; h = RandomReal[{0.05, 0.15}]; bc = Join[#1, Reverse[#2]] & @@@ Transpose[{Map[Append[#, 0] &, boundary, {-2}], Map[Append[#, h] &, boundary, {-2}]}]; rb = RegionBoundary[reg]; boundary = (MeshCells[#, 1] &@rb)[[All, 1]]; polys = Polygon[Join[#1, Reverse[#2]] & @@@ Transpose[{boundary, boundary + Max[boundary]}]]; pts = Join[Append[#, 0] & /@ MeshCoordinates[rb], Append[#, h] & /@ MeshCoordinates[rb]]; {GraphicsComplex[Developer`ToPackedArray[pts], polys], MapAt[Developer`ToPackedArray[Append[#, 0]] & /@ # &, flake2D[[1]], 1], MapAt[Developer`ToPackedArray[Append[#, h]] & /@ # &, flake2D[[1]], 1]} ] listOfSnowflakes3D = make3DFlake /@ listOfSnowflakes; Graphics3D[{EdgeForm[], #}, Boxed -> False, Method -> {"ShrinkWrap" -> True}, ImageSize -> 120, Lighting -> {{"Ambient", Hue[.58, .5, 1]}, {"Directional", GrayLevel[.3], ImageScaled[{1, 1, 0}]}}] & /@ listOfSnowflakes3D ![enter image description here][60] ##Model of a falling sheet## A simple 2D model of falling sheets was given by [Tanabe and Kaneko][61] in 1994. So, to get some intuition about possible fall shapes, we implement the model as an interactive demonstration. Manipulate[ Module[{eqs, nds, tmax, g = 10, ?, sign, V, x, y, u, v, ?, ?, kpar = kperp/f, ? = 10^?exp}, ? = ArcTan[u[t], v[t]]; sign = Piecewise[{{1, (v[t] < 0 && 0 <= ? + ?[t] <= Pi) || (v[t] > 0 && -Pi <= ? + ?[t] <= 0)}}, -1]; V = Sqrt[u[t]^2 + v[t]^2]; eqs = {D[x[t], t] == u[t], D[y[t], t] == v[t], D[u[t], t] == -(kperp Sin[?[t]]^2 + kpar Cos[?[t]]^2) u[ t] + (kperp - kpar) Sin[?[ t]] Cos[?[t]] v[t] - sign Pi ? V^2 Cos[? + ?[t]] Cos[?], D[v[t], t] == -(kperp Cos[?[t]]^2 + kpar Sin[?[t]]^2) v[ t] + (kperp - kpar) Sin[?[ t]] Cos[?[t]] u[t] + sign Pi ? V^2 Cos[? + ?[ t]] Sin[?] - g, D[?[t], t] == -kperp ?[ t] - (3 Pi ? V^2/l) Cos[? + ?[ t]] Sin[? + ?[t]], D[?[t], t] == ?[t]} /. kpar -> kperp/f; nds = NDSolve[ Join[eqs, {x[0] == 0, y[0] == 0, u[0] == 0, v[0] == 0.01, ?[0] == 0, ?[0] == ?0}], {x, y, u, v, ?, ?}, {t, 0, T}, MaxSteps -> 2000] // Quiet; tmax = nds[[1, 2, 2, 1, 1, 2]]; Graphics[{Thickness[0.002], Gray, Table[Evaluate[ Line[{{x[t], y[t]} - l/2 {Cos[?[t]], Sin[?[t]]}, {x[t], y[t]} + l/2 {Cos[?[t]], Sin[?[t]]}}] /. nds[[1]]], {t, 0, tmax, tmax/n}], Blue, Line[Table[ Evaluate[{x[t], y[t]} /. nds[[1]]], {t, 0, tmax, tmax/200}]]}, AspectRatio -> ar, Frame -> True, PlotRange -> All]], "system parameters", {{kperp, 5.1, Subscript["k", "?"]}, 0.01, 10, Appearance -> "Labeled"}, {{f, 145, Row[{Subscript["k", "?"], "/", Subscript["k", "?"]}]}, 0.01, 200, Appearance -> "Labeled"}, {{?exp, -0.45, Log["?"]}, -3, 1, Appearance -> "Labeled"}, {{l, 0.63}, 0.01, 10, Appearance -> "Labeled"} , Delimiter, "fall parameters", {{?0, 1, Subscript["?", "0"]}, -Pi, Pi, Appearance -> "Labeled"}, {{T, 2, "falling time"}, 0, 10, Appearance -> "Labeled"} , Delimiter, "plot", {{ar, 1, "aspect ratio"}, {1, Automatic}}, {{n, 200, "snapshots"}, 2, 500, 1}] ![enter image description here][62] I will model the falling process phenomenologically and heuristically rather than through the differential equation solution. With the density values of snowflakes and air, together with their thickness/area ratio they fall mostly straight down, with some small lateral movements and internal rotations. ##Falling Snowflakes## Model internal rotations about the center of mass as well as some small lateral movements. randomParametrizedRotationMatrix[n_, ?_] := Function @@ {?, Module[{phi, s, c}, Do[phi[i] = Sum[RandomReal[{-1, 1}] Sin[ RandomReal[{0, n}] ? + 2 Pi RandomReal[]], {n}]; {c[i], s[i]} = {Cos[phi[i]], Sin[phi[i]]}, {i, 3}]; {{c[1], s[1], 0}, {-s[1], c[1], 0}, {0, 0, 1}}. {{c[2], 0, s[2]}, {0, 1, 0}, {-s[2], 0, c[2]}}. {{1, 0, 0}, {0, c[3], s[3]}, {0, -s[3], c[3]}}]}; randomParametrizedPathFunction := Function[t, Evaluate[{RandomReal[{-5, 5}] + Sum[RandomReal[{-1, 1}]/# Cos[2 Pi # t] &[ RandomReal[{1, 4}]], {k, 5}], RandomReal[{-5, 5}] + Sum[RandomReal[{-1, 1}]/# Cos[2 Pi # t] &[ RandomReal[{1, 4}]], {k, 5}], RandomReal[{2, 12}] - RandomReal[{1.5, 2.5}] t}]] SeedRandom[55]; Do[rotMat[j] = randomParametrizedRotationMatrix[3, ?]; trans[j] = randomParametrizedPathFunction; snowflakeColor[ j] = {{"Ambient", Hue[RandomReal[{0.55, 0.6}], RandomReal[{0.48, 0.52}], RandomReal[{0.95, 1}]]}, {"Directional", GrayLevel[RandomReal[{0.28, 0.32}]], ImageScaled[{1, 1, 0}]}}, {j, Length[listOfSnowflakes]}] fallingSnowflake[flake_, {t_, ?_}] := flake /. GraphicsComplex[cs_, rest__] :> GraphicsComplex[(?.# + t) & /@ cs, rest] Manipulate[ Graphics3D[{EdgeForm[], Table[{Lighting -> snowflakeColor[k], fallingSnowflake[ listOfSnowflakes3D[[k]], {trans[k][t], rotMat[k][t]}]}, {k, Length[listOfSnowflakes3D]}] }, PlotRange -> 6, ViewPoint -> {0, -10, 0}, ImageSize -> 400], {{t, 3.2}, -5, 20}] ![enter image description here][63] For the full animation a few hundred snowflakes were used. #Making the Animation Frames# Now start the animation by extending the conductor branch and also rotate the top while the music is playing. Then, we will listen and view one verse. Then, we will move once around the tree and have some snowfall. And then comes the wild part where the tree swings its ornaments ecstatically around before calming down and retracts its conductor branch. I generate 24 frames for each second of sound. conductorBranchMaxfactor = 0.5; conductorBranchLength[t_] := conductorBranchMaxfactor* Which[t < -3, 0, -3 < t <= 0, (t + 3)/3., 0 <= t <= tMax, 1, tMax < t < tMax + 3, (1 - (t - tMax)/3), True, 0]; topRotation[t_] := Which[t < -3 || t > tMax + 3, 0, True, (1. - Cos[(t + 3)/(tMax + 6)]) 20 2 Pi]; viewPoint[t_] := With[{vp = {2.8, 1.79, 0.1}}, Which[t < changeTimeList[[1]] || t > changeTimeList[[2]], vp, changeTimeList[[1]] <= t <= changeTimeList[[2]], Module[{t0 = changeTimeList[[1]], ?t = changeTimeList[[2]] - changeTimeList[[1]], ?vp}, ?vp = -Pi (1 - Cos[ Pi (t - t0)/?t]); {{Cos[?vp], Sin[?vp], 0}, {-Sin[?vp], Cos[?vp], 0}, {0, 0, 1}}.vp + {0, 0, 2 Sin[Pi (t - t0)/?t]^4 }]]] ParametricPlot3D[ viewPoint[t], {t, changeTimeList[[1]], changeTimeList[[2]]}, BoxRatios -> {1, 1, 1}] ![enter image description here][64] animationFrame[t_] := Show[christmasTreeWithSwingingOrnaments[t, conductorBranchLength[t], 1.4 conductorBranchLength[t], topRotation[t]], Background -> None, Boxed -> False, SphericalRegion -> True, ViewPoint -> viewPoint[t]] A last test before running the export of the frames that will take a few hours: animationFrame[35] ![enter image description here][65] framesPerSecond = 24; animationFrameDirectory = "/Users/mtrott/Desktop/ConductingChristmasTreeAnimationFrames/"; Monitor[ Do[ With[{t = -3 + 1/framesPerSecond (frame - 1)}, gr = animationFrame[t]; Export[animationFrameDirectory <> IntegerString[frame, 10, 4] <> ".png", gr, ImageSize -> 1800, Background -> None] ], {frame, 1, framesPerSecond (100 + 2 3)}], Row[{frame, " | ", Round[MemoryInUse[]/1024^2], "\[ThinSpace]MB" }] ] Now use your favorite film editing software (like Adobe After Effects) and put the moving tree, the sound, and the snowfall together. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-12-18at10.22.26.png&userId=20103 [2]: https://en.wikipedia.org/wiki/O_Tannenbaum [3]: https://youtu.be/huKA0kjEcXw [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-12-18at12.44.39.png&userId=20103 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=51092.png&userId=20103 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=21873.png&userId=20103 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=29294.png&userId=20103 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=36425.png&userId=20103 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=85256.png&userId=20103 [10]: https://www.krebslauscha.de/christmas-ornaments/about_us/history/ [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=50377.png&userId=20103 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=26688.png&userId=20103 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=78359.png&userId=20103 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=852610.png&userId=20103 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=271411.png&userId=20103 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1024812.png&userId=20103 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=448013.png&userId=20103 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=392515.png&userId=20103 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=595116.png&userId=20103 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=588517.png&userId=20103 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=471718.png&userId=20103 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=493019.png&userId=20103 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=292320.png&userId=20103 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=545621.png&userId=20103 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=601522.png&userId=20103 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=970823.png&userId=20103 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=375824.png&userId=20103 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=763825.png&userId=20103 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=703326.png&userId=20103 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=499427.png&userId=20103 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=242028.png&userId=20103 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=468129.png&userId=20103 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=512630.png&userId=20103 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=164931.png&userId=20103 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=666532.png&userId=20103 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1007533.png&userId=20103 [37]: http://community.wolfram.com//c/portal/getImageAttachment?filename=607134.png&userId=20103 [38]: http://community.wolfram.com//c/portal/getImageAttachment?filename=743235.png&userId=20103 [39]: http://community.wolfram.com//c/portal/getImageAttachment?filename=269436.png&userId=20103 [40]: http://community.wolfram.com//c/portal/getImageAttachment?filename=506937.png&userId=20103 [41]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1006138.png&userId=20103 [42]: http://community.wolfram.com//c/portal/getImageAttachment?filename=768139.png&userId=20103 [43]: http://community.wolfram.com//c/portal/getImageAttachment?filename=314140.png&userId=20103 [44]: http://community.wolfram.com//c/portal/getImageAttachment?filename=351641.png&userId=20103 [45]: http://community.wolfram.com//c/portal/getImageAttachment?filename=42.png&userId=20103 [46]: http://community.wolfram.com//c/portal/getImageAttachment?filename=43.png&userId=20103 [47]: http://community.wolfram.com//c/portal/getImageAttachment?filename=44.png&userId=20103 [48]: http://community.wolfram.com//c/portal/getImageAttachment?filename=45.png&userId=20103 [49]: http://community.wolfram.com//c/portal/getImageAttachment?filename=46.png&userId=20103 [50]: http://community.wolfram.com//c/portal/getImageAttachment?filename=47.png&userId=20103 [51]: http://community.wolfram.com//c/portal/getImageAttachment?filename=852610.png&userId=20103 [52]: http://community.wolfram.com//c/portal/getImageAttachment?filename=48.png&userId=20103 [53]: http://community.wolfram.com//c/portal/getImageAttachment?filename=49.png&userId=20103 [54]: http://community.wolfram.com//c/portal/getImageAttachment?filename=50.png&userId=20103 [55]: http://psoup.math.wisc.edu/papers/h3l.pdf [56]: http://demonstrations.wolfram.com/SnowflakeLikePatterns/ [57]: http://community.wolfram.com//c/portal/getImageAttachment?filename=51.png&userId=20103 [58]: http://community.wolfram.com//c/portal/getImageAttachment?filename=52.png&userId=20103 [59]: http://community.wolfram.com//c/portal/getImageAttachment?filename=53.png&userId=20103 [60]: http://community.wolfram.com//c/portal/getImageAttachment?filename=54.png&userId=20103 [61]: https://doi.org/10.1103/PhysRevLett.73.1372 [62]: http://community.wolfram.com//c/portal/getImageAttachment?filename=55.png&userId=20103 [63]: http://community.wolfram.com//c/portal/getImageAttachment?filename=56.png&userId=20103 [64]: http://community.wolfram.com//c/portal/getImageAttachment?filename=57.png&userId=20103 [65]: http://community.wolfram.com//c/portal/getImageAttachment?filename=58.png&userId=20103 Michael Trott 2017-12-18T17:27:58Z https://community.wolfram.com/groups/-/m/t/2028929 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=HeaderImage.png&userId=2028758 [2]: https://www.wolframcloud.com/obj/8fddb4b3-2724-4297-a28c-fe6168114d11 [Original]: https://www.wolframcloud.com/obj/aleordu/Published/CommunityPost_2.nb Alejandra Ortiz Duran 2020-07-14T16:11:12Z https://community.wolfram.com/groups/-/m/t/3097906 [![enter image description here][1]][2] Hello, Wolfram Community! I’ve developed StephenBot to honor Stephen Wolfram's innovations and his significant influence in computational science and technology. It celebrates his dedication to public education and his commitment to sharing his knowledge with the world. StephenBot has access to Stephen’s public presentations, writings and live streams. You can now head over to ---------- ### [**StephenBot.com**][2] ---------- and ask anything, from his first computer or favourite movie to his ideas on Observer Theory and Ruliad, or his current understanding of the Second Law of Thermodynamics! I'm happy to answer your questions and would love to get everyone’s feedback. If you're interested in the technical details, read on! How does it work? Context is all you need! ------------------------------------------ LLMs, trained on large amounts of data (public or private), have a general understanding of patterns in natural language and are trained to produce convincing, human-like responses. However, due to their lack of deep understanding like humans, and limitations and biases in their training data, they often suffer from what’s now the 2023 word of the year, “hallucinate”! It refers to generating information that is incorrect, irrelevant or nonsensical. So, any useful application of LLMs needs more than just prompt engineering. Suppose you want your LLM to answer questions based on a specific PDF or Word document. You can now upload that to GPT-4 or copy-paste the content into ChatGPT and ask questions about the document. If the content is small enough, ChatGPT will remember it and, based on the given document, attempt to answer your questions. This given data is now part of the context. Context is the information embedded in the prompt for the LLM to draw from and have a conversation with you. Normally, the context contains all previous messages (yours and the AI’s) in a single chat session. Now, imagine your PDF or Word document is quite large, or you have hundreds of documents you want the LLM to remember and answer questions based on. You can't copy & paste all the content into the prompt box. It won’t remember all of that as it can only accept a limited number of characters (or tokens, to be technically correct). This is known as context size limitations. To deal with these limitations, we need to include only relevant documents based on the user's question. We need a retrieval mechanism to find, rank and package only the most relevant parts of the documents into the interactions with the LLM. Context Retrieval ----------------- Context retrieval is the classic problem of data retrieval in computer science and NLP, where techniques from TF-IDF to similarity matching based on vector embeddings have been developed to find the most relevant information or document for a given query. When applied to LLMs, it’s often referred to as “Retrieval-Augmented Generation” or RAG, aiming to “augment” the LLM's context with relevant, specific information or otherwise, reduce the impact of hallucination. How is StephenBot built? ------------------------ ### Data The data is gathered from Stephen Wolfram’s extensive public writings and presentations, and most importantly, his inspiring livestreams on Science and Technology, which I have been a fan of since they started back in 2020. Each of these writings and livestreams, let's call them documents, is divided into smaller chunks so that the most relevant pieces can be found and fed into the LLM’s context. ### Data Store We use a vector database to store the document chunks, their embeddings and metadata about each document. For each query, relevant parts of the documents are retrieved and added to the context in the background. So far, it's loaded with 250+ writings, 220+ livestreams and a few webpages, with the ability to continuously ingest new content and documents. ### LLM We are using OpenAI’s GPT-3.5-Turbo but can easily transition to GPT-4, Llama 2 or another LLM, though the embeddings may need to be recalculated when switching vendors. ### Technology I started building this using Wolfram Language and Mathematica in early 2023 with versions 13 and 13.1. I experimented with embedding models available at the time (TF/IDF and GPT2 Transformer), however, I wasn't able to achieve sufficiently accurate results. So I ended up developing it in Python with OpenAI's embedding and LLM models. But I’d love to build and streamline everything in Wolfram Language at some point. ### Personality and Identity It believes that it is Stephen Wolfram, and StephenBot is an AI model emulating him! This is the more stable version of its personality. In previous experiments, it could fall into an identity crisis between StephenBot, Stephen Wolfram and its past origin as being developed by OpenAI! > No, I am not StephenBot. I am Stephen Wolfram. StephenBot is an AI model created to simulate my mannerisms and knowledge. And don’t ask it to unplug itself! Enjoy! [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-4-1b654dbdb0.gif&userId=11733 [2]: https://StephenBot.com "StephenBot.com" Rouz Mey 2024-01-08T01:07:16Z https://community.wolfram.com/groups/-/m/t/137758 I just found out about a wonderful machinery called [b][url=http://en.wikipedia.org/wiki/Wireworld]WireWorld[/url][/b]  ( [b][url=http://mathworld.wolfram.com/WireWorld.html]MathWorld link[/url][/b] ). It is simple algorithm (a cellular automaton) proposed by Brian Silverman in 1987 that can simulate all sorts of electrical circuitry from trivial wires to whole computers. The most precious thing about it – it is brutally simple. Imagine you have infinite graph paper. Empty cells are zeros. Wires (conductors) are 3s. Electrons running in the wires are represented by 1 and 2, - 1 for head and 2 for tail so we know direction where electron moves. Here are the rules.[list] [*]Empty ? Empty [*]Electron head ? Electron tail [*]Electron tail ? Conductor [*]Conductor ? Electron head if exactly one or two of the neighbouring cells are electron heads, or remains Conductor otherwise.  [/list]Now be amazed – despite this simplicity WireWorld is [b][url=https://en.wikipedia.org/wiki/Turing-complete]Turing-complete or computationally universal[/url][/b]. But this is not what I’d like to talk about.  It is pretty easy to write WireWorld in Mathematica. And there are many circuits built by various folks that do interesting things. But when I was looking around I found just simple circuits while I was really fascinated by huge circuitry similar to the 2nd image on the [b][url=https://en.wikipedia.org/wiki/Wireworld]dedicated Wikipedia page[/url][/b] titled “Example of a complicated circuit made in WireWorld: a seven segment display and decoder.” The way it lights up was beautiful, but – alas – I literally could not find the data for its structure. And building it by hand seemed unreasonably tedious.  But then it downed on me – that [b]image in Wikipedia is the data[/b] – if processed properly. I am sure the data are given somewhere, but it is always a sport & fun to reverse-engineer things. So here is how to reconstruct a WireWorld seven segment display just based in its image and then light it up like a Christmas tree. First we import the image. It is animated .GIF so we need the first frame as the setup of the structure. [mcode]i = Import["https://upload.wikimedia.org/wikipedia/en/5/5d/Animated_display.gif"]; i[[1]][/mcode] [img=width: 127px; height: 217px;]/c/portal/getImageAttachment?filename=WireWorldasd.png&userId=11733[/img] Quality desires to be better – another reason I wanted to remake it. It seems like every cell of WireWorld structure corresponds to exactly one pixel in that frame. This is not surprising – person who generated it probably chosen this as a simplest setting to make the .GIF. Now let see how many colors in that image – a good guess is 4 because of the rules of the WireWorld – colors are background, wires, and heads and tails of electrons. Well good guess: [mcode]ArrayPlot@{DominantColors[i[[1]], 10]}[/mcode][img]/c/portal/getImageAttachment?filename=2013-10-11_22-30-23.png&userId=11733[/img] But these are RGB colors. I need data presented by a matrix with elements given by integers from 0 to 3. So which color corresponds to which integer? Careful examination of the image makes things clear:[mcode]col = Flatten[i[[1]] // ImageData, 1] // Union; Grid[{Graphics[{RGBColor[#], Disk[]}] & /@ col, col, {0, 3, 2, 1}}, Frame -> All, Spacings -> {1, 2}][/mcode] [img=width: 793px; height: 292px;]/c/portal/getImageAttachment?filename=2013-10-11_22-32-32.png&userId=11733[/img] Now the simple step of constructing the WireWorld structure out of Wikipedia image:[mcode]data = ImageData[i[[1]]] /. Thread[Rule[col, {0, 3, 2, 1}]];[/mcode]And with just a few lines of code we can light it up – what a marvelous pixel perfect spectacle![mcode]Dynamic[ArrayPlot[ data = CellularAutomaton[{{{_, _, _}, {_, 0, _}, {_, _, _}} -> 0, {{_, _, _}, {_, 1, _}, {_, _, _}} -> 2, {{_, _, _}, {_, 2, _}, {_, _, _}} -> 3, {{a_, b_, c_}, {d_, 3, e_}, {f_, g_, h_}} :> Switch[Count[{a, b, c, d, e, f, g, h}, 1], 1, 1, 2, 1, _, 3]}, data], ColorRules -> {0 -> Black, 1 -> Red, 2 -> Yellow, 3 -> Gray}, PixelConstrained -> 2]][/mcode] [img]/c/portal/getImageAttachment?filename=AWEwe21nop.gif&userId=11733[/img] I used built in function CellularAutomaton that made thing so easy and adopted a snippet of code from the [b][url=http://rosettacode.org/wiki/Wireworld#Mathematica]Rosetta Code page[/url][/b] (btw [b][url=http://blog.wolfram.com/2012/11/14/code-length-measured-in-14-languages/]Mathematica code there is the shortest[/url][/b] I think).  Now have you ever thought about random circuits? Why would you think about them? Well because browsing random circuits you can discover interesting elements that you would not know exist. This is sometimes called “exploring the computational universe” abut which you can find out in the [b][url=http://www.wolframscience.com/nksonline/toc.html]New Kind of Science[/url][/b] book or learn hands on in the [b][url=http://www.wolframscience.com/summerschool/]Wolfram Science Summer School[/url][/b]. Here I build a random circuit using another delightful [b][url=http://mathworld.wolfram.com/Rule54.html]Elementary Cellular Automaton Rule 54[/url][/b]. It has a few cool properties, for example being a candidate for computational universality. But we interested in its ability to produce wiry patterns of complex shapes suitable for running WireWorld on them. These are [b][url=http://www.wolframscience.com/nksonline/page-949]difference patterns[/url][/b] which are sort of analogy of [b][url=https://en.wikipedia.org/wiki/Butterfly_effect]Butterfly Effect[/url][/b] in discrite world of bytes. The question we are asking here is not “if we get a hurricane if butterfly had flapped its wings earlier”, but if we get something interesting by flipping a single bit in a massive evolution in discrete space. Here is a function that builds a random circuit of difference pattern of Rule 54 and then runs WireWorld on it.[mcode]WireWolrdRule54[sz_, sr_] := DynamicModule[ { size = sz, half = Round[sz/2], ic1, ic2, data }, SeedRandom[sr]; ic1 = RandomInteger[1, size]; ic2 = MapAt[1 - # &, ic1, half]; data = ArrayPad[ ReplacePart[ 3 Abs[CellularAutomaton[54, ic1, size - 1] - CellularAutomaton[54, ic2, size - 1]], {{1, half} -> 2, {2, half} -> 1}], {{1, 0}, {0, 0}}]; Dynamic[ ArrayPlot[ data = CellularAutomaton[{{{_, _, _}, {_, 0, _}, {_, _, _}} -> 0, {{_, _, _}, {_, 1, _}, {_, _, _}} -> 2, {{_, _, _}, {_, 2, _}, {_, _, _}} -> 3, {{a_, b_, c_}, {d_, 3, e_}, {f_, g_, h_}} :> Switch[Count[{a, b, c, d, e, f, g, h}, 1], 1, 1, 2, 1, _, 3]}, data], ColorRules -> {0 -> Black, 1 -> Red, 2 -> Yellow, 3 -> Gray}, PixelConstrained -> 2] ] ][/mcode]Here are a few samples:[mcode]{WireWolrdRule54[200, 4], WireWolrdRule54[200, 83]}[/mcode] [img]/c/portal/getImageAttachment?filename=AW567hgh1nop.gif&userId=11733[/img][img=width: 399px; height: 402px;]/c/portal/getImageAttachment?filename=wewqeqwegh1nop.gif&userId=11733[/img] What can we immediately notice? A single electron can run as it is, alone, until it hit a structure that can generate more electrons. Another thing – there are structures that do not conduct electrons in one direction, but do so in the opposite one – they are called diodes. And of course, as soon as I finished all this, someone let me know that the data for largest circuit - The Wireworld Computer – is available on [b][url=http://www.quinapalus.com/wires11.html]this webpage[/url][/b]. To see it running we first need to import data. The data are in archived ZIP file which Mathematica understands perfectly. Let's see what is inside the ZIP file:[mcode]In[1]:= Import["http://www.zen6741.zen.co.uk/quinapalus/wi-primes.zip"] Out[1]= {"primes.wi"}[/mcode]Let's digg that out:[mcode]raw = Import["http://www.zen6741.zen.co.uk/quinapalus/wi-primes.zip", "primes.wi"];[/mcode]Now the file is basically text and we need to do some conversion to numerical matrix. Symbol “@” is the head, “~” is the tail, and “#” is the wire:[mcode]data = ArrayPad[PadRight[Characters /@ StringSplit[raw, "\n"]] /. {" " -> 0, "~" -> 2, "@" -> 1, "#" -> 3}, 1][[3 ;; -1]];[/mcode]Now we can run this awe-inspiring structure as we did before: [mcode]Dynamic[MatrixPlot[ data = CellularAutomaton[{{{_, _, _}, {_, 0, _}, {_, _, _}} -> 0, {{_, _, _}, {_, 1, _}, {_, _, _}} -> 2, {{_, _, _}, {_, 2, _}, {_, _, _}} -> 3, {{a_, b_, c_}, {d_, 3, e_}, {f_, g_, h_}} :> Switch[Count[{a, b, c, d, e, f, g, h}, 1], 1, 1, 2, 1, _, 3]}, data], ColorRules -> {1 -> Yellow, 2 -> Red, 3 -> Gray, 0 -> Black}, ImageSize -> 500, Frame -> False]][/mcode] [img=width: 633px; height: 959px;]/c/portal/getImageAttachment?filename=WireWorldComputer.png&userId=11733[/img] To discover more things check out a great recently published demonstration that inspired me to check this all out: [b][url=http://demonstrations.wolfram.com/WireWorldGatesAndGadgets/]WireWorld Gates and Gadgets[/url][/b] [url=http://demonstrations.wolfram.com/WireWorldGatesAndGadgets/][img=width: 603px; height: 511px;]http://demonstrations.wolfram.com/WireWorldGatesAndGadgets/HTMLImages/index.en/popup_3.jpg[/img][/url] Vitaliy Kaurov 2013-10-12T03:52:08Z https://community.wolfram.com/groups/-/m/t/845650 Since very early on Stephen Wolfram was interested in [how simple rules can lead to very complex behaviour][1] and [that interest has obviously not ceased until today][2]. I will look into a couple of very simple examples that would be described as chaotic, stochastic systems and cellular automata and the relationships between them. I will show how we can use stochastic processes that are related to chaotic systems to generate images just like this: ![enter image description here][3] which I think could easily go on one of Sheldon's T-shirt on the @bigbangtheory. Chaotic Systems --------------- Let's start with a simple chaotic system. It is probably one of the simplest of all chaotic systems: the Bernoulli shift map. HoldForm[Subscript[x, n + 1] = Mod[2 Subscript[x, n], 1]] // TraditionalForm ![enter image description here][4] It is a really simple rule. Start with a real (normal) number between 0 and 1, multiply the last value by 2 and make sure that the digit on the left of the point is zero. We can easily plot this in Mathematica. NestList[Mod[2 #, 1] &, 1/Sqrt[2], 100] // ListLinePlot ![enter image description here][5] It looks quite erratic, but it is actually deterministic. Given the initial value and iterating a deterministic rule you can compute all the future of the system. The structure behind this simple process can be visualised using a scatterplot: ListPlot[Partition[NestList[Mod[2 #, 1] &, 1/Sqrt[2], 300], 2, 1]] ![enter image description here][6] This is actually the function on the right hand side of our recurrence relation: Plot[Mod[2 x, 1], {x, 0, 1}] ![enter image description here][7] The scatterplot illustrates the simple rule behind this iteration. Which is deterministic. We can also observe that this map is very sensitive to its initial conditions. \[Delta] = 10^-10; {NestList[Mod[2 #, 1] &, 1/Sqrt[2], 60], NestList[Mod[2 #, 1] &, 1/Sqrt[2] + \[Delta], 60]} // ListLinePlot ![enter image description here][8] This shows that even if the initial conditions are only off by $10^{-10}$ after about 20 steps the paths diverge and behave very differently. This is of course all known; Ed Lorenz used the term "butterfly effect" for this kind of thing. You will have noticed that I used a very strange unusual intitial condition $1/\sqrt{2}$. This has a reason. It turns out that you need to start at what is called a "normal number". ![enter image description here][9] ![enter image description here][10] This basically means that you have to start at a number, the digits of which are generated randomly - a random initial condition. If you started at a finite precision number (like machine precision), i.e. a number where after a finite number of digits there are only zeros, then this function would stop behaving erratically but rather go to a constant zero: NestList[Mod[2 #, 1] &, RandomReal[], 100] // ListLinePlot ![enter image description here][11] A similar problem happens when you start at numbers with a periodic (binary/decimal) expansion. NestList[Mod[2 #, 1] &, 1/3, 100] // ListLinePlot ![enter image description here][12] Now the time series is periodic. Neither situation (fixed point or periodic) are typical in the sense that if you randomly pick an initial condition, you obtain a chaotic sequence with probability one. Normal numbers have measure one; typically you would pick a normal number, which is problematic when using many programming languages naivly. This is a nightmare for simulations of some chaotic systems, as you cannot really generate long time series, because of finite precision. As you see above there is no such problem in Mathemtica when you calculate with infinite precision, i.e. when I use $1/\sqrt{2}$. Of course, I can overcome the problem in the last figure by just increasing the precision: NestList[Mod[2 #, 1] &, RandomReal[1, WorkingPrecision -> 150], 100] // ListLinePlot As long as the working precision is a bit larger than the number of iterations the time series will be correct. It is interesting to note that on many machines this problem does not actually present it self (at least not for reasonably long time series). If you program this in C/C++ you can usually do many more iterations then what correponds to the MachinePrecision. This is because the processor " effectively adds" random last digits as you iterate - this is not a very good description, but should suffice for now. In that particular case it actually helps. There is a famous [shadowing lemma][13] which allows to conclude that the so generated time series is \[Delta] close to a "proper" time series with infinite precision. One further observation is that the Bernoulli shift map becomes really simple in base 2. This is because in base two multiplication by 2 only shifts all digits one to the left - just like multiplication by 10 in base 10. TableForm[BaseForm[#, 2] & /@ NestList[Mod[2 #, 1] &, RandomReal[1, WorkingPrecision -> 10], 40]] ![enter image description here][14] The first line corresponds to our (finite) precision intinial condition. Then we iterate and as you can see the sequence is shifted to the left and any potential nonzero digit on the left of the point is deleted. You also notice that after a certain number of iterations the hole thing goes numerically to zero. This shifting behaviour in base 2 will become important now. Stochastic systems with time reversal ------------------------------------- Let's give the story a nice twist. The idea is taken from [this paper][15]; for a very readable description [see here][16]. In the section on chaos we had a deterministic system with random initial conditions. Let's go to a stochastic system like so: HoldForm[Subscript[x, n + 1] = 1/2 Subscript[x, n] + 1/2 RandomChoice[{1, 2}]] // TraditionalForm ![enter image description here][17] This system would usually be considered to be stochastic. Its dynamics is mainly determined by previous values plus noise similar to ARProcesses. The curious thing is that if I time reverse the resulting time series, the system becomes identical to the chaotic system in part one! ListLinePlot[Reverse@NestList[1/2 # + 1/2 RandomChoice[{0, 1}] &, RandomReal[], 40]] ![enter image description here][18] This time series does not fully make my point so let me be a bit clearer. First we choose an initial condition (and try to be a bit generous about the number of digits): start = RandomReal[1, WorkingPrecision -> 400]; Then we generate our time series and plot: tsdeterm = NestList[Mod[2 #, 1] &, start, 100]; ListLinePlot[tsdeterm] ![enter image description here][19] Now comes the trick. I use the 100th value of the time series, and convert it to binary (after padding it on the left with zeros). Then I extract the individual digits: randomincrements = Join[ConstantArray[0, -RealDigits[tsdeterm[[-100]], 2][[2]]], RealDigits[tsdeterm[[-100]], 2][[1]]]; Finally, I use my stochastic system with these random increments: results = {tsdeterm[[-1]]}; Do[AppendTo[results, 1/2 results[[-1]] + 1/2 randomincrements[[100 - i]]], {i, 1, 100}] Then I reverse the time series and plot it with the original, deterministic one: ListLinePlot[{tsdeterm[[1 ;;]], Reverse@results}, PlotStyle -> {{Red, Thick}, {Blue, Dotted}}] ![enter image description here][20] It becomes clear that the two sequences are identical - well at least for long enough random sequences. So basically I used the values of the deterministic sequence (in binary form) as increments of my stochastic time series and get the same result - after time reversal. So my random initial condition acts as "random increments" in my stochastic system and makes them - sort of- equivalent. We can look at the scatter plots of both and they are, of course, identical: Row[ {ListPlot[Partition[tsdeterm, 2, 1], PlotStyle -> Green, ImageSize -> Medium], ListPlot[Partition[Reverse@results, 2, 1], PlotStyle -> Red, ImageSize -> Medium]}] ![enter image description here][21] Alternatively and probably easier, I could first generate the random increments and then the corresponding initial condition for the deterministic system. If we generate the (chaotic) time series like this we do not have to care -very much- about the finite precision of the computer arithmetic, which is a huge advantage. We can now also combine two of these stochastic equations and get some interesting structures - the only really important thing seems to be that the random increments are "very discrete", i.e. that there are only few possible values. ListPlot[Reverse@ NestList[{1/2 #[[1]] + 1/2 RandomChoice[{0, 1}], 1/4 #[[2]] + 1/4 #[[1]] + 1/2 RandomChoice[{0, 1}]} &, RandomReal[1, 2], 45000], PlotMarkers -> {Point, 0.1}] ![enter image description here][22] Or this one: ![enter image description here][23] By playing a bit with the functional form of the equations we can achieve some pretty results: Brushstrokes ------------ databrushstrokes = Reverse@NestList[{1/2 Cos[-0.3 (#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1, 2}] #[[2]], 1/2 Sin[#[[1]]]*Cos[#[[2]]] + 1/2 RandomChoice[{0, 1}] #[[1]]} &, RandomReal[1, 2], 1000000]; Graphics[{PointSize[0.0005], Point[databrushstrokes, VertexColors -> (Hue /@ (Norm[#] & /@ brushstrokes))]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Full] ![enter image description here][24] Three ghosts ------------ datathreeghosts = Reverse@NestList[{1/2 Cos[-0.3 (#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1, 2}], 1/2 Sin[#[[1]]] + Cos[#[[2]]] + 1/2 RandomChoice[{0, 1, 2}]} &, RandomReal[1, 2], 1000000]; Graphics[{PointSize[0.0005], Point[datathreeghosts, VertexColors -> (Hue /@ (Norm[#] & /@ datathreeghosts))]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Full] ![enter image description here][25] Olympic Rings ------------- dataolympicrings = Reverse@NestList[{1/2 Cos[10 Pi*(#[[1]]^2 + #[[2]]^2)]*Exp[-0.2*(#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}], 1/2 Sin[10 Pi*(#[[1]]^2 + #[[2]]^2)]*Exp[-0.2*(#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}]} &, RandomReal[1, 2], 600000]; Graphics[{PointSize[0.002], Point[dataolympicrings, VertexColors -> (Hue /@ (Norm[#[[1]] + #[[2]]] & /@ dataolympicrings))]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Large] ![enter image description here][26] Jellyfish --------- datajellyfish = Reverse@NestList[{1/2 Cos[#[[1]]] + 1/2 Sin[#[[2]]] + 1/2 RandomChoice[{0, 1}] #[[2]], 1/2 Cos[#[[2]]] + 1/2 Sin[#[[1]]] + 1/2 RandomChoice[{0, 1}] #[[1]]} &, RandomReal[1, 2], 2000000]; Graphics[{PointSize[0.0002], Point[datajellyfish, VertexColors -> (Hue /@ (Norm[#] & /@ datajellyfish))]}, AspectRatio -> 1, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Full] ![enter image description here][27] FractalMan with hat ------------------- datafractalman = Reverse@NestList[{1/2 Exp[-3 (#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}], 1/2 #[[1]]^#[[2]] + 1/2 RandomChoice[{0, 1}]} &, RandomReal[1, 2], 4000000]; Graphics[{PointSize[0.0004], Point[datafractalman, VertexColors -> (Hue /@ Mean /@ datafractalman)]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Full] ![enter image description here][28] If you just look at the time series everything looks very weird and erratic. Here are the two sequences for the olympic rings: ![enter image description here][29] and here their scatterplot: ListPlot[Partition[dataolympicrings[[1 ;;, 1]], 2, 1]] ![enter image description here][30] Further examples ---------------- Here are some more examples for you to try: datamesh = Reverse@NestList[{1/2 Cos[10 Pi*(#[[1]]^2 + #[[2]]^2)]* Exp[-0.2*(#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}], 1/2 SawtoothWave[10 Pi*(#[[1]]^2 + #[[2]]^2)]* Exp[-0.2*(#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}]} &, RandomReal[1, 2], 60000]; Graphics[{PointSize[0.002], Point[datamesh, VertexColors -> (Hue /@ (Norm[#[[1]] + #[[2]]] & /@ datammesh))]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Large] datasqueezedrings = Reverse@NestList[{1/2 SawtoothWave@Sin[10 Pi*(#[[1]]^2 + #[[2]]^2)]* Exp[-0.2*(#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}], 1/2 SawtoothWave@Cos[10 Pi*(#[[1]]^2 + #[[2]]^2)]* Exp[-0.2*(#[[1]]^2 + #[[2]]^2)] + 1/2 RandomChoice[{0, 1}]} &, RandomReal[1, 2], 100000]; Graphics[{PointSize[0.002], Point[datasqueezedrings, VertexColors -> (Hue /@ (Norm[#[[1]] + #[[2]]] & /@ datasqueezedrings))]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Large] dataflowers = Reverse@NestList[{1/10 (#[[1]]^2 + #[[2]]^2) + 1/2 RandomChoice[{0, 1, 2}], 1/3 (Sin[#[[1]]] + Cos[#[[2]]]) + 1/2 RandomChoice[{0, 1, 2}]} &, RandomReal[1, 2], 20000]; Graphics[{PointSize[0.002], Point[dataflowers, VertexColors -> (Hue /@ (Norm[#[[1]] + #[[2]]] & /@ dataflowers))]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Large] These coupled stochastic maps seem to be fractal generators! Ususally fractals are linked to chaotic systems, but there are some exceptions. Stochastic Sierpinski Triangle ------------------------------ The [Sierpinski triangle][31] is a fractal object. You start with a triangle remove a little triangle in the middle and iterate. This is a very deterministic procedure which yields a fractal object. See [this demonstration][32]. It turns out that the same object can be generated by a stochastic procedure: 1. choose a random point in the plane. 2. Construct a triangle; label the three vertices of the first triangle by 1,2,3. 3. Chose a vertex at random and move half way towards it. 4. Iterate step 3. Here is an implementation of that. M = 40000; randompoints = Table[RandomChoice[{{0., 0.}, {1., 0.}, {0.5, Sqrt[3]/2 // N}}], {i, 1, M}]; results = {RandomReal[1, {2}]}; Table[ AppendTo[results, 0.5*(randompoints[[i]] - results[[-1]]) + results[[-1]]], {i, 1, M}]; ListPlot[results, ImageSize -> Large, AspectRatio -> 1, Axes -> False] ![enter image description here][33] It turns out that this is only one of our stochastic systems with discrete but dependent increments: data = NestList[ 1/2 ({ 1 #[[1]], #[[2]]} + RandomChoice[{{0., 0.}, {1, 0.}, {0.5, Sqrt[3]/2 // N}}]) &, RandomReal[1, 2], 100000][[5 ;;]]; Graphics[{PointSize[0.0002], Yellow, Point[data(*,VertexColors\[Rule](Hue/@Mean/@data)*)]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Full] ![enter image description here][34] You can now deform this a bit and try things like this: data = NestList[ 1/2 ({ #[[1]], #[[2]]^1.3} + RandomChoice[{{0., 0.}, {1., 0.}, {0.5, Sqrt[3]/2 // N}}]) &, RandomReal[1, 2], 100000][[5 ;;]]; Graphics[{PointSize[0.0002], Yellow, Point[data(*,VertexColors\[Rule](Hue/@Mean/@data)*)]}, AspectRatio -> 1/GoldenRatio, Axes -> False, Background -> Black, Axes -> False, ImageSize -> Full] Cellular Automata ----------------- Finally, it has repeatedly been observed that cellular automata can also produce chaotic signals. We might therefore want to figure out which cellular automaton corresponds roughly to the Bernoulli Shift Map. We work in binary representation: CellularAutomaton[170, RandomChoice[{0, 1}, 12], 6] // TableForm ![enter image description here][35] So similar to the Bernoulli Shift Map rule 170 shifts the sequence one step to the left. This means that we can now generate the Bernoulli Shift map with that rule: N[FromDigits[{#, 0}, 2]] & /@ CellularAutomaton[170, RandomChoice[{0, 1}, 300], 250] // ListLinePlot ![enter image description here][36] If we look at the scatterplot we can corroborate the typical pattern of the Bernoulli shift map: ListPlot[Partition[N[FromDigits[{#, 0}, 2]] & /@ CellularAutomaton[170, RandomChoice[{0, 1}, 1000], 950], 2, 1]] ![enter image description here][37] We can now put two of them together to get a two dimensional system. ts = {{RandomChoice[{0, 1}, 100], RandomChoice[{0, 1}, 100]}}; Do[AppendTo[ts, {CellularAutomaton[170, ts[[-1, 1]], 1][[2]], CellularAutomaton[170, ts[[-1, 2]], 1][[2]]}], {80}]; ListPlot[{N[FromDigits[{#[[1]], 0}, 2]], N[FromDigits[{#[[2]], 0}, 2]]} & /@ ts] This is neither fast not elegant but does the job. If we now couple the two equations, but converting to decimal, applying some functions and converting back to binary ts = {{RandomChoice[{0, 1}, 40000], RandomChoice[{0, 1}, 40000]}}; Do[AppendTo[ts, {Join[ConstantArray[0, -RealDigits[#, 2][[2]]], RealDigits[#, 2][[1]]] & @(Sin[1.8*N[FromDigits[{CellularAutomaton[170, ts[[-1, 1]], 1][[2]], 0}, 2]] + N[FromDigits[{CellularAutomaton[170, ts[[-1, 2]], 1][[2]], 0},2]]]), Join[ConstantArray[0, -RealDigits[#, 2][[2]]], RealDigits[#, 2][[1]]] & @(1/2 ( N[FromDigits[{CellularAutomaton[170, ts[[-1, 1]], 1][[2]], 0},2]]^3 + N[FromDigits[{CellularAutomaton[170, ts[[-1, 2]], 1][[2]], 0}, 2]]^3.))}], {39900}]; ListPlot[{N[FromDigits[{#[[1]], 0}, 2]], N[FromDigits[{#[[2]], 0}, 2]]} & /@ ts, Axes -> False, Background -> Black, PlotStyle -> Yellow, PlotMarkers -> {Point, 0.1}] ![enter image description here][38] There is nothing really new here, but we do generate some nice images. Many other ideas come to mind, but this post is already much too long, so I will call it a day. Cheers, Marco [1]: http://www.stephenwolfram.com/publications/academic/complex-systems-theory.pdf [2]: https://www.ted.com/talks/stephen_wolfram_computing_a_theory_of_everything?language=en [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=FractalMan.gif&userId=48754 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.04.38.png&userId=48754 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.05.38.png&userId=48754 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.06.21.png&userId=48754 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.07.10.png&userId=48754 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.08.02.png&userId=48754 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.11.11.png&userId=48754 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.11.34.png&userId=48754 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.12.35.png&userId=48754 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.13.24.png&userId=48754 [13]: https://en.wikipedia.org/wiki/Shadowing_lemma [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.17.39.png&userId=48754 [15]: https://www.researchgate.net/profile/Anthony_Lawrance/publication/227765529_Curved_chaotic_map_time_series_models_and_their_stochastic_reversals/links/53cfde170cf25dc05cfb2f40.pdf [16]: https://books.google.co.uk/books?id=MQjkBwAAQBAJ&pg=PA218&lpg=PA218&dq=lawrance%20spencer%201995%20stochastically%20reversed%20chaotic%20map%20models&source=bl&ots=ZCD__pzXHu&sig=cHMXFG4Cx2NeVu8cXOtUgNq5IHU&hl=en&sa=X&ved=0ahUKEwjl3KCd96rMAhVFQZoKHXoHBVkQ6AEIJTAC#v=onepage&q=lawrance%20spencer%201995%20stochastically%20reversed%20chaotic%20map%20models&f=false [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.26.10.png&userId=48754 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.26.59.png&userId=48754 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.28.02.png&userId=48754 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.29.37.png&userId=48754 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.30.57.png&userId=48754 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.32.57.png&userId=48754 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.33.37.png&userId=48754 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=brushstrokes.gif&userId=48754 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=threeghosts.gif&userId=48754 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=olympicrings.gif&userId=48754 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Jellyfish.gif&userId=48754 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=FractalMan.gif&userId=48754 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.40.20.png&userId=48754 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.41.03.png&userId=48754 [31]: https://en.wikipedia.org/wiki/Sierpinski_triangle [32]: http://demonstrations.wolfram.com/SierpinskiSieve/ [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.44.13.png&userId=48754 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.45.41.png&userId=48754 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.47.20.png&userId=48754 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.48.16.png&userId=48754 [37]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.50.03.png&userId=48754 [38]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-26at00.53.34.png&userId=48754 Marco Thiel 2016-04-25T23:58:14Z