Hot answers tagged

149

I did a very simple (in fact over-simple) snowflake simulator with CellularAutomaton years before. It's based on the hexagonal grid: and range-1 rules: Initial code First we'll need some functions to display our snowflakes: Clear[vertexFunc] vertexFunc = Compile[{{para, _Real, 1}}, Module[{center, ratio}, center = para[[1 ;; 2]]; ratio = ...


54

========== update =========== Remember guys how we can cut out a snowflake from a sheet of paper carving 12th folded part? Like the image below. So I decided to write an app to imitate the process. It also can be used to make random snowflakes (similar to to @bill s' but with reflection to imitate real cutting paper process and reflective symmetry of ...


47

The only reason I am attempting to answer this is to perhaps get a Reversal badge. There you go... We will go slowly and this answer is the basis for what comes next. Let's start with two dimensions. You'll see why. We create a rectangular region: Needs["NDSolve`FEM`"] mesh = ToElementMesh[FullRegion[2], {{0, 5}, {0, 1}}, "MeshOrder" -> 1, "...


40

After correcting the syntax errors in the original code, the actual question can be addressed: How to display the four variables x1[t]...y2[t] as an animation in a way that conveys their meaning? The basic idea is to use ListAnimate on a list of frames that I define below: Clear[phi1, phi2, t]; sol = First[ NDSolve[{2*phi1''[t] + phi2''[t]*Cos[phi1[t] - ...


36

The power of Mathematica's syntax allows us to create dice in several different ways. Here's one way that I like: dice[n_Integer] := dice[n, Black] Format[dice[n_Integer, c_]] := With[{ dots = {1 -> {5}, 2 -> {3, 7}, 3 -> {3, 5, 7}, 4 -> {1, 3, 7, 9}, 5 -> {1, 3, 5, 7, 9}, 6 -> {1, 2, 3, 7, 8, 9}} /. l : {...


33

Usage Just use this function with any polyhedron in in form: GraphicsComplex[pts_, Polygon[vertices_, ___]]. When I find time and motivation maybe I will add more DownValues so it can be more general. At the moment you can play with solids given by PolyhedronData[... "Faces"]: polyhedronRandomWalk[ PolyhedronData["DuerersSolid", "Faces"] ] It ...


32

Update June 2015 Here is an updated version of the program. I've made it compatible with newer Mathematica versions (AstronomicalData returns Quantity structures in newer versions, which wrangled calculations). It should now work on versions 8 through 10. Let me know if it doesn't. I added animation and simplified the presentation (no tooltips in the ...


28

We have unicode support so we can use the following strings: {"⚀", "⚁", "⚂", "⚃", "⚄", "⚅"}: dice = FromCharacterCode /@ Range[9856, 9856 + 5]; Grid[Partition[RandomInteger[{1, 6}, {50, 2}], 5] /. { i : {__Integer} :> Style[ Row[dice[[i]], Spacer[1]], {Large, Total[i] /. {7 -> Red, _ -> Black}}]} , Frame -> All]


25

BernoulliDistribution is a perfect fit for this. RandomVariate[BernoulliDistribution[1 - 0.1], {50}] {1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1} Also, as kguler states, you can use RandomChoice, but the benefit of BernoulliDistribution is that ...


24

After importing a free dice 3D model {pd, vd} = Import["c:\\dice.stl", #] & /@ {"PolygonData", "VertexData"}; g2 = Translate[GraphicsComplex[vd, Polygon /@ pd], {-10, -37.5, -10}]; rv = {{0, 0, -1}, {0, -1, 0}, {0, 0, 1}, {0, 1, 0}, {-1, 0, 0}, {1, 0, 0}}; dice[x_List, n_Integer] := Rasterize@(Graphics3D[{EdgeForm[None], Blue, Rotate[g2,{{0, 0, 1},...


23

The programming style you are using is not very fitting for Mathematica. Here's a better way (shorter, much faster): n = 1000000; (* number of points to use *) octantVolume = N[ Total@UnitStep[1 - Norm /@ RandomReal[1, {n, 3}]]/n ] The reason why you get the error you mention is that for some x, y, the expression 1 - x^2 - y^2 is negative, thus its ...


23

Here is a simple method that begins with an $n$-sided polygon (defined by the $n$ points in tab), then rotates the polygon and superimposes it six times to achieve the six-fold symmetry. The makeFlake function is: makeFlake[n_] := Module[{tab, rot}, tab = RandomReal[{-1/2, 1/2}, {n, 2}]; rot = RotationMatrix[Pi/3]; Graphics[{Hue[RandomReal[]], ...


22

You are trying to implement Euler-Maruyama simulation method for a 2-stage short-term interest rate model which is given by the following system of SDEs: $$\begin{eqnarray} \mathrm{d} \theta_t &=& -\lambda_\theta \left( \theta_t - \bar\theta\right) \mathrm{d}t + \sigma_\theta \mathrm{d}W_{\theta,t} \\ \mathrm{d} \pi_t &=& -\lambda_\pi\...


21

Not so much snowflakes as random artworks with the same symmetry as snowflakes, but I wanted to join in the festive fun! These are generated with a "randomart" package I wrote a while ago (code at the bottom of the answer). It uses a kind of non-linear iterated function system to generate random images. Here's a grid of random images with snowflake symmetry:...


19

This answer is going to be a bit of a sprawl. Please read on. I am going to present several methods of simulation, hopefully in increasing order of performance. Method 1 We can carry out the filling of seats, at least as I understand the puzzle, quite literally like this: fillseats[seats_List] := ReplacePart[seats, {{1}, {2}} + RandomChoice @ ...


19

This was a fun question to answer, even considering that I know nothing about general relativity. It's all a matter of translating the equations presented in this paper by Oliver James, Eugenie von Tunzelmann, Paul Franklin, and Kip Thorne into notebook expressions. Embedding Diagrams The paper gives some really cool figures to show the curvature of 4-...


18

Method of random number generation is also significant: Default: n = 10^6; AbsoluteTiming[N@Mean@UnitStep[1. - Total[RandomReal[1, {3, n}]^2]] - π/6] {0.197896, 0.000649224} Niederreiter low-discrepancy sequence (see "methods" here): SeedRandom[Method -> {"MKL", Method -> {"Niederreiter", "Dimension" -> 3}}]; AbsoluteTiming[N@Mean@UnitStep[...


16

When n is large it's much faster to operate on a 3 x n array than to process each of the n 3-vectors separately. This is one of the standard "tricks" to speed things up. n = 10^6; (* Isn't that easier to read than 1000000 ? *) AbsoluteTiming @ N[ Total@UnitStep[ 1. - Norm/@RandomReal[1,{n,3}] ]/n ] (* {4.555842, 0.524302} *) AbsoluteTiming @ N[ Total@...


16

One way is to set up a DAE: See tutorial/DSolveExamplesOfDAEs and example/ModelConstrainedSystemsAsDAEs. The constraint that the driver (bottom rotating link) has a fixed length is taken care of by initial conditions and the DE. There are two possible starting positions for the driven link. One might have to inspect the result of Solve to determine which ...


16

I am delighted by this problem mostly because I was not aware of the underlying physical model of phase separation (the Cahn–Hilliard equation)! Anyway, here is an approximation of a somewhat similar behavior to start the discussion: NestList[ Sharpen@Threshold[GaussianFilter[#, 2], {"Hard", {"BlackFraction", 0.1}}] &, img, 50 ]; ListAnimate[%...


15

Here is an un-golfed and simplified version of an L-System production based on a previous answer of mine: f1[initState_, rotAngle_, prodRules_, iters_] := Module[{currAngle = 0, currPos = {0, 0}, res = {}}, (res = {res, Line@{currPos, currPos += {Cos@currAngle, Sin@currAngle}}}; If[NumericQ@#, currAngle += I^# rotAngle]) & /@ ...


15

Well I guess one more couldn't hurt. Using an iterated matrix-replacement scheme and some fancy opacity: powzerz = 2; width = 550; primitive = Scale[Cuboid[], 0.99999]; matrix0 = {{{1}}}; matrixT = CrossMatrix[{1, 1, 1}]; rules = {0 -> (0 #1 &), 1 -> (#1 &)}; iterate[matrix0_, matrixT_, rules_, power_] := Nest[Function[prev, ...


15

The separation-of-variables solution you quoted has two indices appearing in it: n and j (the subscripts of the coefficient $A_{nj}$). Here, n is azimuthal mode order, i.e. it counts the number of nodes along the direction in which the polar-angle $\theta$ varies (divided by 2). The index j is needed because the wave is supposed to satisfy the boundary ...


14

A smooth changing fractal snowflake: {s, d, t} = {0, 1, 3}; Dynamic@Graphics@ Polygon@Reap[ If[# != 0, t += 8.^-5; Do[#0[# - 1]; Sow[d = Sign@d #; {Re[s += d], Im@s}] & /@ (# E^(I t #) &@ Range@6/(5^(4 - #))); d *= E^((\[Pi] - 63 t)/3 I), {6}]] &@ 3][[2, 1]]


14

The printed version of the 2002 edition was printed 3 times and sold out 3 times; Springer and Google recently started selling it (book only) as a PDF eBook (no software) on the Springer and Google sites for $79. I know other authors (e.g. here) have gone to some trouble to make their books available here on stack exchange ... We are delighted to be able ...


13

Using the same (well slightly modified) Wolfram demonstrations code as bill s dicelist = {{Disk[{0, 0}, 0.2]}, {Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2]}, {Disk[{0, 0}, 0.2], Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2]}, {Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2], Disk[{-0.6, 0.6}, 0.2]}, {Disk[{...


12

As I mentioned in the comments, using Mod[] is one good way to enforce your periodic boundary conditions: just generate the random walk as usual, and then apply Mod[] to bring back inside the sections that are outside your box. Here's an example of what I'm describing: n = 5*10^3; (* number of steps *) s = 20; (* cube edge length *) h = 1/10; (* step bound ...


12

Rapid calculations are afforded by Accumulate to generate the walk and Mod to implement the periodicity. Scaling the entire thing to the unit cube simplifies the code a little. Furthermore, don't generate normally distributed displacements: uniform displacements will do when the increments are small. With these efficiencies we may generate the coordinates ...


12

For the example you give there is no reason you can't use NestList, you just need to make two simple changes: Don't use the side effect in deltaπt to get the value for θnow, give it as an explicit second argument Then you just do: NestList[{deltaπt[#[[1]], #[[2]]] + #[[1]], deltaθt[#[[2]]] + #[[2]]} &, {2, 2}, noYear] Similar changes would allow ...


12

Here's one way, borrowing heavily from one of the Wolfram demonstrations. dicelist[rb_] := {{rb, Disk[{0, 0}, 0.2]}, {rb, Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2]}, {rb, Disk[{0, 0}, 0.2], Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2]}, {rb, Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2], Disk[{-0.6, 0.6}, 0.2]}, {rb, Disk[{0, ...



Only top voted, non community-wiki answers of a minimum length are eligible