https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Wolfram Science sorted by most viewed. 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/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/995095 ![enter image description here][18] The long evolutionary history of humans has optimized the recognition of animals in the human vision system. To escape predators and to find food. Sometimes we believe to see animals and human faces, even if there aren't any, this phenomena is called [pareidolia][1], or more generally apophenia. Classic examples are Jesus on a toast ([Liu2014][2]), the image on the shroud of Turin ([Sheen2016][3]), Elvis in a potato chip ([Voss2011][4]), and the face on Mars ([Martinez-Conde2012][5]). In many cases, in about 100ms ([Naber2012][6]) humans can identify animal shapes. Some animals, e.g. snakes are potentially identified much faster ([VanLe2013][7]). So, an interesting question might be: how often do we (believe to) see animals in an genuinely random image? Here is, in the literal sense of the word, a random image of size 300*300 pixels: SeedRandom[4056380]; dim=300; randomImage = Image[Table[RandomChoice[{2,1}->{0,1}],{dim},{dim}]]; Show[randomImage,ImageSize -> 300] ![enter image description here][8] No animal shapes are directly visible. Using ImageMesh we can get the individual/connected components (some potentially animal-like shaped) as regions (this operation is not fully deterministic, so results below may vary). Show[imesh=ImageMesh[randomImage,Method->"DualMarchingSquares"],ImageSize -> 300] ![enter image description here][9] These are the individual shapes. We ignore too small and too large regions. For our image we find neatly 400 regions. (* this takes a minute *) shapes=Select[ConnectedMeshComponents@imesh,18< Area[#]<2000&]; Length[shapes] `393` These are the shapes positioned in the original image. Show[HighlightMesh[#,Style[2, RandomColor[]]]&/@ shapes] ![enter image description here][10] For later use, we define one function to make a random image and get the shapes. getShapes[{black_,white_}, dim_] :=Select[ConnectedMeshComponents@ ImageMesh[Image[Table[RandomChoice[{black,white}->{0,1}],{dim},{dim}]], Method->"DualMarchingSquares"],18< Area[#]<2000&] As we want to interpret the shapes as animals, we smooth the edges. We switch from regions to graphics. smooth[reg_] :=Graphics[{Lighter[Blue], (ToExpression[ToString[InputForm@reg],StandardForm,Hold] /. HoldPattern[BoundaryMeshRegion[v_,b__,___Rule]]:>GraphicsComplex[v,FilledCurve[{b}/. Line[l_]:> BSplineCurve[DeleteDuplicates[Flatten[l,1]], SplineClosed->True,SplineDegree->2]]])[[1]]}] We also allow changing the orientation and color. rotate[g_,?_] := With[{m={{Cos[?],Sin[?]},{-Sin[?], Cos[?]}}},g/. GraphicsComplex[v_, r__]:> GraphicsComplex[m.#&/@ v,r]] flip[g_] := g/.GraphicsComplex[v_, r__]:> GraphicsComplex[{-1,1}#&/@ v,r] recolor[g_,col_] := g/.c_RGBColor:>col animalize[g_,{f_,?_,col_}] := Graphics[ recolor[rotate[If[f, flip,Identity]@ smooth[g],?],col], PlotRange -> All]&[smooth[g]] Here are some of the shapes that were hiding in the above image.The human eye tries to see fishes, wales, birds, squirrels, frogs, ducks, sea-horses, bunnies, deers, dogs, cats and similar creatures as well as human heads. GraphicsGrid[Partition[Show[#, ImageSize -> 120,Frame->True,FrameTicks->False]&/@#,5]&@ { animalize[shapes[[18]],{False,1.8,GrayLevel[0.1]}], animalize[shapes[[99]],{False,1.1,Darker[Yellow]}], animalize[shapes[[6]],{False,0.7,Darker[Blue]}], animalize[shapes[[14]],{False,0.,Darker[Brown]}], animalize[shapes[[4]],{False,0.5,Darker[Red]}], animalize[shapes[[23]],{False,0,Darker[Orange]}], animalize[shapes[[76]],{False,0,Darker[Orange,0.6]}], animalize[shapes[[95]],{False,-1.5,Darker[Green,0.4]}], animalize[shapes[[9]],{False,0.,Brown}], animalize[shapes[[163]],{False,1.1,Darker[Purple]}]}, Spacings->{5,-20}] ![enter image description here][11] Looking at the last selection shows the importance of one or two eyes in the shapes ([Yang2015][12]). Eyes are often used by nature for deception ([Steven2014][13]). A small Manipulate will allow to optimize the animal-perception by changing color, orientation, and aspect ratio. makeManipulate[shape_]:=Manipulate[Graphics[ recolor[rotate[If[f, flip,Identity]@ #[[1]],?],col], ImageSize -> 120,AspectRatio->ar,PlotRange -> All], OpenerView[{"modify",Column[{ Control[{{?,0,"rotate"},-Pi,Pi,ImageSize->Small}], Control[{{f,False,"reflect"},{True,False},ImageSize->Small}], Control[{{col, Darker[Blue],"color"},Red,ImageSize->Tiny}], Control[{{ar, Automatic,"aspect ratio"},0.2,5,ImageSize->Small}]}]}], SaveDefinitions->True,TrackedSymbols:>True]&[smooth[#]]&@ shape Manipulate[makeManipulate[shapes[[j]]],{{j,141,""},1, Length[shapes],1,Appearance->"Labeled"}] ![enter image description here][14] Here are some more animal-shapes found in other random images. ![enter image description here][15] One could now try to automate the finding of animals using ImageIdentify. In general, the interpretation of ImageIdentify will depend on the image orientation. So, we maximize over different orientations. getOptimalAnimal[shape_] := Module[{s=smooth[shape][[1]],tab,ras,tab2}, tab=Table[{(ras=Rasterize[Graphics[rotate[s,\[Alpha]],ImageSize -> 120,PlotRange -> All]]), Normal@KeyDrop[ImageIdentify[ras,"animal",2,"Probability"],Entity["Concept",#]&/@ {"Person::93r37","Hominid::tt93h","Mammal::nt5bz", "SeaStar::46w97","Shark::632s8","CanisFamiliaris::597qc"}]}, {\[Alpha], 0, 2Pi, 2Pi/24}]; tab2=Sort[{#2[[1,2]], #2[[1,1]], #1}&@@@DeleteCases[ tab,{_,{}}]]; {tab2[[-1,3]]->tab2[[-1,2]],"Probabilty" -> tab2[[-1,1]]}] As ImageIdentify was trained on real photographs, it is not the ideal tool for this task. It is biased towards humans, mammals, and sharks. getOptimalAnimal[shapes[[10]]] ![enter image description here][16] getOptimalAnimal[shapes[[27]]] ![enter image description here][17] To answer the original question: in a random 400x400 pixel image, one easily finds a few dozen animals. Here are four dozen animal-shape like smoothed regions from random 400x400 image. Module[{gs, gs2}, SeedRandom[2222]; gs = getShapes[{2, 1}, 400]; gs2 = {animalize[gs[[3]], {False, 0, GrayLevel[0.1]}], animalize[gs[[6]], {False, 1, GrayLevel[0.1]}], animalize[gs[[9]], {False, 1.3, GrayLevel[0.1]}], animalize[gs[[15]], {False, -1, GrayLevel[0.1]}], animalize[gs[[17]], {False, 0.3, GrayLevel[0.1]}], animalize[gs[[30]], {True, 2.3, GrayLevel[0.1]}], animalize[gs[[39]], {False, 0.3, GrayLevel[0.1]}], animalize[gs[[40]], {True, -0.1, GrayLevel[0.1]}], animalize[gs[[48]], {False, -0.1, GrayLevel[0.1]}], animalize[gs[[53]], {True, -0.1, GrayLevel[0.1]}], animalize[gs[[55]], {True, -0.1, GrayLevel[0.1]}], animalize[gs[[62]], {True, 2.3, GrayLevel[0.1]}], animalize[gs[[64]], {False, 0, GrayLevel[0.1]}], animalize[gs[[65]], {False, 0, GrayLevel[0.1]}], animalize[gs[[68]], {False, -0.2, GrayLevel[0.1]}], animalize[gs[[73]], {True, -0.3, GrayLevel[0.1]}], animalize[gs[[81]], {False, 0.2, GrayLevel[0.1]}], animalize[gs[[86]], {True, 3.4, GrayLevel[0.1]}], animalize[gs[[97]], {False, 0.3, GrayLevel[0.1]}], animalize[gs[[100]], {False, 0.9, GrayLevel[0.1]}], animalize[gs[[101]], {False, 2.6, GrayLevel[0.1]}], animalize[gs[[115]], {False, 4.3, GrayLevel[0.1]}], animalize[gs[[124]], {False, 0, GrayLevel[0.1]}], animalize[gs[[125]], {False, 2.9, GrayLevel[0.1]}], animalize[gs[[139]], {False, 0, GrayLevel[0.1]}], animalize[gs[[146]], {False, -1.6, GrayLevel[0.1]}], animalize[gs[[175]], {False, -1., GrayLevel[0.1]}], animalize[gs[[201]], {True, -0.5, GrayLevel[0.1]}], animalize[gs[[209]], {True, 3.1, GrayLevel[0.1]}], animalize[gs[[210]], {False, -1.4, GrayLevel[0.1]}], animalize[gs[[218]], {True, 3.2, GrayLevel[0.1]}], animalize[gs[[227]], {True, -0.3, GrayLevel[0.1]}], animalize[gs[[229]], {True, 0.9, GrayLevel[0.1]}], animalize[gs[[253]], {True, 0., GrayLevel[0.1]}], animalize[gs[[273]], {True, -0.3, GrayLevel[0.1]}], animalize[gs[[278]], {True, 1., GrayLevel[0.1]}], animalize[gs[[282]], {True, 3, GrayLevel[0.1]}], animalize[gs[[298]], {False, 0, GrayLevel[0.1]}], animalize[gs[[299]], {False, 0.6, GrayLevel[0.1]}], animalize[gs[[318]], {False, 2., GrayLevel[0.1]}], animalize[gs[[326]], {False, 3, GrayLevel[0.1]}], animalize[gs[[340]], {False, -1.3, GrayLevel[0.1]}], animalize[gs[[352]], {True, -13, GrayLevel[0.1]}], animalize[gs[[361]], {True, -13, GrayLevel[0.1]}], animalize[gs[[365]], {False, 2.4, GrayLevel[0.1]}], animalize[gs[[377]], {True, 2.6, GrayLevel[0.1]}], animalize[gs[[395]], {False, 0.3, GrayLevel[0.1]}], animalize[gs[[405]], {True, 0.3, GrayLevel[0.1]}]}; Grid[Partition[Framed[Show[#, ImageSize -> 100]] & /@ SortBy[gs2, FullOptions[#, AspectRatio] &], 6]]] ![enter image description here][18] Using different method options for ImageMesh gives different results. Here are some animal-shaped regions from a 300*300 image and method "MarchingSquares". ![enter image description here][19] [1]: https://en.wikipedia.org/wiki/Pareidolia [2]: https://dx.doi.org/10.1016/j.cortex.2014.01.013 [3]: https://doi.org/10.1163/15736121-12341320 [4]: http://dx.doi.org/10.1093/cercor/bhr315 [5]: https://www.scientificamerican.com/article/a-faithful-resemblance/ [6]: http://dx.doi.org/10.1167/12.1.25 [7]: http://dx.doi.org/10.1073/pnas.1312648110 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4356yretet465yhdfreg5w4ytrg.png&userId=11733 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fdfgnsgt65whtr.png&userId=11733 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dfgdhcvbcbcx34tq.png&userId=11733 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dfg4dsgdfsgdqy546hfgsnbv.png&userId=11733 [12]: http://arxiv.org/pdf/1509.04954 [13]: http://dx.doi.org/10.1093/czoolo/60.1.26 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=weretregdfdgdscbx3454y6rtdfgsb.png&userId=11733 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sadfert543wyhdfgdhfd5676e565w44.png&userId=11733 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=67567etfhg54yw.png&userId=11733 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sadf345q4yrthgd.png&userId=11733 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=kfkeighsmf534yrthgfds.png&userId=11733 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fdsg65udfsdstrdgjyt7u56uw56rh.png&userId=11733 Michael Trott 2017-01-15T10:54:26Z https://community.wolfram.com/groups/-/m/t/404292 Does anyone have an idea for an efficient implementation of [Jaro–Winkler distance][1]? If there is a built in function with a different name it would be great, please let me know. If not, perhaps a modification of [Levenshtein][2] or similar would do or a compiled version (not sure which functions to use to make it compilable). I know good etiquette is to show some code, but I have to compare millions of strings pairwise and need the most efficient approach. Any advice would be appreciated - thanks in advance! BTW does anyone see any link between Shannon Entropy and Levenshtein and similar distances? Is it possible to talk about distance metric between strings in terms of information change needed to turn one string into the other? [1]: https://en.wikipedia.org/wiki/Jaro%E2%80%93Winkler_distance [2]: http://reference.wolfram.com/language/ref/EditDistance.html Sam Carrettie 2014-12-09T02:00:25Z 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/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/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/121507 [b]With 5 point-source lights in a square room, what is the optimal configuration for even lighting?[/b] To make this question concrete, say that each wall has length 1, the room has no height (i.e., two dimensional) and we have five identical lights that are pointsized and want to know the optimal placement that maximizes even lighting.  That could mean [mcode]f = 1/((x - x1)^2 + (y - y1)^2) + 1/((x - x2)^2 + (y - y2)^2) + 1/((x - x3)^2 + (y - y3)^2) + 1/((x - x4)^2 + (y - y4)^2) + 1/((x - x5)^2 + (y - y5)^2);[/mcode] a) maximizing the value of the minimal illumination [mcode]Minimize[f, {x,0,1},{y,0,1}][/mcode]or an integral measure like b) maximizing the total illumination where the brightest areas are considered as being some default value, e.g., the value of [mcode]Integrate[Min[f, f0], {x,0,1},{y,0,1}][/mcode] For an example configuration of light sources with [mcode]f = With[{n = 5}, Sum[1/((x - (.5 + .45 Cos[2 Pi i/n]))^2 + (y - (.5 + .45 Sin[2 Pi i/n]))^2), {i, 0, n - 1}]] [/mcode]and then here is the minimum illumination [mcode]NMinimize[{f, 0 <= x <= 1 && 0 <= y <= 1}, {x, y}] (*{14.349, {x -> 1., y -> 1.}}*) [/mcode]and here that point is shown on a contour plot [img=width: 360px; height: 359px;]/c/portal/getImageAttachment?filename=lights5.jpg&userId=23275[/img] For that configuration here is the integral (which I had to approximate with a Sum) [mcode]Sum[Min[1.2 (14.349), f], {x, 0.0001, 1, .01}, {y, 0.0001, 1, .01}]/10^4 (*17.2146*) [/mcode]I'd be interested in optimization approaches, but also aesthetic approaches, e.g., symmetries, angles, shadows, or patterns made by contour lines. To generalize, not only other numbers of lights, but try tacking on albedo of 50% so the wall reflect half of the light they receive. Todd Rowland 2013-09-10T16:45:23Z https://community.wolfram.com/groups/-/m/t/108323 Last week [url=http://www.youtube.com/user/Vihart/videos]Vi Hart[/url] submitted a new class titled “[url=http://youtu.be/EdyociU35u8]Doodling in Math Class: DRAGONS[/url]”. There, she introduced a family of fractals known as [url=http://en.wikipedia.org/wiki/Dragon_curve]dragon curves[/url], see here below the most famous one, the Heighway dragon:[quote]The Heighway dragon (also known as the Harter–Heighway dragon or the Jurassic Park dragon) was first investigated by NASA physicists John Heighway, Bruce Banks, and William Harter. It was described by Martin Gardner in his Scientific American column Mathematical Games in 1967. Many of its properties were first published by Chandler Davis and Donald Knuth. It appeared on the section title pages of the Michael Crichton novel Jurassic Park. ? Wikipedia[/quote][url=http://youtu.be/EdyociU35u8][img=width: 600px; height: 380px;]/c/portal/getImageAttachment?filename=vihartDragon.png&userId=56204[/img][/url] Wouldn’t it be great to doodle fractals as fast as she does? What about doodling dragons in Mathematica? [img=width: 600px; height: 502px;]/c/portal/getImageAttachment?filename=DownBinary.gif&userId=56204[/img] Two years ago, when I was playing with the mind-blowing “[url=http://demonstrations.wolfram.com/TreeBender/]Tree Bender[/url]” demonstration by [url=http://blog.wolfram.com/author/theodore-gray/]Theodore Gray[/url], I spotted a striking property. When the two branch-locators were placed in a symmetrical arrangement along the pair of horizontal line-segments {{-0.5,0.5},{0.5,0.5}} and {{-0.5,-0.5},{0.5,-0.5}}, the resulting trees were always forming dragons!  [img=width: 800px; height: 255px;]/c/portal/getImageAttachment?filename=DragonTrees.jpg&userId=56204[/img] I was so excited by this observation that I ended up carrying out a whole [url=http://pille.iwr.uni-heidelberg.de/~fractaltree01/]project[/url] about fractal trees, I published two papers presenting the n-ary symmetric trees with tip-to-tip self-contact, I 3D-printed some [url=http://shpws.me/ouuH]SuperFractals[/url] generated by these trees, and I generalized this special class of fractals to three dimensional fractal trees during my participation at the 2013 [url=http://www.wolframscience.com/summerschool/]Wolfram Science Summer School[/url]. For now let’s focus on doodling dragons, I will talk about these related projects in future discussions. There are four different ways to place symmetrically the pair of locators along the pair of horizontal lines: [list=1] [*]One with the first pair of branches constrained to move along the upper line in a mirror symmetric way: Lévy Trees. [*]One with the first pair of branches constrained to move along the lower line in a mirror symmetric way: Koch Trees. [*]One with the first pair of branches constrained to move along both horizontal lines in an opposite way to each other, 180º: Polynomial Trees. [*]And one with the first pair of branches constrained to move along both horizontal lines in a mirror symmetric way: Jurassic Park Trees. [/list][img=width: 800px; height: 500px;]/c/portal/getImageAttachment?filename=Levy_Tres.gif&userId=56204[/img] [img=width: 800px; height: 500px;]/c/portal/getImageAttachment?filename=Koch_Trees.gif&userId=56204[/img] [img=width: 800px; height: 400px;]/c/portal/getImageAttachment?filename=Polynomial_Trees.gif&userId=56204[/img] [img=width: 800px; height: 500px;]/c/portal/getImageAttachment?filename=Jurassic_Trees.gif&userId=56204[/img] Here below you have my pieces of code for doodling the four different kinds of binary dragon trees. Notice that I’ve also added the final leaves in red and some meaningful labels to explore these trees with high precision (press Alt-key while moving the branch locator to slowly change the parameters). [size=3][b]Lévy Trees Doodler [/b][/size] [img=width: 800px; height: 549px;]/c/portal/getImageAttachment?filename=levy.png&userId=56204[/img] [mcode]Manipulate[ Module[{branches=NestList[Flatten[Map[{{#[[2]],#[[2]]+{Reverse[{pt1[[1]],0.5}],{-1,1}*{pt1[[1]],0.5}}.(#[[2]]-#[[1]])},{#[[2]],#[[2]]+{Reverse[{-pt1[[1]],0.5}],{-1,1}*{-pt1[[1]],0.5}}.(#[[2]]-#[[1]])}}&,#],1]&,{{{0,-1},{0,0}}},gen]}, Graphics[{ {CapForm["Round"],Gray,Thickness[0.005],Opacity[0.3],Line[{{-0.5,-0.5},{0.5,-0.5}}]}, {CapForm["Round"],Gray,Thickness[0.005],Line[{{-0.5,0.5},{0.5,0.5}}]}, {(*Tree*)MapIndexed[{Hue[0.022*#2[[1]],0.9,1,0.6],CapForm["Round"],Thickness[th*0.77^#2[[1]]],Line[#]}&,branches]}, {(*Leaves*)MapIndexed[{Hue[0.03(*gen*),1,1,0.9],CapForm["Round"],Thickness[th*0.82^(gen+1)],Translate[Line[#],{4,0}]}&,Drop[branches,gen]]}, (*Labels*) {Inset[Style[Text@TraditionalForm@Style[Row[{"Scaling Ratio r"," "" "" Seed z = ",y+x*I}],18],Gray],{0,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"r = |z|"," = ",SetAccuracy[Norm[{{pt1[[1]],0.5},{0,0}}],4]," ",z," = ",SetAccuracy[0.5,4]+SetAccuracy[pt1[[1]],4]I}],16],Gray],{0,-1.8}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Angle \[Theta] = Arg(z)"," = ",SetAccuracy[VectorAngle[{pt1[[1]],0.5},{0,0.5}],4]," rad = ",SetAccuracy[180/Pi*VectorAngle[{pt1[[1]],0.5},{0,0.5}],2]"\[Degree] "}],16],Gray],{0,-2}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Hausdorff Dimension \!\(\*SubscriptBox[\(D\), \(H\)]\) = ",SetAccuracy[ Log[2]/Log[1/Norm[{{pt1[[1]],0.5},{0,0}}]],4]}],18],Gray],{4.,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Leaves = ",Count[Drop[branches,gen],_Real,\[Infinity]]/4" "" ""Length = ",SetAccuracy[Count[Drop[branches,gen],_Real,\[Infinity]]/4*(Norm[{{pt1[[1]],0.5},{0,0}}]^gen),3]}],18],Gray],{4.,-1.8}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Lévy Trees by Bernat Espigulé"}],18],Gray, Opacity[0.4]],{4.,-2}]}}, PlotRange->{{-2.1,6.1},{-2.1,2.1}},ImageSize->{1000,600},Background->Black]], {{th,0.02,"Thickness"},0.005,0.185}, {{gen,12,"Generations"},Range[1,16], ControlType -> SetterBar}, {{pt1,{0.5,0.5}},{-0.5,0.5},{0.5,0.5},Locator}][/mcode] [b][size=3]Koch Trees Doodler [/size][/b] [img=width: 800px; height: 552px;]/c/portal/getImageAttachment?filename=koch.png&userId=56204[/img] [mcode]Manipulate[ Module[{branches=NestList[Flatten[Map[{{#[[2]],#[[2]]+{Reverse[{pt1[[1]],-0.5}],{-1,1}*{pt1[[1]],-0.5}}.(#[[2]]-#[[1]])},{#[[2]],#[[2]]+{Reverse[{-pt1[[1]],-0.5}],{-1,1}*{-pt1[[1]],-0.5}}.(#[[2]]-#[[1]])}}&,#],1]&,{{{0,-1},{0,0}}},gen]}, Graphics[{{CapForm["Round"],Gray,Thickness[0.005],Opacity[0.7],Line[{{-0.5,-0.5},{0.5,-0.5}}]},{CapForm["Round"],Gray,Opacity[0.3],Thickness[0.005],Line[{{-0.5,0.5},{0.5,0.5}}]}, {(*FrTree*)MapIndexed[{Hue[0.022*#2[[1]],0.9,1,0.6],CapForm["Round"],Thickness[th*0.75^#2[[1]]],Line[#]}&,branches]}, {(*Red Leaves*)MapIndexed[{Hue[0.03(*gen*),1,1,0.9],CapForm["Round"],Thickness[th*0.84^(gen+1)],Translate[Line[#],{2,0}]}&,Drop[branches,gen]]}, (*Labels*) {Inset[Style[Text@TraditionalForm@Style[Row[{"Scaling Ratio r"," "" "" Seed z = ",y+x*I}],18],Gray],{0,-1.2}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"r = |z|"," = ",SetAccuracy[Norm[{{pt1[[1]],0.5},{0,0}}],4]," ",z," = ",SetAccuracy[-0.5,4]+SetAccuracy[pt1[[1]],4]I}],16],Gray],{0,-1.4}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Angle \[Theta] = Arg(z)"," = ",SetAccuracy[VectorAngle[{pt1[[1]],0.5},{0,0.5}],4]," rad = ",SetAccuracy[180/Pi*VectorAngle[{pt1[[1]],-0.5},{0,0.5}],2]"\[Degree] "}],16],Gray],{0,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Hausdorff Dimension \!\(\*SubscriptBox[\(D\), \(H\)]\) = ",SetAccuracy[ Log[2]/Log[1/Norm[{{pt1[[1]],0.5},{0,0}}]],4]}],18],Gray],{2.,-1.2}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Leaves = ",Count[Drop[branches,gen],_Real,\[Infinity]]/4" "" ""Length = ",SetAccuracy[Count[Drop[branches,gen],_Real,\[Infinity]]/4*(Norm[{{pt1[[1]],0.5},{0,0}}]^gen),3]}],18],Gray],{2.,-1.4}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Koch Trees by Bernat Espigulé"}],18],Gray, Opacity[0.4]],{2.,-1.6}]}}, PlotRange->{{-1.1,3.1},{-1.7,0.5}},ImageSize->{1000,600},Background->Black]], {{th,0.01,"Thickness"},0.005,0.185}, {{gen,12,"Generations"},Range[1,16], ControlType -> SetterBar}, {{pt1,{0.5,0.5}},{-0.5,-0.5},{0.5,-0.5},Locator}][/mcode] [b][size=3]Polynomial Trees Doodler [/size][/b] [img=width: 800px; height: 548px;]/c/portal/getImageAttachment?filename=polynomial.png&userId=56204[/img] [mcode]Manipulate[ Module[{branches=NestList[Flatten[Map[{{#[[2]],#[[2]]+{Reverse[{pt1[[1]],0.5}],{-1,1}*{pt1[[1]],0.5}}.(#[[2]]-#[[1]])},{#[[2]],#[[2]]+{Reverse[{-pt1[[1]],-0.5}],{-1,1}*{-pt1[[1]],-0.5}}.(#[[2]]-#[[1]])}}&,#],1]&,{{{0,-1},{0,0}}},gen]}, Graphics[{{CapForm["Round"],Gray,Thickness[0.005],Opacity[0.7],Line[{{-0.5,-0.5},{0.5,-0.5}}]},{CapForm["Round"],Gray,Thickness[0.005],Line[{{-0.5,0.5},{0.5,0.5}}]}, {(*FrTree*)MapIndexed[{Hue[0.022*#2[[1]],0.9,1,0.6],CapForm["Round"],Thickness[th*0.8^#2[[1]]],Line[#]}&,branches]}, {(*Red Leaves*)MapIndexed[{Hue[0.03(*gen*),1,1,0.9],CapForm["Round"],Thickness[th*0.84^(gen+1)],Translate[Line[#],{2,0}]}&,Drop[branches,gen]]}, (*Labels*) {Inset[Style[Text@TraditionalForm@Style[Row[{"Scaling Ratio r"," "" "" Seed z = ",y+x*I}],18],Gray],{0,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"r = |z|"," = ",SetAccuracy[Norm[{{pt1[[1]],0.5},{0,0}}],4]," ",z," = ",SetAccuracy[0.5,4]+SetAccuracy[pt1[[1]],4]I}],16],Gray],{0,-1.8}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Angle \[Theta] = Arg(z)"," = ",SetAccuracy[VectorAngle[{pt1[[1]],0.5},{0,0.5}],4]," rad = ",SetAccuracy[180/Pi*VectorAngle[{pt1[[1]],0.5},{0,0.5}],2]"\[Degree] "}],16],Gray],{0,-2}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Hausdorff Dimension \!\(\*SubscriptBox[\(D\), \(H\)]\) = ",SetAccuracy[ Log[2]/Log[1/Norm[{{pt1[[1]],0.5},{0,0}}]],4]}],18],Gray],{2.3,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Leaves = ",Count[Drop[branches,gen],_Real,\[Infinity]]/4" "" ""Length = ",SetAccuracy[Count[Drop[branches,gen],_Real,\[Infinity]]/4*(Norm[{{pt1[[1]],0.5},{0,0}}]^gen),3]}],18],Gray],{2.3,-1.8}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Polynomial Trees by Bernat Espigulé"}],18],Gray, Opacity[0.4]],{2.3,-2}]}}, PlotRange->{{-1.7,3.7},{-2.1,1.5}},ImageSize->{1000,600},Background->Black]], {{th,0.025,"Thickness"},0.005,0.185}, {{gen,12,"Generations"},Range[1,16], ControlType -> SetterBar}, {{pt1,{0.5,0.5}},{-0.5,0.5},{0.5,0.5},Locator}][/mcode] [size=3][b]Jurassic Trees Doodler [/b][/size] [img=width: 800px; height: 550px;]/c/portal/getImageAttachment?filename=jurassic.png&userId=56204[/img] [mcode]Manipulate[ Module[{branches=NestList[Flatten[Map[{{#[[2]],#[[2]]+{Reverse[{pt1[[1]],0.5}],{-1,1}*{pt1[[1]],0.5}}.(#[[2]]-#[[1]])},{#[[2]],#[[2]]+{Reverse[{pt1[[1]],-0.5}],{-1,1}*{pt1[[1]],-0.5}}.(#[[2]]-#[[1]])}}&,#],1]&,{{{0,-1},{0,0}}},gen]}, Graphics[{{CapForm["Round"],Gray,Thickness[0.005],Opacity[0.7],Line[{{-0.5,-0.5},{0.5,-0.5}}]},{CapForm["Round"],Gray,Thickness[0.005],Line[{{-0.5,0.5},{0.5,0.5}}]}, {(*FrTree*)MapIndexed[{Hue[0.022*#2[[1]],0.9,1,0.6],CapForm["Round"],Thickness[th*0.72^#2[[1]]],Line[#]}&,branches]}, {(*Red Leaves*)MapIndexed[{Hue[0.03(*gen*),1,1,0.9],CapForm["Round"],Thickness[th*0.8^(gen+1)],Translate[Line[#],{2,0}]}&,Drop[branches,gen]]}, (*Labels*) {Inset[Style[Text@TraditionalForm@Style[Row[{"Scaling Ratio r"," "" "" Seed z = ",y+x*I}],18],Gray],{0,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"r = |z|"," = ",SetAccuracy[Norm[{{pt1[[1]],0.5},{0,0}}],4]," ",z," = ",SetAccuracy[0.5,4]+SetAccuracy[pt1[[1]],4]I}],16],Gray],{0,-1.8}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Angle \[Theta] = Arg(z)"," = ",SetAccuracy[VectorAngle[{pt1[[1]],0.5},{0,0.5}],4]," rad = ",SetAccuracy[180/Pi*VectorAngle[{pt1[[1]],0.5},{0,0.5}],2]"\[Degree] "}],16],Gray],{0,-2}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Hausdorff Dimension \!\(\*SubscriptBox[\(D\), \(H\)]\) = ",SetAccuracy[ Log[2]/Log[1/Norm[{{pt1[[1]],0.5},{0,0}}]],4]}],18],Gray],{2.3,-1.6}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Leaves = ",Count[Drop[branches,gen],_Real,\[Infinity]]/4" "" ""Length = ",SetAccuracy[Count[Drop[branches,gen],_Real,\[Infinity]]/4*(Norm[{{pt1[[1]],0.5},{0,0}}]^gen),3]}],18],Gray],{2.3,-1.8}]}, {Inset[Style[Text@TraditionalForm@Style[Row[{"Jurassic Trees by Bernat Espigulé"}],18],Gray, Opacity[0.4]],{2.3,-2}]}}, PlotRange->{{-1.7,3.7},{-2.1,1.2}},ImageSize->{1000,600},Background->Black]], {{th,0.03,"Thickness"},0.005,0.185}, {{gen,12,"Generations"},Range[1,16], ControlType -> SetterBar}, {{pt1,{0.5,0.5}},{-0.5,0.5},{0.5,0.5},Locator}][/mcode] As far as I know these four families of fractal trees have not been presented before so I’ve just uploaded them on a single CDF to the Demonstration Project. I will share with you its url when published. If you would like to explore other demonstrations dealing with these [url=http://mathworld.wolfram.com/DragonCurve.html][i]dragons[/i][/url] here are the links to the “[url=http://demonstrations.wolfram.com/PaperfoldingDragonCurve/]Paperfolding Dragon Curve[/url]” by [url=http://blog.wolfram.com/author/todd-rowland/]Todd Rowland[/url], the [url=http://demonstrations.wolfram.com/AllPossibleSumsAndDifferencesOfPowers/]original[/url] Polynomial Trees by [url=http://blog.wolfram.com/author/michael-trott/]Michael Trott[/url] (check also his recent posts ([url=http://blog.wolfram.com/2013/05/17/making-formulas-for-everything-from-pi-to-the-pink-panther-to-sir-isaac-newton/]1[/url], [url=http://blog.wolfram.com/2013/07/19/using-formulas-for-everything-from-a-complex-analysis-class-to-political-cartoons-to-music-album-covers/]2[/url], [url=http://blog.wolfram.com/2013/08/15/even-more-formulas-for-everything-from-filled-algebraic-curves-to-the-twitter-bird-the-american-flag-chocolate-easter-bunnies-and-the-superman-solid/]3[/url]) about other creative ways of doodling in Mathematica ), and the classic “[url=http://demonstrations.wolfram.com/LimitsOfTreeBranching/]Limits of Tree Branching[/url]” by [url=http://blog.wolfram.com/author/stephen-wolfram/]Stephen Wolfram[/url]. [url=http://demonstrations.wolfram.com/PaperfoldingDragonCurve/][img=width: 749px; height: 474px;]/c/portal/getImageAttachment?filename=DragonCurveTodd.jpg&userId=56204[/img] [/url] [url=http://demonstrations.wolfram.com/AllPossibleSumsAndDifferencesOfPowers/][img=width: 754px; height: 419px;]/c/portal/getImageAttachment?filename=PolynomialTrott.jpg&userId=56204[/img] [/url] [url=http://demonstrations.wolfram.com/LimitsOfTreeBranching/][img=width: 749px; height: 625px;]/c/portal/getImageAttachment?filename=BinaryTreesWolfram.jpg&userId=56204[/img] [/url] Finally, if you liked [url=http://blog.wolfram.com/author/theodore-gray/]Theodore Gray[/url]’s “Tree Bender”, here you will find [url=http://pille.iwr.uni-heidelberg.de/~fractaltree01/cdf_binary.html]my adapted CDF[/url] for exploring binary trees with color and with meaningful parameters to describe them precisely. [url=http://pille.iwr.uni-heidelberg.de/~fractaltree01/cdf_binary.html][img=width: 800px; height: 636px;]/c/portal/getImageAttachment?filename=EspiguleCDF.png&userId=56204[/img][/url] That’s all for today! Enjoy, and let me know if you had been lucky enough to find [url=http://en.wikipedia.org/wiki/Tree_worship]a tree worthy of worship[/url] ;-).  Bernat Espigulé 2013-08-27T18:34:31Z https://community.wolfram.com/groups/-/m/t/133271 This is a sister thread of [url=http://community.wolfram.com/groups/-/m/t/127970?p_p_auth=J7J4xvRC]a discussion about Hodgkin-Huxley cable (HHC) simulation[/url]. I am writing this companion article here to show how to use [url=http://www.wolfram.com/system-modeler/]Wolfram SystemModeler [/url]to recreate this physical system and make it easier to use in the future as black box.    Lets first take a look at my result. The graph on the left is written in Mathematica from this Demonstrations web page: [b][url=http://demonstrations.wolfram.com/TheHodgkinHuxleyEquationsForTransmissionOfElectricalImpulses/]The Hodgkin-Huxley Equations for Transmission of Electrical Impulses along an Axon[/url][/b] [url=http://demonstrations.wolfram.com/TheHodgkinHuxleyEquationsForTransmissionOfElectricalImpulses/][img=width: 637px; height: 547px;]http://demonstrations.wolfram.com/TheHodgkinHuxleyEquationsForTransmissionOfElectricalImpulses/HTMLImages/index.en/popup_3.jpg[/img][/url] The result on the right hand side from [url=https://github.com/shenghuiy/SystemModelerExamples]my SystemModeler model[/url] (download and unzip everything, open mytest.mo with SystemModeler). The parameters are set with stimulus = 0.142 (mA/cm^2), start time = 1 ms and duration = 40 ms. You can find the two results are identical after you exam the characteristics of the two curves.  [center] [img=width: 800px; height: 498px; ]/c/portal/getImageAttachment?filename=systemModeler.png&userId=23928[/img][/center] Of course the Manipuate function in Mathematica is very powerful, yet SystemModeler creates a compoent-like element, which is more convenient to use and more adaptive to a larger set. Another great advantage is that System Modeler encapsulates your code to high level so products should not contain any codes other than the neat blocks or flow charts.[center][img=width: 800px; height: 361px; ]/c/portal/getImageAttachment?filename=Model.png&userId=23928[/img][/center] Though you may be told that you can draw an equivalent circuit to simulate the HHC, we here demonstrate a hardcore-yet-very-general instruction so that you can convert your other Mathematica codes nto a System modeler examples.  [url=http://demonstrations.wolfram.com/TheHodgkinHuxleyEquationsForTransmissionOfElectricalImpulses/]In Faria's notebook[/url] you may first uncollapse the Initialization Code section. There are many constants defined ahead of the following calcualation. In system modeler I do the following: use keywords "constant" to declare a symbol that is not going to changel; "Real" is simply a type of the symbol, which is like float or doulble in C/C++.[center][img=width: 541px; height: 326px; ]/c/portal/getImageAttachment?filename=constants.png&userId=23928[/img][/center] The next step is to define those intermediate functions. Because these functions are rather simple, I just sneak around and take advantage of variables in SystemModeler to handle these one-argument dependencies. I use "Real am;", for instance, to delcare such a variable that is indeed a function of V (which in turn depends on time T). In System modeler, a variable is simply a symbol whose value can be changed during computation. [center][img=width: 448px; height: 241px; ]/c/portal/getImageAttachment?filename=varaible.png&userId=23928[/img][/center] After I have declared those symbols, I put all denitions into the equation section. For example, "am[v]" can just be replaced with a algebraic expression with respect to V. This also applies to the rest variables or my original Mathematica function heads.[center][img=width: 800px; height: 669px; ]/c/portal/getImageAttachment?filename=variables2.png&userId=23928[/img][/center] I also notice that the value of V, m, h and n are determined via a system of differential equations. In System Modeler the keyword "der" indicates the first order differential wrt time. It cannot be used recursively, that is No "der(der(x))".[center][img=width: 300px; height: 195px; ]/c/portal/getImageAttachment?filename=equation.png&userId=23928[/img][/center] I think one of the most featured parts is that I can use GUI to program at same time. The "Modelica.... RealInput" symbols are such drag-drop components. These componts works as a liason so the values inside my axon cable model can talk to other models/blocks and recieve information at the same time. In this case, I just make a copy of the "RealInput" class (dark blue) and "RealOutput" class (white) into my model. If you look closely at the code, you should see a small blue icon on the right end of the framed code block. It is a collapsed symbol for annotation, which contains the coordinates and other graphical info for each compoent when printed on the workspace. [center][img=width: 800px; height: 447px; ]/c/portal/getImageAttachment?filename=interface.png&userId=23928[/img][/center] So far I have walked you through the main process of converting the demonstration project in Mathematica to Systemmodeler language. You can[url=https://github.com/shenghuiy/SystemModelerExamples] download the entire model[/url] with a compiled experimental file, *.sme file. With either option, you need to hit the play button to run the experiment and uncollapse the argument list to pick up the output you want to see in the plot, just like the attachment below. [center][img=width: 800px; height: 741px; ]/c/portal/getImageAttachment?filename=ScreenShot2013-10-02at12.49.04AM.png&userId=23928[/img][/center] Certainly I left you something to explore such as how to add a picture into the model. Since you have my model, you can spend some time to work around and explore the new things as an essential part of learning.  Ref.  The big and juicy picure of the neuron cell which I used in the model is [url=http://www.studyblue.com/notes/note/n/nervous-tissue-and-fundamentals/deck/1448672]from this web page[/url].  Shenghui Yang 2013-10-02T06:07:53Z 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/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/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/546818 [Crossposting][1] here to get a wider opinion. So, given some data, *Mathematica* 10.2 can now attempt to figure out what probability distribution might have produced it. Cool! But suppose that, instead of having data, we have something that is in some ways better -- a formula. Let's call it $f$. We suspect -- perhaps because $f$ is non-negative over some domain and because the integral of $f$ over that domain is 1 -- that $f$ is actually the PDF of some distribution (Normal, Lognormal, Gamma, Weibull, etc.) or some relatively simple transform of that distribution. Is there any way that *Mathematica* can help figure out the distribution (or simple transform) whose PDF is the same as $f$? Example: Consider the following formula: 1/(2*E^((-m + Log[5])^2/8)*Sqrt[2*Pi]) $$\frac{e^{-\frac{1}{8} (\log (5)-m)^2}}{2 \sqrt{2 \pi }}$$ As it happens -- and as I discovered with some research and guesswork -- this formula is the PDF of `NormalDistribution[Log[5], 2]` evaluated at $m$. But is there a better way than staring or guessing to discover this fact? That is, help me write `FindExactDistribution[f_, params_]`. Notes --- - The motivation for the problem comes from thinking about Conjugate Prior distributions but I suspect it might have a more general application. - One could start with mapping PDF evaluated at $m$ over a variety of continuous distributions. And if I did this I would at some point get to what I will call $g$, which is the PDF or the `NormalDistribution` with parameters $a$ and $b$ evaluated at $m$. 1/(b*E^((-a + m)^2/(2*b^2))*Sqrt[2*Pi]) $$\frac{e^{-\frac{(m-a)^2}{2 b^2}}}{\sqrt{2 \pi } b}$$ But unless I knew that if I replaced $a$ by `Log[5]` and $b$ by $2$ that I would get $f$, this fact would not mean a lot to me. I suppose I could look at the `TreeForm` of $f$ and $g$ and I would notice certain similarities, and that might be a hint, but I am not sure how to make much progress beyond that observation. Ultimately, the problem looks to be about finding substitutions in parts of a tree ($g$) which, after evaluation, yield a tree that matches a target $f$. I have the suspicion that this is a difficult problem with an NKS flavor but one for which *Mathematica* and its ability to transform expressions might be well suited. [1]: http://mathematica.stackexchange.com/q/91408/13 Seth Chandler 2015-08-12T18:27:19Z https://community.wolfram.com/groups/-/m/t/1065956 ![enter image description here][1] &[Wolfram Notebook][2] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=lichtenberg.gif&userId=32203 [2]: https://www.wolframcloud.com/obj/2775a340-5dcd-445e-8949-2d92d2fa1aed Henrik Schachner 2017-04-19T10:34:55Z https://community.wolfram.com/groups/-/m/t/392391 This week Wolfram is celebrating Benoit Mandelbrot‘s birthday and his contributions to mathematics by holding a [Tweet-a-Program challenge][1]. In honor of Mandelbrot, tweet us your favorite fractal-themed lines of Wolfram Language code. To give you some ideas, I've listed below my favorite examples of WL-generated fractals: 1. [ Fractal Self-Portrait, The Mandelbrot Set:][2] ![Fractal Self-Portrait, The Mandelbrot Set][3] 2. [A Binary Fractal Hand:][4] ![The Fractal Hand][5] 3. [A MandelTree:][6] ![MandelTree][7] 4. [Dalí's Face of War:][8] (For comparison with the next graphic.) ![The Face of War][9] 5. [The WL Face of War:][10] ![WL Face of War][11] 6. [A Cool Julia Set:][12] ![Julia Set][13] 7. [The Glynn Set Tree:][14] ![Glynn Set][15] 8. [The Jurassic Park Fractal Dragon in 3D:][16] ![Jurassic Dragon][17] 9. [A Plane-Filling H-Fractal in 3D:][18] ![HTree][19] 10. [The GoldenRatio Icosahedron Fractal:][20] ![Icosahedron Fractal][21] 11. [My Golden Fractal Tree Gasket:][22] ![enter image description here][23] Read about its discovery in [Adventures into the Mathematical Forest of Fractal Trees][24]. 12. [A Five-Armed Spiral Galaxy:][25] ![Fractal Galaxy][26] 13. [The Koch Snowflake Tree:][27] ![Koch Snowflake][28] 14. [A Binary Tree:][29] ![Binary Tree][30] 15. [A Sierpinski Triangle Tree:][31] ![Sierpinski Triangle Tree][32] 16. [A Plane-Filling Tree:][33] ![Plane-Filling Tree][34] 17. [And My Tetrahedron Sierpinski Tree:][35] ![Tetrahedron Tree][36] I hope that these examples captured your imagination. I can’t wait to see what you come up with! [Bernat Espigulé][37] [1]: http://blog.wolfram.com/2014/11/17/fractal-fun-tweet-a-program-mandelbrot-code-challenge/ [2]: https://twitter.com/wolframtap/status/535021140331474944 [3]: /c/portal/getImageAttachment?filename=B2zG5GjIIAA1Xw0.png&userId=56204 [4]: https://twitter.com/wolframtap/status/515634587045986304 [5]: /c/portal/getImageAttachment?filename=Byfm7L8IQAAO3oO.png&userId=56204 [6]: https://twitter.com/wolframtap/status/534493892423725056 [7]: /c/portal/getImageAttachment?filename=B2rnXO-IQAEr24Z.png&userId=56204 [8]: https://twitter.com/wolframtap/status/528515298534912000 [9]: /c/portal/getImageAttachment?filename=B1Wp3RjIYAAzj7y.png&userId=56204 [10]: https://twitter.com/wolframtap/status/528518367683280898 [11]: /c/portal/getImageAttachment?filename=B1Wsp7FIQAAIGRD.png&userId=56204 [12]: https://twitter.com/wolframtap/status/515650970081312768 [13]: /c/portal/getImageAttachment?filename=Byf10j4IAAA5Tc8.png&userId=56204 [14]: https://twitter.com/wolframtap/status/515522896861876224 [15]: /c/portal/getImageAttachment?filename=ByeBV8XIQAA3ZY6.png&userId=56204 [16]: https://twitter.com/wolframtap/status/522014262546685952 [17]: /c/portal/getImageAttachment?filename=Bz6RNLPIMAAtO5g.png&userId=56204 [18]: https://twitter.com/wolframtap/status/518189735454732288 [19]: /c/portal/getImageAttachment?filename=BzD60ZgIAAA5_5R.png&userId=56204 [20]: https://twitter.com/wolframtap/status/534708482541637635 [21]: /c/portal/getImageAttachment?filename=B2uqiBPIEAArX5z.png&userId=56204 [22]: https://twitter.com/wolframtap/status/530054886143307778 [23]: /c/portal/getImageAttachment?filename=B1siHEPIQAEPnyY.png&userId=56204 [24]: http://blog.wolfram.com/2014/05/22/adventures-into-the-mathematical-forest-of-fractal-trees/ [25]: https://twitter.com/wolframtap/status/531835478933520384 [26]: /c/portal/getImageAttachment?filename=B2F1jMqIMAAiPrv.png&userId=56204 [27]: https://twitter.com/wolframtap/status/530358766928416769 [28]: /c/portal/getImageAttachment?filename=B1w2fQUIcAAv4rl.png&userId=56204 [29]: https://twitter.com/wolframtap/status/534693936347234304 [30]: /c/portal/getImageAttachment?filename=B2udTVJIcAA2jfo.png&userId=56204 [31]: https://twitter.com/wolframtap/status/534694842941833216 [32]: /c/portal/getImageAttachment?filename=B2ueIGIIMAEhWvN.png&userId=56204 [33]: https://twitter.com/wolframtap/status/534699490855645184 [34]: /c/portal/getImageAttachment?filename=B2uiWoPIEAAO9dt.png&userId=56204 [35]: https://twitter.com/wolframtap/status/534686739848499200 [36]: /c/portal/getImageAttachment?filename=B2uWwb7IMAAJzOW.png&userId=56204 [37]: https://twitter.com/bernatree Bernat Espigulé 2014-11-19T12:45:24Z 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/946991 It's quite amazing that humans can abstract patterns in nature and see similarities between, for example, pigmentation of some [mollusc shells and cellular automata][1]. The amazement deepens as we discover that [mathematical relations][2] and [simple programs][3] can grasp the essence of numerous patterns. Below is an example. A "line" is one of the simplest patterns in nature and is easily caught by human eye. So it is quite miraculous to see points with coordinates `(brain mass, body mass)` for various mammals would suddenly arrange along a straight line in log-log coordinate system. Which right away implies a power or scaling mathematical law that is very universal in nature. It is known as [Snell's equation][4] in simple [allometry][5] due to Otto Snell (1891). It's not to be confused with [Snell's law][6] of optics due to Willebrord Snell (1621). Let's see how we can build this wonderful plot. ![enter image description here][7] I start from searching Wolfram Language built-in data resources for animal-related sets: ResourceSearch["animal"] ![enter image description here][8] Let's grab the first one: data = ResourceData["Animal Weights Sample Data"] ![enter image description here][9] A simple plot of brain vs body mass does not reveal anything obvious: ListPlot[Normal[data[All, {1000 #BodyWeight, #BrainWeight} &]], PlotTheme -> "Business"] ![enter image description here][10] And by browsing the data we see we got a few long-dead species: Interpreter["Dinosaur"][{"Diplodocus", "Triceratops", "Brachiosaurus"}] ![enter image description here][11] EntityValue[%, "Image"] ![enter image description here][12] Let's delete these old friends and concentrate on modern species: modern = Delete[data, {{6}, {16}, {26}}]; and find equation of line passing through the log of data points: f[x_] = Fit[Log[QuantityMagnitude[ Normal[modern[All, {1000 #BodyWeight, #BrainWeight} &]]]], {1, x},x] Out[]= -3.04602 + 0.752261 x Getting it back into Snell's equation power-from I get: eq = Rationalize[BRAIN ? First[BRAIN /. Solve[(f[x] /. x -> Log[BODY]) == Log[BRAIN], BRAIN]], .01] ![enter image description here][13] And now to make the final plot above we use `ListLogLogPlot`: Show[ ListLogLogPlot[Normal[modern[All,Callout[{1000#BodyWeight,#BrainWeight},#Species]&]], PlotTheme->"Detailed",AspectRatio->1], Plot[f[x],{x,3,16},PlotStyle->Directive[Red,Dashed,Opacity[.8]]], BaseStyle->13, PlotLabel->Style["brain vs body mass for mammals",25,Darker[Red],FontFamily->"Phosphate"], FrameLabel->{"Body Weight, g","Brain Weight, g"}, Epilog->Inset[Style[eq,18,Red],Scaled[{.2,.8}]] ] Of course, the mathematical formula is just an approximation and the constants change slightly for a different set of animals. For instance, [according to Harry J. Jerison][14] (UCLA): ![enter image description here][15] ## Further reading: - https://en.wikipedia.org/wiki/Brain%E2%80%93body_mass_ratio - https://en.wikipedia.org/wiki/Encephalization_quotient - https://doi.org/10.1093/jmammal/gyz043 [1]: https://www.wolframscience.com/nksonline/page-423 [2]: https://en.wikipedia.org/wiki/The_Unreasonable_Effectiveness_of_Mathematics_in_the_Natural_Sciences [3]: http://www.wolframscience.com/nksonline/page-363 [4]: https://en.wikipedia.org/wiki/Brain-to-body_mass_ratio [5]: https://www.britannica.com/science/allometry [6]: https://www.britannica.com/science/Snells-law [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-20at8.00.23PM.png&userId=11733 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-20at7.29.22PM.png&userId=11733 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=asdf435ytrhsgfda.png&userId=11733 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdf234q5yeuthrgsfds.png&userId=11733 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-20at7.37.48PM.png&userId=11733 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-20at7.38.57PM.png&userId=11733 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-20at7.44.26PM.png&userId=11733 [14]: http://brainmuseum.org/evolution/paleo/index.html [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=BrnBodwt6.jpg&userId=11733 Vitaliy Kaurov 2016-10-21T00:48:46Z https://community.wolfram.com/groups/-/m/t/897811 **Introduction to the Problem** While a gate-based quantum computer has yet to be implemented at the level of more than a handful of qubits, and some worry that the decoherence problem will remain an obstacle to real-world use of these machines; the field of theoretical quantum computing has its own virtue apart from these problems of construction and implementation. The theory of quantum computation and quantum algorithms have been used as powerful tools to tackle long-standing problems in classical computation such as proving the security of certain encryption schemes and refining complexity classifications for some approaches to the Traveling Salesman problem. Moreover, learning how to apply quantum effects like superposition, interference, and entanglement in a useful, computational, manner can help students gain a better understanding of how the quantum world really works. These educational and research advantages of quantum computing, along with the ever-present goal of designing new quantum algorithms that can provide us with speedups over their classical counterparts, furnish ample reason to make the field as accessible as possible. The goal of this project was to do just that by using the Wolfram language to design functionality that allows for researchers and students alike to engage with quantum computing in a meaningful way. **Getting it Done** This project involved the design and development of a suite of functions that allows for the simulation of quantum computing algorithms. The overarching goal was a framework that allows for easy implementation of quantum circuits, with minimal work done by the user. The specific design challenges were to have a tool simple enough to be used as an educational aide and powerful enough for researchers. To this end circuits can be built iteratively, allowing students, and those new to quantum computing, to build a working knowledge of the field as they increase the complexity of the algorithms. The system has a universal set of gates allowing it to carry out any operation possible for a quantum computer (up to limits on the number of qubits due to the size of the register). ---------- *Short note on this: I have not rigorously tested the system yet, but unless you want to wait several hours for your computation to complete, I suggest not attempting computations with more than ~20 qubits. To classically simulate an N-qubit register, requires a state vector of length 2<sup>N</sup>. Interestingly, it is this insight into the computational difficulty of simulating a quantum state that led Feynman to realize the power that quantum computing could have.* ---------- The project has functionality for the following gates: Hadamard, X, Y, Z, Rotation (any angle, about any axis), C-NOT, C-anything, SWAP, and QFT. It takes input in standard quantum circuit notation, and can output circuit diagrams, and the corresponding unitary transformation matrix as well as return the probabilities for results of measurements on a given qubit. Moreover, there is built in functionality for easy circuit addition, allowing one to stitch together large circuits from smaller ones, a boon for comprehension and testing. **A Simple Example** We initialize some random circuit by specifying it's corresponding circuit notation. For sake of brevity, we start with a medium-sized circuit that is already formed, and perform operations on it, but one can easily build a circuit up qubit-by-qubit and gate-by-gate with the applyQ and circuitQ functions. Below we name some variable `quantumCircuit` using the function `circuitQ` to which we pass some circuit notation. This notation is just a matrix representing the quantum logic circuit, with the gates and qubits arranged schematically. quantumCircuit= circuitQ[{{"H", "R[1,Pi/2]", "N", "SWAP1"}, {"H", 1, "C", "SWAP2"}, {"X", 1, "C", 1}}]; `circuitQ` outputs the circuit diagram corresponding to the notation given: ![enter image description here][1] But, say I wish to alter the circuit. We can add in as many layers of gates or extra qubits as we wish, without having to deal with the pesky notation matrix. Here I add a Hadamard gate to the second qubit after the SWAP using the function `applyQ`: applyQ[quantumCircuit, "H", 2] the output of which is: ![enter image description here][2] One can also use `Append`, `Join`,`Nest` and a variety of other Wolfram language functions to build up highly complex circuits. However, the `circuitQ` function is overloaded, and one can also perform computations with it. We will now build the actual unitary transformation matrix that corresponds to the circuit diagram: unitar=matrixBuild@quantumCircuit which, for our circuit, produces: ![enter image description here][3]. Now we can easily perform operations with circuit. Let's specify some random 3 qubit initial state (in the computational basis): initalState = {1, 0, 0, 1, 0, 0, 1, 0} // Normalize ![enter image description here][4] We can pass this initial state to the circuit easily with: premeasure=unitar.initialState which gives back the state of the quantum register (in this case our 3 qubits) after they have been operated on by the circuit, but pre-measurement: ![enter image description here][5] We can now sample our state using the `projection` function. Here we will calculate the probability of getting state |0> when measuring qubit #3: projection[2,0,premeasure] which, for our case, gives back a probability of 2/3. **Wrap Up** This was only a very simple example. Using `applyQ` and `circuitQ` one can build and modify highly complex quantum circuits easily. `matrixBuild` does all the math of calculating the corresponding unitary transformation matrix for you. All that is left is for the user to pass an initial state and see the output. A good learning technique is to start with a very simple circuit and initial state, and slowly build up in complexity, performing measurements at each step, to build an intuition and working knowledge of any given quantum circuit. An obvious next step for the project would be to add functionality that allows for the easy implementation of a general quantum oracle. I would also like to add more gates to the gate library, including: $\sqrt{SWAP}$, Tofolli, and QFT<sup>-1</sup> which were left out due to lack of time and are trivial to implement. These tools would make it significantly easier for researchers to model any given quantum circuit. **Where is the NKS?** Finding quantum algorithms that perform useful tasks faster than their classical counterparts is an open area of research. However, it is often quite difficult to design these algorithms to take advantage of interference, as well as the structure in a given computational problem that may be useful to exploit. As such, there are only a small number of important quantum algorithms that are currently known. Hopefully this tool will allow for NKS-style search experiments for interesting behavior in quantum circuits. Similar searches have been carried out for classical circuits, and the tools I built will make it easy to generate vast sets of random quantum circuits that follow certain rules. What remains is to build useful analytic tools for combing the space. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=circuit.jpeg&userId=896802 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=circuit2.jpeg&userId=896802 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=unitar.jpeg&userId=896802 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3114initialstate.jpeg&userId=896802 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=finalstate.jpeg&userId=896802 Aaron Tohuvavohu 2016-08-02T02:35:38Z https://community.wolfram.com/groups/-/m/t/603607 Over the past year, I've found it increasingly more difficult to find video games that can keep me entertained. This has forced me to focus more on making my own. Making games was the main reason I got into programming as a teenager (and a popular reason for many, I believe), so it's nice to return to it. For my first game last year, I wanted to make something interesting as quickly as possible. This led me to make a small puzzle game. I prototyped it in Mathematica, and now you can play the JavaScript version here ( [www.gatheredgame.com][1] ). That was a fun exercise, but moving forward, I wanted to create less abstract systems. I'm interested in small fictional worlds, emphasizing intricacy and responsiveness. This would enable player-driven stories, without having to hand-code every possible outcome and without limiting myself to the building and strategy genres. Perhaps things like Dwarf Fortress, but more accessible and varied. I decided a key to accomplishing this was to more closely tie together the creative writing and programming parts of my design process. I knew that the final result wouldn't hold my attention long enough to be worth the effort if I took the industry approach to game design by starting from an existing genre or game and changing the setting or adding a new feature. Some independent games have been successful by starting from a novel interaction mechanic, and then exploring the language of puzzles that can be generated from that grammar. A prominent example is Portal. I think starting from random creative writing exercises is more fun, but in my initial attempts I had to throw away many details to reduce the results down to something I could start coding. That made the design process feel very inefficient. I want coding a game to feel like creative writing, and I want the output to be interesting from the first few lines until the final result. Ever since reading NKS, I've been struck by how interesting a random cellular automata browser can be given how little code is required to make one. For example, try enabling rules below until interesting behavior is produced (click the squares to the right of the arrows). SeedRandom[1]; init = RandomInteger[1, 100]; rule = Table[False, {2^5}]; Row@{Column@ Table[Row@{Row[ IntegerDigits[a - 1, 2, 5] /. {0 -> Graphics[{White, EdgeForm[{Thin, Black}], Rectangle[]}, ImageSize -> 10], 1 -> Graphics[{Black, EdgeForm[{Thin, Black}], Rectangle[]}, ImageSize -> 10]}], "\[Rule]", With[{a = a}, Dynamic@Graphics[ Button[If[ rule[[a]], {{Black, EdgeForm[{Thin, Black}], Rectangle[]}}, {{White, EdgeForm[{Thin, Black}], Rectangle[]}}], rule[[a]] = ! rule[[a]]], ImageSize -> 10]]}, {a, 2^5}], Spacer@10, Dynamic@ArrayPlot[ CellularAutomaton[{FromDigits[Reverse@Boole@rule, 2], 2, 2}, init, 150], ImageSize -> 350]} ![enter image description here][2] So I decided the easiest way to try and take advantage of the fundamental phenomenon that complex behavior isn't difficult to produce, while simultaneously focusing on concrete objects, was to experiment with association automata. With "association" referring to Wolfram's key/value dictionaries. I like starting from random story ideas. I currently pull random story tropes from the TV Tropes idea generator to get started. Sometimes I mix in a few random Wikipedia articles. randomStoryIdea[] := DynamicModule[{elements = Import["http://tvtropes.org/pmwiki/storygen.php", "Data"][[2, 2, 2]]}, Dynamic@ Grid[MapIndexed[{#[[1]], Hyperlink[#[[2]], "http://tvtropes.org/pmwiki/pmwiki.php/Main/" <> StringReplace[#[[2]], Except@LetterCharacter -> ""]], Button["New", elements[[#2[[1]]]] = Import["http://tvtropes.org/pmwiki/storygen.php", "Data"][[2, 2, 2, #2[[1]]]]]} &, elements], Alignment -> Left]] Here is a random seed I'm working with now: ![enter image description here][3] Then I start to stitch some of the elements together in my head. An evil poacher at a lighthouse made me think of a fisherman, perhaps a criminal hiding in a lighthouse who is fishing to survive. Chain of harm and monster adventurers made me think that perhaps his fishing activities are damaging a community of marine life under the dock, and some crabs attempt to stop him. Now I'll start defining some entities and properties. I start with the properties that I think someone would consider most interesting at the end of a game. Health and location of main characters, how many catches did the fisherman complete, what is the state of the crab town? entities = <| "fisherman" -> <|"health" -> "healthy", "location" -> "dock", "catches" -> 0|>, "hero crab" -> <|"health" -> "healthy"|>, "assistant crab" -> <|"health" -> "healthy"|>, "crab town" -> <|"population" -> 50, "crime rate" -> .05|> |> Then I define some rules to update those properties, referring to new properties that will influence them. In this way I essentially define the game world by starting from final effects and working backward by defining causes. The entities and properties are defined as an association of associations. The rules are defined as a list of lists that is then converted to associations with some code. Each sublist represents one rule that updates one property of one entity. The first two items of the sublist are the entity and property being updated, and the last item is a pure function that defines the behavior of the rule. Three values are passed to the rule when it is used. Slot[1] is the current value of the property being updated. Slot[2] is the current entity being updated, so I can refer to other properties of that entity easily with #2["property"]. Slot[3] is the association containing the current state of all entities, so I can refer to properties of the fishing rod within a rule that updates the fisherman's catch count with #3["fishing rod","fish on line"]. rules = { {"fisherman", "health", Which[ #2@"pacemaker" === "off", "dead", #2@"fear level" >= 30, "dead", #2@"location" === "ocean", "dead", #2@"blood level" < 30 && # === "healthy", "injured", #2@"blood level" <= 0, "dead", #2@"hunger level" >= 50, "dead", # === "injured" && #2@"time without bleeding" >= 20, "healthy", True, #] &}, {"crab town", "population", # + If[RandomReal[] < #2@"crime rate", -1, 0] + If[RandomReal[] < #/4*.005, 1, 0] &} } Before we look at the behavior of the system, we need to define initial values for any new properties we reference in the rules. Here is some code to find those. extractVars[fun_, scopedEntity_] := Join[Cases[fun, #2[prop_] :> {scopedEntity, prop}, \[Infinity]], Cases[fun, #3[globalEntity_, prop_] :> {globalEntity, prop}, \[Infinity]], Cases[fun, prop[globalEntity_String, prop_String] :> {globalEntity, prop}, \[Infinity]]] Complement[ Union[Join @@ (Prepend[extractVars[#3, #], {#, #2}] & @@@ rules)], Join @@ KeyValueMap[Thread[{#, Keys@#2}] &, entities]] The following code expands the rules into associations and allows for simple one-level, OO-style inheritance of properties and rules by using an "is a" property on an entity. This example doesn't utilize that, but the code to apply rules assumes they have been transformed into associations. (*currently only supports one level of inheritance. inherited rules \ lose ordering*) fullEntities = entities; Select[fullEntities, KeyExistsQ@"is a"] // KeyValueMap[{#, #2@"is a"} &] // Apply[{entity, parent} \[Function] AssociateTo[fullEntities, entity -> Join[fullEntities@parent, fullEntities@entity]], #, {1}] &; fullRules = Select[entities, KeyExistsQ@"is a"] // KeyValueMap[Cases[rules, {#2@"is a", a__} :> {#, a}] &] // Select[<|"entity" -> #, "property" -> #2, "rule" -> #3, If[Length@{##} > 3, "probabilities" -> {##}[[4]], "probabilities" -> Null]|>, # =!= Null &] & @@@ Join[Catenate@#, rules] &; Then to step through the evolution of the system, we can use code like the following. In my example the only changes come from a gradually changing population due to birth and crime, so you can use the input field above the step button to take more than one step at a time: applyRules[entities_, rules_] := Fold[ReplacePart[#, {#2@"entity", #2@"property"} -> #2[ "rule"][#[#2@"entity", #2@"property"], #[#2@"entity"], #]] &, entities, rules] play[] := (state = fullEntities; steps = 0; stepSize = 1; Grid[{{Column@{InputField[Dynamic@stepSize, Number, FieldSize -> 4], Button["Step", state = Nest[applyRules[#, fullRules] &, state, stepSize]; steps += stepSize], Dynamic@steps}, Dynamic@Column@Normal[state]}}, Frame -> All, Alignment -> {Center, Center}]) play[] To help decide what rules to add next, I have some code that visualizes which properties influence other properties as a graph, and some code that sorts properties by how many other properties they influence. This makes it easy to add rules that have the greatest downstream effects on the system. Graph[Flatten[ Thread[Union@extractVars[#[[3]], #[[1]]] \[DirectedEdge] #[[;; 2]], List, 1] & /@ rules, 1], VertexLabels -> "Name", PlotRangePadding -> 1] Module[{counts = Counts[Join @@ (Union@extractVars[#3, #] & @@@ fullRules)], counts2 = Counts[Join @@ (extractVars[#3, #] & @@@ fullRules)]}, Complement[ Join[Join @@ KeyValueMap[Thread[{#, Keys@#2}] &, fullEntities], Keys@counts], Values@fullRules[[All, {"entity", "property"}]]] // Map[{#, Lookup[counts, Key@#, 0], Lookup[counts2, Key@#, 0]} &] // SortBy[-Last@# &]] ![enter image description here][4] As you start expanding your system, you'll very quickly realize that defining rules for the behavior of "intelligent" entities in your system is very tedious. I've started investigating some ways to simplify this. We'll use the fisherman as an example, but I plan to use the same techniques for the crabs and others. We can just treat his choice of what action to perform as a search and optimization problem. By giving him a utility or objective property to maximize like "happiness", we can just have him search through a few steps of simulating the system for various possible actions and choose the one that leads to the most happiness. optimize[property_, choices_, objective_, entities_, rules_, searchDepth_] := Module[{rulesSafe = Select[rules, property =!= prop[#entity, #property] &]}, First@MaximalBy[ Table[{c, Module[{newState = applyRules[ReplacePart[entities, List @@ property -> c], rulesSafe]}, If[searchDepth > 1, Last@optimize[property, choices, objective, newState, rulesSafe, searchDepth - 1], newState @@ objective]]}, {c, entities @@ choices}], Last]] You would use that function similar to the following: {"fisherman", "action", First@optimize[prop["fisherman", "action"], prop["fisherman", "possible actions"], prop["fisherman", "happiness"], #3, fullRules, 5] &} I gave the fisherman a few possible actions (sitting, standing, casting, fishing, reeling, unhooking) and defined which ones are accessible under which conditions with nested Which expressions. Then I defined his happiness to increase by one whenever he unhooks a fish. Now we immediately run into a problem where he has no way to prioritize unhooking a fish now when he could just wait a turn and unhook it then. If he is recursively searching two moves ahead, then both unhooking now then waiting or waiting now then unhooking both return the same happiness. So depending on search order, he might just choose to wait every single step. One simple fix for this example is to just multiply his happiness by something like 1.01 at each step. Then he will prioritize unhooking the fish as soon as possible, because ((x+1)*1.01)*1.01 is greater than ((1.01*x)+1)*1.01. The sooner he gets happiness increases, the greater the effect of the ongoing multiplier. You could also have his happiness be diminished based on search depth in the optimization recursion, have the formula directly incorporate the amount of time that has passed in the game, etc. entities = <| "fisherman" -> <|"health" -> "healthy", "location" -> "dock", "catches" -> 0, "action" -> "sitting", "happiness" -> 50, "possible actions" -> {"sitting", "casting", "standing"}, "blood level" -> 100, "fear level" -> 0, "hunger level" -> 0, "pacemaker" -> "on", "time without bleeding" -> 0, "catching fish" -> False|>, "hero crab" -> <|"health" -> "healthy"|>, "assistant crab" -> <|"health" -> "healthy"|>, "crab town" -> <|"population" -> 50, "crime rate" -> .05|>, "fishing rod" -> <|"crab on line" -> False|>, "dock" -> <|"trip wire" -> "not set"|> |>; rules = { {"fisherman", "action", First@optimize[prop["fisherman", "action"], prop["fisherman", "possible actions"], prop["fisherman", "happiness"], #3, fullRules, 5] &}, {"fisherman", "catching fish", #2@"action" === "unhooking" && #3["fishing rod", "crab on line"] &}, {"crab town", "crime rate", .05 + .05*#3["fisherman", "catches"] &}, {"fisherman", "location", Which[ #2@"fear level" >= 20 && # === "dock" && #3["dock", "trip wire"] === "set", "ocean", #2@"action" === "going to lighthouse", "lighthouse", #2@"action" === "going to dock", "dock", True, #] &}, {"fisherman", "possible actions", Which[ #2@"location" === "dock", Which[ #2@"action" === "sitting", {"sitting", "casting", "standing"}, #2@"action" === "casting", {"fishing"}, #2@"action" === "fishing", {"fishing", "reeling"}, #2@"action" === "reeling", {"sitting", "unhooking"}, #2@"action" === "unhooking", {"sitting"}, #2@"action" === "standing", {"sitting", "going to lighthouse"}, True, #], True, #] &}, {"fisherman", "health", Which[ #2@"pacemaker" === "off", "dead", #2@"fear level" >= 30, "dead", #2@"location" === "ocean", "dead", #2@"blood level" < 30 && # === "healthy", "injured", #2@"blood level" <= 0, "dead", #2@"hunger level" >= 50, "dead", # === "injured" && #2@"time without bleeding" >= 20, "healthy", True, #] &}, {"fisherman", "happiness", 1.01 (# + If[#2@"catching fish", 1, 0] - If[#2@"health" === "injured", 20, 0]) &}, {"fisherman", "catches", If[#2@"catching fish", # + 1, #] &}, {"fishing rod", "crab on line", Which[ #3["fisherman", "action"] === "fishing" && RandomReal[] < .1, True, #3["fisherman", "action"] === "unhooking", False, True, #] &}, {"crab town", "population", # + If[RandomReal[] < #2@"crime rate", -1, 0] + If[RandomReal[] < #/4*.005, 1, 0] &} }; ![enter image description here][5] So now if he was guaranteed to catch a fish within the search depth of his optimization (I'm using 5 for now), he would behave as desired. The problem is that for each step that he is fishing, he only has a 10% chance of a fish biting. This means that almost 9 of 10 times, his optimization search will return no better options than doing nothing. He needs to understand that the chance of catching a fish is always better than doing nothing. I'm experimenting with just manually annotating any rules that depend on randomness. Then I define a new optimization search function that can read these annotations, split the search into multiple branches when necessary, and return the expected happiness from the split. In our example, when he is fishing and no fish has bitten yet, it will return a happiness of .1*(the happiness from continuing the search assuming a fish bites)+.9*(the happiness from continuing the search assuming a fish doesn't bite). {"fishing rod", "crab on line", Which[#3["fisherman", "action"] === "fishing" && RandomReal[] < .1, True, #3["fisherman", "action"] === "unhooking", False, True, #] &, {{#3["fisherman", "action"] === "fishing" && ! # &, {{.1, True}, {.9, False}}}}} relevantProbs[rule_, state_] := If[KeyExistsQ[rule, "probabilities"], Select[rule[ "probabilities"], #[[1]][state[rule@"entity", rule@"property"], state[rule@"entity"], state] &], {}] applyRulesProb[entities_, rules_] := Fold[Function[{states, rule}, Function[state, If[Length@relevantProbs[rule, state[[2]]] > 0, relevantProbs[rule, state[[2]]][[1, 2]] // Map[Function[ branch, {branch[[1]]*state[[1]], ReplacePart[ state[[2]], {rule@"entity", rule@"property"} -> branch[[2]]]}]] // Sequence @@ # &, {state[[1]], ReplacePart[ state[[2]], {rule@"entity", rule@"property"} -> rule["rule"][state[[2]][rule@"entity", rule@"property"], state[[2]][rule@"entity"], state[[2]]]]}]] /@ states], {{1., entities}}, rules] optimizeProb[property_, choices_, objective_, entities_, rules_, searchDepth_] := Module[{rulesSafe = Select[rules, property =!= prop[#entity, #property] &]}, First@MaximalBy[ Table[{c, Module[{newState = applyRulesProb[ReplacePart[entities, List @@ property -> c], rulesSafe]}, If[searchDepth > 1, Function[branch, branch[[1]]* Last@optimizeProb[property, choices, objective, branch[[2]], rulesSafe, searchDepth - 1]] /@ newState // Total, Function[branch, branch[[1]]*branch[[2]] @@ objective] /@ newState // Total]]}, {c, entities @@ choices}], Last]] He now displays the desired behavior of choosing to start fishing immediately, waiting until a fish bites, then reeling and unhooking, then continuing. ![enter image description here][6] Right now, the fisherman has perfect knowledge of the system. This is because I pass in the full rules and full set of entities of the system to the optimization search. An interesting next step as I add rules and properties to the system will be to use a subset of the entities and rules that represent his limited mind and knowledge. Then I can add rules that update his knowledge and even his happiness function over time to make him learn. For example, say whether or not a fish bites is actually deterministic based on more detailed rules for crab behavior. However, let's says the fisherman's copy of the system rules excludes those and instead just assumes a 30% random chance of catching a fish. Further, assume the 30% expectation is represented as a property of the fisherman (say "fishing optimism"). Then we can easily add a rule that increases his optimism whenever he catches a fish, and decreases it whenever he doesn't. Then say we add time of day to the system, and expand his happiness function to decrease when he stays out too late fishing. Then he will automatically choose to stay out a little later when he has been a catching a lot of fish compared to when he hasn't been catching many. That's just one possible extension I've considered. I don't know if this approach will ever lead to me making a commercially successful game, but it's holding my attention for now. [1]: http://www.gatheredgame.com/ [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdfae54w6ujtyehrgeafsd.gif&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7103temp.png&userId=64737 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2015-11-02_11-02-21.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5320temp.png&userId=64737 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9395temp.gif&userId=64737 Michael Hale 2015-11-01T23:48:50Z