https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Computer Science sorted by most likes. https://community.wolfram.com/groups/-/m/t/1931315 [![enter image description here][2]][1] &[Wolfram Notebook][3] [1]: https://youtu.be/rOa5IntICFA [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-04-09at12.54.33PM.png&userId=11733 [3]: https://www.wolframcloud.com/obj/afe2a2fb-ee55-4df5-a6fb-9bc16dd08af7 Brenton Bostick 2020-04-09T15:04:38Z https://community.wolfram.com/groups/-/m/t/148287 I am an artist, drawing and working with 3d. Since long time, I am missing a method to form realistic folds and wrinkles into virtual sheets of paper, metal or cloth. I found some attempts within 3d-programs, but I never saw something that was not very limited or looked like rubber. Because it is so easy at reality, but so difficult at the computer, I think there is just little mathematical base.First of all: Could anybody tell me, what field of mathematics this is? [img=width: 800px; height: 1132px; ]/c/portal/getImageAttachment?filename=Folds-01.jpg&userId=145842[/img] [img=width: 800px; height: 1132px; ]/c/portal/getImageAttachment?filename=Folds-02.jpg&userId=145842[/img] Dietmar Klein 2013-11-03T23:03:23Z https://community.wolfram.com/groups/-/m/t/1017668 *NOTE: Please see the original version of this post and related discussion [**HERE**][1]. Cross-posted here per suggestion of [Vitaliy Kaurov][2].* ---------- You will find a lot of information in [this][3] answer. I will add a few personal notes. ##Module Use `Module` when you want to localize variables inside your function's body, and those variables will potentially acquire and/or change their values during the computation. ###Basic use For example: f[x_]:=Module[{y=x^2},y=y+x;{x,y}] Here, a local mutable variable (symbol) `y` is local to the `Module`, and is, indeed, a symbol with a unique name. This is the closest you have in Mathematica to, say, local variables in C. ###Advanced uses `Module` also has advanced uses. One of them is to create closures - functions with a persistent state. My third post in [this][4] thread illustrates many cases of that and has further references. One example I will steal from there: the following function will produce the next Fibonacci number on demand, and yet it will be as fast as the iterative loop implementation for generation of consecutive Fibonacci numbers (since Module is invoked only once, when the function is defined): Module[{prev, prevprev, this}, reset[] := (prev = 1; prevprev = 1); reset[]; nextFib[] := (this = prev + prevprev; prevprev = prev; prev = this) ]; reset[]; Table[nextFib[], {1000}]; // Timing (* ---> {0.01, Null} *) One problem with persistence created with `Module`-variables is that one should not generally serialize such state (definitions), for example by saving the state via `Save` or `DumpSave`. This is because, the uniqueness of names for `Module`-generated symbols is guaranteed only within a single Mathematica session. `Module` also allows one to create *local functions*, which `With` does not (except pure functions). This is a very powerful capability. It is particularly useful for writing recursive functions, but not only. In the link mentioned above, there were examples of this. One problem with local functions created by `Module` is that these symbols won't be automatically garbage-collected when `Module` finishes (if they have `DownValues`, `SubValues` or `UpValues`. `OwnValues` are fine), and so may lead to memory leaks. To avoid that, one can `Clear` these symbols inside `Module` before returning the result. ##With Use `With` to define local constants, which can not be changed inside the body of your function. ###Basic use For example, f[x_,y_]:=With[{sum = x+y},{sum *x, sum *y}] It is instructive to trace the execution of `f`. You will notice that `sum` gets replaced by its value very early on, before the body starts evaluating. This is quite unlike `Module`, where variable entries get replaced by their values in the process of evaluation, just as it would normally happen were the variables global. ###Advanced uses On an advanced level, `With` can be used to inject some evaluated code deep into some expression which is otherwise unevaluated: With[{x=5},Hold[Hold[x^2]]] (* Hold[Hold[5^2]] *) and is thus an important meta-programming tool. There are lots of uses for this feature, in particular one can use this to inject code into `Compile` at run-time right before compilation. This can extend the capabilities / flexibility of `Compile` quite a bit. One example can be found in my answer to [this][5] question. The semantics of `With` is similar to that of rule substitutions, but an important difference is that `With` cares about inner scoping constructs (during variable name collisions), while rules don't. Both behaviors can be useful in different situations. ###Module vs With Both of these are *lexical* scoping constructs, which means that they bind their variables to lexical their occurrences in the code. Technically, the major difference between them is that you can not change the values of constants initialized in `With`, in the body of `With`, while you can change values of `Module` variables inside the body. On a deeper level, this is because `With` does not generate any new symbols. It does all the replacements before the body evaluates, and by that time no "constant symbols" are at all present, all of them replaced with their values. `Module`, OTOH, does generate temporary symbols (which are normal symbols with an attribute `Temporary`), which can store a mutable state. Stylistically, it is better to use `With` if you know that your variables are in fact constants, i.e. they won't change during the code execution. Since `With` does not create extra (mutable) state, the code is cleaner. Also, you have more chances to catch an occasional erroneous attempt in the code to modify such a constant. Performance-wise, `With` tends to be faster than `Module`, because it does not have to create new variables and then destroy them. This however usually only shows up for very light-weight functions. I would not base my preference of one over another on performance boosts. ##Block ###Basic use `Block` localizes the *value* of the variable. In this example, `a` does not refer to `i` *literally* inside `Block`, but still uses the value set by `Block`. a:=i Block[{i=2},a] {a,i} `Block` therefore affects the *evaluation stack*, not just the literal occurrences of a symbol inside the code of its body. Its effects are much less local than those of lexical scoping constructs, which makes it much harder to debug programs which use `Block` extensively. It is not much different from using global variables, except that `Block`guarantees that their values will be restored to their previous values once the execution exits `Block` (which is often a big deal). Even so, this non-transparent and non-local manipulation of the variable values is one reason to avoid using `Block` where `With` and / or `Module` can be used. But there are more (see below). In practice, my advice would be to avoid using `Block` unless you know quite well why you need it. It is more error-prone to use it for variable localization than `With` or `Module`, because it does not prevent variable name collisions, and those will be quite hard to debug. One of the reasons people suggest to use `Block` is that they claim it is faster. While it is true, my opinion is that the speed advantage is minimal while the risk is high. I elaborated on this point [here][6], where at the bottom there is also an idiom which allows one to have the best of both worlds. In addition to these reasons, as noted by @Albert Retey, using `Block` with the `Dynamic` - related functionality may lead to nasty surprises, and errors resulting from that may also be quite non-local and hard to find. One valid use of `Block` is to temporarily redefine some global system settings / variables. One of the most common such use cases is when we want to temporarily change the value of $RecursionLimit or $IterationLimit variables. Note however that while using Block[{$IterationLimit = Infinity}, ...] is generally okay, using Block[{$RecursionLimit = Infinity}, ...] is not, since the stack space is limited and if it gets exhausted, the kernel will crash. A detailed discussion of this topic and how to make functions tail-recursive in Mathematica, can be found e.g. in my answer to [this question][7]. It is quite interesting that the same ability of `Block` can be used to significantly extend the control the user has over namespaces/symbol encapsulation. For example, if you want to load a package, but not add its context to the `$ContextPath` (may be, to avoid shadowing problems), all you have to do is Block[{$ContextPath}, Needs[Your-package]] As another example, some package you want to load modifies some other function (say, ``System`SomeFunction``), and you want to prevent that without changing the code of the package. Then, you use something like Block[{SomeFunction}, Needs[That-package]] which ensures that all those modifications did not affect actual definitions for `SomeFunction` - see [this answer][8] for an example of this. ###Advanced uses `Block` is a very powerful metaprogramming device, because you can make every symbol (including system functions) temporarily "forget" what it is (its definitions and other global properties), and this may allow one to change the order of evaluation of an expression involving that symbol(s) in non-trivial ways, which may be hard to achieve by other means of evaluation control (this won't work on `Locked` symbols). There are many examples of this at work, one which comes to mind now is the `LetL` macro from my answer to [this][9] question. Another more advanced use of `Block` is to ensure that all used variables would be restored to their initial values, even in the case of Abort or exception happening somewhere inside the body of `Block`. In other words, it can be used to ensure that the system will not find itself in an illegal state in the case of sudden failure. If you wrap your critical (global) variables in `Block`, it will guarantee you this. A related use of `Block` is when we want to be sure that some symbols will be cleared at the end. [This question][10] and answers there represent good examples of using `Block` for this purpose. ###Variable name conflicts In nested scoping constructs, it may happen that they define variables with the same names. Such conflicts are typically resolved in favor of the inner scoping construct. The documentation contains more details. ###Block vs Module/With So, `Block` implements dynamic scoping, meaning that it binds variables in time rather than in space. One can say that a variable localized by `Block` will have its value during the time this `Block` executes (unless further redefined inside of it, of course). I tried to outline the differences between `Block` and `With`/`Module` (dynamic vs lexical scoping) in [this][11] answer. ###Some conclusions - For most common purposes of variable localization, use `Module` - For local constants, use `With` - Do not ordinarily use `Block` for introducing local variables - All of the scoping constructs under discussion have advanced uses. For `Module` this is mostly creating and encapsulating non-trivial state (persistent or not). For `With`, this is mostly injecting inside unevaluated expressions. For `Block`, there are several advanced uses, but all of them are, well, advanced. I'd be worried if I found myself using `Block` a lot, but there are cases when it is indispensable. ---------- [1]: http://mathematica.stackexchange.com/a/569 [2]: http://community.wolfram.com/web/vitaliyk/home [3]: http://stackoverflow.com/questions/6661393/mathematica-module-versus-with-or-block-guideline-rule-of-thumb-for-usage [4]: http://groups.google.com/group/comp.soft-sys.math.mathematica/browse_thread/thread/5eff6213a0ab5f51 [5]: http://stackoverflow.com/questions/4973424/in-mathematica-how-do-i-compile-the-function-outer-for-an-arbitrary-number-of [6]: http://stackoverflow.com/questions/7596460/condition-block-module-which-way-is-the-most-memory-and-computationally-effi/7597238#7597238 [7]: http://stackoverflow.com/questions/4481301/tail-call-optimization-in-mathematica [8]: http://stackoverflow.com/questions/4702590/fixing-combinatorica-redefinition-of-element/4720679#4720679 [9]: http://stackoverflow.com/questions/5866016/question-on-condition [10]: http://stackoverflow.com/questions/7342748/dynamic-programming-in-mathematica-how-to-automatically-localize-and-or-clear/ [11]: http://stackoverflow.com/questions/6236458/plot-using-with-versus-plot-using-block-mathematica/6236808#6236808 Leonid Shifrin 2017-02-20T10:08:24Z https://community.wolfram.com/groups/-/m/t/3495066 ![Visual and statistical analysis of LLMs via problem complexity][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=HeroImage-WSS25.bmp&userId=3492577 [2]: https://www.wolframcloud.com/obj/2bc91532-706a-4dbe-ab99-4446339eba44 Rakesh Vijay Kumar 2025-07-08T21:23:18Z https://community.wolfram.com/groups/-/m/t/1421180 Two months ago, Albert Rich posted ["What's the hardest integral Mathematica running Rubi can find?"](http://community.wolfram.com/groups/-/m/t/1343015) here on the Wolfram Community. You might have also seen that I responded in detail, and pointed out a few things that could help improve Rubi (Rule-based integrator). While it appears nothing really happened afterward, this is far from reality. Since then, Albert and I have worked closely together to make Rubi more accessible and user-friendly. If you would like to learn how our productive collaboration evolved, let me invite you to read [my latest blog-post](http://halirutan.de/programming/Rubi/). However, here, we want to share an update that should serve as an overview of what we have done to improve Rubi. First of all, Rubi has got a new home under [rulebasedintegration.org](https://rulebasedintegration.org/), and its old website will no longer be updated. On the new website, you will find information, installation instructions, and links to the source-code and test-suites. Secondly, we created a [Rubi Organization](https://github.com/RuleBasedIntegration) on GitHub that serves as the headquarters for all things Rubi. It contains all Rubi's code, notebooks, and test-suites nicely structured into several repositories. At the moment, we provide repositories for the * loadable package files and notebook source files defining over 6700 integration rules, * PDF files displaying the rules in human-readable mathematical notation alongside the Mathematica code, and * test-suite files containing over 71000 integration problems and their solutions. The integration test files are available in the syntax used by 4 popular computer algebra systems (Mathematica, Maple, Maxima, and Axiom). The test-suite can be used to compare Rubi's results with other symbolic integrators, including Mathematica's `Integrate` function. In addition to the transition to GitHub, we recently released version 4.16.0.3 of Rubi which significantly expands the class of expressions the system can integrate. But the most noticeable change for users is the completely reworked display of the rules and intermediate steps Rubi uses to integrate expressions. Although installation, usage, and examples are given on [Rubi's website](https://rulebasedintegration.org/), let me show you how easy it is to install and run Rubi 4.16.0.3 using Mathematica 11.3: The command PacletInstall["https://github.com/RuleBasedIntegration/Rubi/releases/download/4.16.0.3/Rubi-4.16.0.3.paclet"]; installs the Rubi-4.16.0.3 paclet on your computer. After that, to load Rubi into Mathematica all you have to do is issue the `Get` command << Rubi` Then to integrate an expression with respect to a variable, use Rubi's `Int` command similar to Mathematica's `Integrate` command. For example, evaluating Int[(Sec[x]^2 + Sec[x]^2*Tan[x])/((2 - Tan[x])*Sqrt[1 + Tan[x]^3]), x] returns the antiderivative (a.k.a. the indefinite integral) ![enter image description here][1] Rubi's unique ability to display the steps it uses to integrate expressions is a great feature of the system. For example, the `Steps` command Steps@Int[(Sec[x]^2 + Sec[x]^2*Tan[x])/((2 - Tan[x])*Sqrt[1 + Tan[x]^3]), x] displays ![enter image description here][2] Here, in red are the rules used to integrate the expression, and in blue are the intermediate results. Each rule can be expanded to show the rule number, which directly corresponds to the index of the rule in `Int`'s list of DownValues. More importantly, you can see the conditions that have to be satisfied so the rule can be applied. ![enter image description here][3] Rubi's `Stats` command provides statistics about the integration. For example, Stats[Int[(Sec[x]^2 + Sec[x]^2*Tan[x])/((2 - Tan[x])*Sqrt[1 + Tan[x]^3]), x]] displays ![enter image description here][4] The leaf-count size of an antiderivative is a crude measure of its complexity. As you can see, Rubi's antiderivative for this integral has a leaf-count of 25. Now compare Rubi's antiderivative with that produced by Mathematica 11.3 for the same integral: Integrate[(Sec[x]^2 + Sec[x]^2*Tan[x])/((2 - Tan[x])*Sqrt[1 + Tan[x]^3]), x] ![enter image description here][5] LeafCount[%] (* 290 *) Note that not only is Mathematica's result more than 11 times the size of Rubi's, it unnecessarily involves elliptic integral functions *and* the imaginary unit. Skeptics might be inclined to ask if Rubi's dramatically simpler result is actually a valid antiderivative. Since symbolic differentiation is much easier than integration, antiderivatives can be verified correct by seeing if its derivative equals the original integrand as follows: expr = (Sec[x]^2 + Sec[x]^2*Tan[x])/((2 - Tan[x])*Sqrt[1 + Tan[x]^3]); FullSimplify[D[Int[expr, x], x] == expr] FullSimplify[D[Integrate[expr, x], x] == expr] ![enter image description here][6] As you can see Mathematica easily verifies Rubi's antiderivative correct, but has a hard time verifying its own antiderivative correct... Albert and I are working on publishing the program used to thoroughly test each new version of Rubi before being released. The test program ensures Rubi's result equals the optimal antiderivative for the over 71000 problems in the test-suite. And yes, the optimal antiderivatives have all been verified correct by differentiation. Of course, the optimal antiderivatives stored in the test-suite are actually just the simplest ones found so far. If you should find a substantially simpler antiderivative than the one in the test-suite, please report it so the test-suite can be made even harder on Rubi! If all that has got you interested in joining Rubi's community of users, check out its website or talk to us in our [Gitter chatroom](https://gitter.im/Rule-Based-Integration/Lobby). [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10564sSs5M.png&userId=11733 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=qDtIH.png&userId=11733 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=vQ4GR.png&userId=11733 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=43t8e.png&userId=11733 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=xjKTJ.png&userId=11733 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=eCoWB.png&userId=11733 Patrick Scheibe 2018-08-24T02:50:37Z https://community.wolfram.com/groups/-/m/t/1330785 *WOLFRAM MATERIALS for the ARTICLE:* > William Gilpin. *Cryptographic hashing using chaotic hydrodynamics*. > Proceedings of the National Academy of Sciences, 115 (19) (2018), pp. 4869-4874. > https://doi.org/10.1073/pnas.1721852115 > [Full article in PDF][1] ![enter image description here][2] ##Introduction## Last week, William Gilpin published a fascinating paper suggesting a physics-based hashing mechanism in the Proceedings of the National Society: Cryptographic hashing using chaotic hydrodynamics: https://doi.org/10.1073/pnas.1721852115 The paper discusses a hashing algorithm based on fluid mechanics: Particles are distributed in a 2D disk. The inside of the disk is filled with an idealized fluid and the fluid is now stirred with a single stirrer. The stirring process is modelled with two possible stirrer positions. A message (say made from 0s and 1s) can now be encoded through which of the two stirrer positions is active. If the bit from the message is 1, use stirrer position 1, if the bit of the message is 0, use stirrer position 2. After some bites are processed, and the fluid is stirred, this process mixes the particles. Dropping some of the information content of the actual particle positions, e.g. by taking only the x-positions of the particle positions allows to build a hash by using the particle indices after sorting the particles along the x-axis. The Methods section of the paper mentions that all calculations were carried out using Mathematica 11.0. Unfortunately no notebook supplement was given. So, playing around with ideas of the paper, I re-implemented some of the computations of the paper. The paper is behind a paywall, but fortunately the author's website has a downloadable copy of the paper [here][3]. The potential importance of physics-based models for hashing, and so for cryptocurrencies was pointed out at various sites (e.g. [Stanford News][4], [btcmanager][5]). It is fun to play around with the model. ##The chaotic advection model model## This classic model goes back to Hassan Aref (whom I was fortunate to know personally) from his 1984 paper [Stirring by chaotic advection][6]. The Hamiltonian for the movement of a particle with coordinates {ξ,η} in a circle of radius a under the influence of agitating vortex at {x,y} (possibly time-dependent) of strength Γ and its mirror vortex. H[{ξ_, η_}, {x_, y_}] = Γ/(2 π) Log[ComplexExpand[ Abs[((ξ + I η) - (x + I y))/((ξ + I η) - a^2/( x - I y))]] ] ![enter image description here][7] The resulting equations of motion: odes = {ξ'[t] == -D[H[{ξ[t], η[t]}, {x[t], y[t]}], η[t]], η'[ t] == +D[H[{ξ[t], η[t]}, {x[t], y[t]}], ξ[t]]} // Simplify ![enter image description here][8] Solve the equations of motion for randomly selected parameters and plot the particle trajectory. For a position-independent and time-independent vortex, the particle moves in a circle. nds = NDSolveValue[{ Block[{a = 1, Γ = 1, x = 0.5 &, y = 0 &}, odes], ξ[0] == 0.3, η[0] == -0.4}, {ξ[t], η[t]}, {t, 0, 10}] ![enter image description here][9] ParametricPlot[Evaluate[nds], {t, 0, 10}] ![enter image description here][10] Here the vortex moves around in a periodic manner. The resulting particle trajectory has a high degree of symmetry. nds2 = NDSolveValue[{ Block[{a = 1, Γ = 1, x = 0.8 Cos[2 Pi #/200] &, y = 0.8 Sin[2 Pi #/200] &}, odes], ξ[0] == 0.3, η[0] == -0.4}, {ξ[t], η[t]}, {t, 0, 400}] ![enter image description here][11] ParametricPlot[Evaluate[nds2], {t, 0, 400}, PlotPoints -> 400] ![enter image description here][12] Letting the vortex move along a random curve results in a chaotic movement of the particle. We color the particle's trajectory with time. (* vortex movement curve *) randomCurve = BSplineFunction[RandomPoint[Disk[], {100}]]; X[t_Real] := randomCurve[t/100][[1]] Y[t_Real] := randomCurve[t/100][[2]] nds2 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = X, y = Y}, odes], ξ[0] == 0.3, η[0] == -0.4}, {ξ[t], η[t]}, {t, 0, 100}] ![enter image description here][13] ParametricPlot[Evaluate[nds2], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][14] Having two possible positions of the vortex and switching periodically between them results in a particle trajectory that is made of piecewise circle arcs. nds2 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = Sign[Sin[Pi #]]/2 &, y = 0 &}, odes], ξ[0] == 2/3, η[0] == 0}, {ξ[t], η[t]}, {t, 0, 100}]; ParametricPlot[Evaluate[nds2], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][15] Using initially 4320 points on a circle shows how the initial circle gets stretched and ripped apart and the points distribute chaotically over the disk. nds2 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = Sign[Sin[Pi #]]/2 &, y = 0 &}, odes], ξ[0] == Table[2/3 Cos[φ], {φ, 0, 2 Pi, 2 Pi/(12 360)}], η[0] == Table[2/3 Sin[φ], {φ, 0, 2 Pi, 2 Pi/(12 360)}]}, {ξ[t], η[t]}, {t, 0, 2}]; GraphicsGrid[ Partition[Graphics[{LightGray, Disk[], Black, PointSize[0.005], Point[Transpose[nds2 /. t -> #]]}, ImageSize -> 120] & /@Range[0, 2, 2/19] , 5]] ![enter image description here][16] With time running upwards, here is a 3D image of this stirring process. The transition from using the right stirrer to using the left stirrer at time 1 is clearly visible. trajectories3D = Transpose[Table[ Append[#, N[τ]] & /@ Transpose[nds2 /. t -> τ], {τ, 0, 2, 2/100}]]; Graphics3D[{Thickness[0.001], Opacity[0.2], BSplineCurve /@ RandomSample[trajectories3D, 1600]}, PlotRange -> All, Axes -> True, BoxRatios -> {1, 1, 2}] ![enter image description here][17] Here is the corresponding interactive demonstration. Manipulate[ Graphics[{LightGray, Disk[], Black, PointSize[0.005], Point[Transpose[nds2 /. t -> τ]]}], {τ, 0, 2, Appearance -> "Labeled"}] ![enter image description here][18] The x-position of the particles will be used later. Here is a plot of the x-positions of 540 points initially on a circle over time.One observes many crossing of these x-trajectories. nds2B = NDSolveValue[{ Block[{a = 1, Γ = 4, x = Sign[Sin[Pi #]]/2 &, y = 0 &}, odes], ξ[0] == Table[2/3 Cos[φ], {φ, 0, 2 Pi, 2 Pi/540}], η[0] == Table[2/3 Sin[φ], {φ, 0, 2 Pi, 2 Pi/540}]}, {ξ[t], η[t]}, {t, 0, 12}]; ListLinePlot[Transpose[Table[{t, #} & /@ nds2B[[1]], {t, 0., 4, 4/200}] ], PlotStyle -> Table[Directive[Opacity[0.4], Thickness[0.001], ColorData["DarkRainbow"][j/541]], {j, 541}], Frame -> True, Axes -> False, FrameLabel -> {t, x}] ![enter image description here][19] Using a Dynamic[particleGraphics] we can easily model many more particles in real time without having to store large interpolating functions. We solve the the equations of motion over small time increments and the graphic updates dynamically. rPoints = Select[Flatten[Table[N[{x, y}], {x, -1, 1, 2/101}, {y, -1, 1, 2/101}], 1], Norm[#] < 1 &]; Dynamic[Graphics[{LightGray, Disk[], Black, PointSize[0.001], Point[rPoints]}]] ![enter image description here][20] rhsξ[X_, ξ_List, η_List] := With[{ Γ = 5}, -(((1 - X^2) Γ η (1 + X^2 - 2 X ξ))/(2 π (X^2 + η^2 - 2 X ξ + ξ^2) (1 - 2 X ξ + X^2 (η^2 + ξ^2))))] rhsη[X_, ξ_List, η_List] := With[{ Γ = 5}, -(((1 - X^2) Γ (-ξ - X^2 ξ + X (1 - η^2 + ξ^2)))/(2 π (X^2 + η^2 - 2 X ξ + ξ^2) (1 - 2 X ξ + X^2 (η^2 + ξ^2))))] With[{Δt = 10^-2, T = 0.2}, Monitor[ Do[ nds = NDSolveValue[ Block[{ X = Evaluate[1/2 Sign[Sin[Pi (k + 1/2) Δt/T]]] &}, {ξ'[t] == rhsξ[t, ξ[t], η[t]], η'[t] == rhsη[t, ξ[t], η[t]], ξ[k Δt] == Transpose[rPoints][[1]], η[k Δt] == Transpose[rPoints][[2]]}], {ξ[t], η[t]}, {t, (k + 1) Δt, (k + 1) Δt}] /. t -> (k + 1) Δt; rPoints = Transpose[nds], {k, 0, 200}], k]] Switching irregularly between the two stirrer positions gives qualitatively similar-looking trajectories. We use a sum of three trig functions see here for a detailed account on this type of function). (* left or right stirrer is on *) Plot[Sign[Sin[Pi t] + Sin[Pi Sqrt[2] t] + Sin[Pi Sqrt[3] t]], {t, 0, 100}, Exclusions -> None] ![enter image description here][21] nds3 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = Sign[Sin[Pi #] + Sin[Pi Sqrt[2] #] + Sin[Pi Sqrt[3] #]]/2 &, y = 0 &}, odes], ξ[0] == 2/3, η[0] == 0}, {ξ[t], η[t]}, {t, 0, 100}]; ParametricPlot[Evaluate[nds3], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][22] We can also change the stirring direction. nds3B = NDSolveValue[{ Block[{a = 1, Γ = 10 Sign[Sin[Pi t] + Sin[Pi Sqrt[2] t] + Sin[Pi Sqrt[3] t]], x = Sign[Sin[Pi #] + Sin[Pi Sqrt[2] #] + Sin[Pi Sqrt[3] #]]/2 &, y = 0 &}, odes], ξ[0] == 2/3, η[0] == 0}, {ξ[t], η[ t]}, {t, 0, 100}]; ParametricPlot[Evaluate[nds3B], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][23] Here are three stirrer positions at the vertices of an equilateral triangle. st3[t_] = Piecewise[ With[{r = RandomInteger[{0, 2}]}, {1/2. {Cos[2 Pi r/3], Sin[2 Pi r/3]}, #[[1]] <= t <= #[[2]] }] & /@ Partition[FoldList[Plus, 0, RandomReal[{0, 1}, 300]], 2, 1]]; x3[t_Real] := st3[t][[1]] y3[t_Real] := st3[t][[2]] nds3 = NDSolveValue[{ Block[{a = 1, Γ = 5, x = x3, y = y3}, odes], ξ[0] == 1/3, η[0] == 0}, {ξ[t], η[t]}, {t, 0, 100}] ![enter image description here][24] ParametricPlot[Evaluate[nds3], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][25] ##Side note: the linked twist map## Mathematically, alternating left and right use of the stirrer, is isomorphic to a so-called linked twist map. The following implements a simple realization of a linked twist map from Cairns /Kolganova. https://doi.org/10.1088/0951-7715/9/4/011 Clear[g, h, f]; g[{x_, y_}] := {x, Mod[Piecewise[{{y + 4 x, Abs[x] <= 1/4}}, y], 1, -1/2]} h[{x_, y_}] := {Mod[Piecewise[{{x + 4 y, Abs[y] <= 1/4}}, x], 1, -1/2], y} f[{x_, y_}] := g[h[{x, y}]] f[{x, y}] ![enter image description here][26] In explicit piecewise form, the map is more complicated. (To fit it, we use a reduce size.) (f2 = PiecewiseExpand[# , -1/2 < x < 1/2 && -1/2 < y < 1/2] & /@ f[{x, y}]) ![enter image description here][27] Here are the first and second component visualized. {ContourPlot[Evaluate[f2[[1]]], {x, -1/2, 1/2} , {y, -1/2, 1/2}, Exclusions -> {}, PlotPoints -> 60], ContourPlot[Evaluate[f2[[2]]], {x, -1/2, 1/2} , {y, -1/2, 1/2}, Exclusions -> {}, PlotPoints -> 60]} ![enter image description here][28] Applying the linked twist map to a set of points inside a square hints at the ergodic nature of the map. ptsRG = With[{pp = 80}, Table[{RGBColor[x + 1/2, y + 1/2, 0.5], Point[{x, y}]}, {y, -1/2, 1/2, 1/pp}, {x, -1/2, 1/2, 1/pp}]]; Graphics /@ NestList[Function[p, p /. Point[xy_] :> Point[f@xy]], ptsRG, 3] ![enter image description here][29] ##Closed form mapping## As mentioned, for a fixed stirrer position, a particle moves along a circle. This means that to move the particle to its final position, we don't have to solve nonlinear differential equations, but rather can calculate the final position through algebraic computations which are unfortunately not fully explicit. Doing the calculations (see Aref's paper for details) shows that we will have to solve of transcendental equation. In the following we will use a unit disk of radius 1 and a unit strength vortex. The particle is initially at {r,θ} (in polar coordinates) and the stirrer is at {±b,0}. a = 1; Γ = 1; The circle the particle is moving on. circle[{r_, θ_}, b_] := Module[{λ, ξc, ρ}, λ = Sqrt[(b^2 + r^2 - 2 b r Cos[θ])/(a^4/b^2 + r^2 - 2 a^2 r Cos[θ]/b)]; ξc = (b - λ^2 a^2/b)/(1 - λ^2); ρ = Abs[λ/(1 - λ^2) (a^2/b - b)]; Circle[{ξc, 0}, ρ]] The period for one revolution on the circle. period[{r_, θ_}, b_, T_] := Module[{λ, ρ, Tλ}, λ = Sqrt[(b^2 + r^2 - 2 b r Cos[θ])/(a^4/b^2 + r^2 - 2 a^2 r Cos[θ]/b)]; ρ = Abs[λ/(1 - λ^2) (a^2/b - b)]; Tλ = (2 Pi)^2 ρ^2/Γ (1 + λ^2)/(1 - λ^2) ] The final position after rotating for time T. rotate[{r_, θ_}, b_, T_, opts___] := Module[{(*λ,ξc,ρ,θp,Tλ,eq,fr*)}, λ = Sqrt[(b^2 + r^2 - 2 b r Cos[θ])/(a^4/b^2 + r^2 - 2 a^2 r Cos[θ]/b)]; ξc = (b - λ^2 a^2/b)/(1 - λ^2); ρ = Abs[λ/(1 - λ^2) (a^2/b - b)]; θp = ArcTan[r Cos[θ] - ξc, r Sin[θ]]; Tλ = (2 Pi)^2 ρ^2/Γ (1 + λ^2)/(1 - λ^2); (* the implicit equation to be solved numerically for θt *) eq = θt - 2 λ/(1 + λ^2) Sin[θt] == θp - 2 λ/(1 + λ^2) Sin[θp] + 2 Pi T/Tλ; fr = FindRoot[eq, {θt, θp}, opts] // Quiet; (* could use Solve[eq, θt, Reals] *) {Sqrt[ρ^2 + ξc^2 + 2 ρ ξc Cos[θt]], ArcTan[ρ Cos[θt] + ξc, ρ Sin[θt]]} /. fr] A high-precision version for later use. rotateHP[{r_, θ_}, b_, T_ ] := With[{prec = Precision[{r, θ}]}, rotate[{r, θ}, b, T, WorkingPrecision -> Min[prec, 200] - 1, PrecisionGoal -> prec - 10]] rotateHP[{2/5, 1}, 1/2, 10^-10] {0.3999999999735895736749310453217879335729586969724148186668989989685300449569453838180010833652353802304511654926113687832716502416432363896855780225351918314742068365263060199921670958293439964299441, 1.000000000034865509829422032384759003150106866109371061507406908121303212377635808764825759934117372434662086592066738925787825280696681907390281734196810440241159138906978471624124765879791828431390} Also for later use, rotate many points at once. rotate[l : {_List ..}, b_, T_ ] := rotate[#, b, T] & /@ l rotateHP[l : {_List ..}, b_, T_ ] := rotateHP[#, b, T] & /@ l The locator is the initial particle position; the stirrer position is the purple point. We show the circle and the final particle position (gray point). Manipulate[ Graphics[{LightGray, Disk[], Purple, PointSize[0.02], Point[{b, 0}] , Gray, circle[ToPolarCoordinates[p], b] , PointSize[0.01], Point[p], Blue , Point[ FromPolarCoordinates[ rotate @@ SetPrecision[ {ToPolarCoordinates[p], b, T}, 200] ]]}], {{T, 0.2}, 0.001, 10}, {{b, 0.5}, -0.999, 0.999}, {{p, {0.3, 0.4}}, Locator}] ![enter image description here][30] Here is a plot of the period for one revolution as a function of the initial position of the particle. The period can get quite large when points are near the boundary of the disk ParametricPlot3D[{r Cos[θ], r Sin[θ], period[{r, θ}, 1/2, 1]}, {r, 0, 1}, {θ, -Pi, Pi}, BoxRatios -> {1, 1, 0.3}, PlotPoints -> 40, MeshFunctions -> {#3 &}] ![enter image description here][31] For the stirrer located at {0.5,0}, here are the possible circles that the particle will move on. Graphics[Table[circle[{r, θ}, 1/2.] , {r, 1/10, 9/10, 1/10}, {θ, -Pi, Pi, 2 Pi/20}]] ![enter image description here][32] We use the closed form of the stirring map to visualize the flow. Here are about 20k points in stripes in the unit disk. stripePoints = Select[RandomPoint[Disk[], 40000], Function[xy, Mod[xy[[1]], 0.2] < 0.1]]; Graphics[{PointSize[0.002], Point[stripePoints]}] ![enter image description here][33] We repeatedly stir with the left and then the right stirrer on for time 1. swirled[1] = rotate[ToPolarCoordinates[stripePoints], 0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[1]]]}] ![enter image description here][34] swirled[2] = rotate[swirled[1], -0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[2]]]}] ![enter image description here][35] swirled[3] = rotate[swirled[2], 0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[3]]]}] ![enter image description here][36] swirled[4] = rotate[swirled[3], -0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[4]]]}] ![enter image description here][37] ##Now stir and make hashes## We now use two different initial positions of the points: a sunflower-like one and a random one. randominitialPositions[n_, prec_] := SortBy[Table[ReIm[RandomReal[{0, 1}, WorkingPrecision -> prec] * Exp[ I RandomReal[{-Pi, Pi}, WorkingPrecision -> prec]]], {n}], First] SeedRandom[1234]; initialPositionsR = randominitialPositions[100, 250]; Graphics[{LightGray, Disk[], MapIndexed[Function[{p, pos}, {Red, PointSize[0.002], Point[p], Black, Text[pos[[1]], p]}], N[initialPositionsR]]}] ![enter image description here][38] sunflower[n_, R_, prec_] := Table[FromPolarCoordinates[ N[{Sqrt[j/n] R, Mod[2 Pi (1 - 1/GoldenRatio) j, 2 Pi, -Pi]}, prec]], {j, n}] Graphics[{LightGray, Disk[], Black, Point[sunflower[1000, 0.9, 20]]}] ![enter image description here][39] The message to encode we will tell in the form of a sequence of 0s and 1s. A zero means use the left stirrer position and a 1 means use the right stirrer position. So, we define a stirring process with a given message σ and fixed b and T as follows: stirringProcess[initialPositions_, bAbs_, T_, σ_List] := FromPolarCoordinates /@ FoldList[rotateHP[#1, #2 bAbs, T] &, ToPolarCoordinates /@ initialPositions, 2 σ - 1] Here is a simple message: message1 = RandomInteger[{0, 1}, 50] {1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,1, 0, 1, 0} Now we carry out the corresponding stirring process. (We arbitrarily use b=1/2 and T=1/10.) sP1 = stirringProcess[initialPositionsR, 1/2, 1/10, message1]; To get a feeling for the stirring process, we connect successive positions of each particle with a randomly colored spline interpolation. (Note that the spline interpolation does not exactly represent the particle's trajectory.) Graphics[{LightGray, Disk[], Thickness[0.001], Map[Function[c, {RandomColor[], BSplineCurve[c, SplineDegree -> 5]}], Transpose[N[Table[sP1[[j]], {j, 50}]]]]}] ![enter image description here][40] Now, can we trust these results? We can check by running the stirring process (numerically) backwards. sP1Rev = stirringProcess[sP1[[-1]], 1/2, -1/10, Reverse[message1]]; The so-recovered initial positions agree to at least 80 digits with the original point positions. sP1Rev[[-1]] - initialPositionsR // Abs // Max // Accuracy 86.9777 As mentioned earlier, we define the hashes as the positions of the particles when ordered according to their x-values. So, for a given particle configurations, this is the hash-making function. makeHash[l_] := Sort[ MapIndexed[{#1, #2[[1]]} &, l]][[All, 2]] Because the hashes are permutations of the particle numberings, the number of hashes grows factorially with the particle number and 58 particles could model a 256 bit hash and 99 particles a 512 bit hash. {2^256, {57!, 58!}} // N {1.15792*10^77, {4.05269*10^76, 2.35056*10^78}} {2^512, {98!, 99!}} // N {1.34078*10^154, {9.42689*10^153, 9.33262*10^155}} hashes1 = makeHash /@ sP1; Here is a visualization how the hashes evolve with each stir. The coloring is from blue (1) to 100 (red) of the initial particle numbering. ArrayPlot[hashes1, ColorFunction -> ColorData["DarkRainbow"], PlotRange -> {1, 100}] ![enter image description here][41] This is how the edit distance of the hashes increases with successive stirrings. ListPlot[Table[{j, EditDistance[hashes1[[1]], hashes1[[j]]]}, {j, 1, 50}], Filling -> Axis] ![enter image description here][42] Gilpin defines the rearrangement index of a hash as the sum of the absolute difference between neighboring particle indices. rearrangementIndex[indexList_] := Total[Abs[Differences[indexList]]] Here is the growth rate of the rearrangement index for our just-calculated hashes. ListPlot[Table[{j, rearrangementIndex[hashes1[[j]]]}, {j, 1, 50}], Filling -> Axis] ![enter image description here][43] Let's make a second message that has one bit flipped, say at position 10. message2 = MapAt[1 - # &, message1, 10] {1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0} message1 - message2 {0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0} The resulting particle movements look quite different. sP2 = stirringProcess[initialPositionsR, 1/2, 1/10, message2]; Graphics[{LightGray, Disk[], Thickness[0.001], Map[Function[c, {RandomColor[], BSplineCurve[c, SplineDegree -> 5]}], Transpose[N[Table[sP2[[j]], {j, 50}]]]]}] ![enter image description here][44] The edit distances between the two hash sequences increase quickly after the different bit is encountered. hashes2 = makeHash /@ sP2; ListPlot[Table[{j, EditDistance[hashes1[[j]], hashes2[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][45] Gilpin carried out many numerical experiments investigating how the hashes behave as a function of the hash length (number of particles), stirring time T, and message length. The next two examples change only the stirring time, and keep all other parameters: message, stirrer distance, initial particle distance. sP1B = stirringProcess[initialPositionsR, 1/2, 1/9, message1]; hashes1B = makeHash /@ sP1B; ListPlot[Table[{j, EditDistance[hashes1[[j]], hashes1B[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][46] With increasing stirring time, the edit distance between the hashes quickly increases. sP1C = stirringProcess[initialPositionsR, 1/2, 1/2, message1]; hashes1C = makeHash /@ sP1C; ListPlot[Table[{j, EditDistance[hashes1[[j]], hashes1C[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][47] Next, we use the phyllotaxis-like initial position from above with 200 particles. We also use a longer stirring time (T=1). message3 = RandomInteger[{0, 1}, 50] {0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0,1, 0, 1, 0} sP3 = stirringProcess[sunflower[200, 9/10, 250], 1/2, 1, message3]; A plot of the 200 particle trajectories suggests a good mixing. Graphics[{LightGray, Disk[], Thickness[0.001], Map[Function[c, {RandomColor[], BSplineCurve[c, SplineDegree -> 5]}], Transpose[N[Table[sP3[[j]], {j, 50}]]]]}] ![enter image description here][48] Already after the first stir, the edit distance between the original hash and the one resulting after stirring is quite large. hashes3 = makeHash /@ sP3; ListPlot[Table[{j, EditDistance[hashes3[[1]], hashes3[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][49] We will end here. The interested reader can continue to model, stir a million times, count trajectory exchanges, and statistically analyze other aspects of the proposed hashing scheme from Gilpin's paper. PS: And one can compare with theoretical hashing probabilities for ideal hashes. Such as: draw \[ScriptCapitalN]s hashes from M! possible hashes. How many different hashes Subscript[\[ScriptCapitalN], U] does one draw in average? uniqueHashes[M_, \[ScriptCapitalN]s_] := M! (1 - (1 - 1/M!)^\[ScriptCapitalN]s) Plot3D[uniqueHashes[M, \[ScriptCapitalN]s], {M, 1, 60}, {\[ScriptCapitalN]s, 1, 1000}, MeshFunctions -> {#3 &}, PlotPoints -> 100, ScalingFunctions -> "Log", PlotRange -> All, WorkingPrecision -> 50, AxesLabel -> {Style["M", Italic], Style["\[ScriptCapitalN]s", Italic], Style["\!\(\*SubscriptBox[\(\[ScriptCapitalN]\), \(U\)]\)", Italic]}] ![enter image description here][50] For Ns≪M!, this becomes: Series[Mfac (1 - (1 - 1/Mfac)^\[ScriptCapitalN]s), {Mfac, ∞, 2}] /. Mfac -> M! // Simplify ![enter image description here][51] uniqueHashesApprox[M_, \[ScriptCapitalN]s_] := \[ScriptCapitalN]s - (\[ScriptCapitalN]s*(\[ScriptCapitalN]s - 1))/(2*M!) + (\[ScriptCapitalN]s*(\[ScriptCapitalN]s - 1)*(\[ScriptCapitalN]s - 2))/(6*M!^2) Here is a quick numerical modeling with a sample size of 100 from 6!=720 possible hashes. With[{M = 6, \[ScriptCapitalN]s = 100}, {Table[Length[ Tally[RandomChoice[Range[M!], \[ScriptCapitalN]s]]], {10000}] // Mean, uniqueHashes[M, \[ScriptCapitalN]s], uniqueHashesApprox[M, \[ScriptCapitalN]s]}] // N {93.407, 93.4267, 93.4369} I definitely suggest reading the whole paper, including the Supplementary Information. The notebook with all the code and visualizations is attached. [1]: https://www.pnas.org/doi/epdf/10.1073/pnas.1721852115 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-05-02at11.55.34AM.png&userId=20103 [3]: http://www.wgilpin.com/papers/gilpin_pnas_2018.pdf [4]: https://news.stanford.edu/2018/04/23/swirling-liquids-shed-light-bitcoin-works/ [5]: https://btcmanager.com/stanford-university-physicists-uncover-correlation-between-bitcoin-transactions-and-laws-of-nature/ [6]: https://www.cambridge.org/core/journals/journal-of-fluid-mechanics/article/stirring-by-chaotic-advection/7B32CACE61D5AD79077846D7ACF4A31E [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=61661.png&userId=20103 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=82192.png&userId=20103 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=40363.png&userId=20103 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=79744.png&userId=20103 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=59285.png&userId=20103 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10756.png&userId=20103 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=34567.png&userId=20103 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=92028.png&userId=20103 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=19639.png&userId=20103 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=385110.png&userId=20103 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=341511.png&userId=20103 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=891612.png&userId=20103 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=903513.png&userId=20103 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=200714.png&userId=20103 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1069415.png&userId=20103 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=577216.png&userId=20103 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=224217.png&userId=20103 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=435818.png&userId=20103 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=121819.png&userId=20103 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=370620.png&userId=20103 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=949421.png&userId=20103 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=426622.png&userId=20103 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=281923.png&userId=20103 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=365024.png&userId=20103 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=389825.png&userId=20103 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=256626.png&userId=20103 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=218327.png&userId=20103 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=319828.png&userId=20103 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=889929.png&userId=20103 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=995130.png&userId=20103 [37]: http://community.wolfram.com//c/portal/getImageAttachment?filename=30s.png&userId=20103 [38]: http://community.wolfram.com//c/portal/getImageAttachment?filename=639031.png&userId=20103 [39]: http://community.wolfram.com//c/portal/getImageAttachment?filename=469232.png&userId=20103 [40]: http://community.wolfram.com//c/portal/getImageAttachment?filename=123233.png&userId=20103 [41]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1074134.png&userId=20103 [42]: http://community.wolfram.com//c/portal/getImageAttachment?filename=497035.png&userId=20103 [43]: http://community.wolfram.com//c/portal/getImageAttachment?filename=993836.png&userId=20103 [44]: http://community.wolfram.com//c/portal/getImageAttachment?filename=852637.png&userId=20103 [45]: http://community.wolfram.com//c/portal/getImageAttachment?filename=597938.png&userId=20103 [46]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1011739.png&userId=20103 [47]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1005540.png&userId=20103 [48]: http://community.wolfram.com//c/portal/getImageAttachment?filename=132941.png&userId=20103 [49]: http://community.wolfram.com//c/portal/getImageAttachment?filename=625642.png&userId=20103 [50]: http://community.wolfram.com//c/portal/getImageAttachment?filename=879343.png&userId=20103 [51]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1026844.png&userId=20103 Michael Trott 2018-05-02T11:44:45Z https://community.wolfram.com/groups/-/m/t/218587 Hi all, one of my friends shared the following link, which I found interesting to share with you and by the way, ask the community if it is to do something like the machine enigma that is on that page, I hope someone has any idea how to do it. [url=http://enigmaco.de/enigma/enigma.swf]http://enigmaco.de/enigma/enigma.swf[/url] Luis Ledesma 2014-03-13T23:51:00Z https://community.wolfram.com/groups/-/m/t/1121273 *NOTE: Please see the original version of this post [**HERE**][1]. Cross-posted here per suggestion of [Vitaliy Kaurov][2]* *Also note: This post has been reposted verbatim, and as such is rather dated. While I believe that it is still mostly accurate, it does not necessarily fully reflect my current views on the subject matter. In particular, a number of newer internal projects have been using metaprogramming techniques in ways not fully reflected here.* ---------- ##What this answer is and is not To avoid some confusion and misunderstanding, let me state right away what is the intended status of this answer. This answer ***is not*** - A tutorial to the subject - A systematic, or complete, introduction to the subject - An authoritative answer putting the final word on the subject This answer hopefully is - An (subjective!) overview of various meta-programming techniques in Mathematica, *in the way they are known to me*. I want to explicitly state that I am ***not*** trying to convey any kind of the "common wisdom" here, since the answer is largely based on my own experiences, and I have not seen an overwhelming number of meta-programming examples in Mathematica-related resources I had a chance to get acquainted with (so I may have no idea what the common wisdom is :)). - A collection of (hopefully relevant) links with some minimal explanations, which would allow the reader to see some examples and applications of metaprogramming in Mathematica, or at least examples of what I consider meta-programming in Mathematica. - A possible stub for some future answers, so that this larger one could be eventually rewritten and/or split into more focused and narrow ones, as the interest towards some particular forms of metaprogramming in Mathematica is being developed in our community. ##Preamble Ok, let me give it a shot. I'll start by claiming that Mathematica is very well suited for meta-programming, and one can write much more powerful programs in Mathematica by utilizing it. However, while it *allows* for very interesting and powerful meta-programming techniques, it does not IMO provide a convenient layer of tools to make these techniques more standard and effortless. Particularly painful is the evaluation control (preventing pieces of code from premature evaluation), because of the *absence* of the true quotation mechanism (here I will disagree with some other answers), the infinite evaluation model of Mathematica, and a quite complex core evaluator. ##Enumerating some meta-programming techniques There are several forms of meta-programming, so let me give a partial list first, and discuss afterwards - Introspection-based metaprogramming - Reflection-based metaprogramming (like in say, Java) - Run-time code generation - Macros (like in Lisp) - DSL (domain-specific-language) creation - ...? In addition to these, Mathematica has its own meta-programming devices, such as rule-based metaprogramming and the `Block`-related techniques. ##Introspection Mathematica is IMO very strong here. There are a couple of reasons for this: - Homoiconic language (programs written in own data structures - Mathematica expressions. This is code-as-data paradigm, like Lisp which uses lists for this) - One can access global definitions for symbols stored in `OwnValues`, `DownValues`, `SubValues`, `UpVaulues`, etc, and various other global properties, programmatically. - Rule-based destructuring techniques (using `Cases` etc) seriously simplify many introspection-related operations - Mathematica code is "over-transparent" - even pure functions are expressions, available to introspection and destructuring, rather than black boxes. This has its downsides (for example, making a functional abstraction leaky in Mathematica, see the end of [this answer][3]), but it also allows for things like `withGlobalFunctions` macro from [this answer][4], where global function definitions are expanded inside pure functions (that macro also illustrates other meta-programming techniques). ###Automatic dependency tracking I will give a single simple explicit example of what I mean by introspection here, and supply some references to more involved cases. The following line of code gives all the symbols used to build a given expression `expr`, kept unevaluated: Cases[Unevaluated[expr],s_Symbol:>HoldComplete[s],{0,Infinity},Heads->True] Note that this will work for *any* Mathematica expression, including a piece of (perhaps unevaluated) Mathematica code. A good illustration of introspection-based meta-programming is the symbol dependency analysis. I gave it a shot [here][5], where I fully used all of the above-mentioned features (homoiconic language, low-level access to symbol's properties, rule-based destructuring). A simpler but practical application of dependency analysis can be found e.g. in the `getDependencies` function from [this answer][6], where I do use the dependencies to dynamically construct a set of symbols which are encapsulated (not easily available on the top-level) but whose definitions must be saved during the serialization of the list object being constructed. ###Working around some language limitations Sometimes, introspection-based metaprogramming can be also used to go around certain limitations of the language, or to make the language constructs behave in the way you want while minimally affecting them. Some examples off the top of my head: [changing the default behavior of `SaveDefinitions` option for `Manipulate`][7], [making patterns to match only children of certain elements][8], and also two functions from [this answer][9]: a function `casesShielded` which implements a version of `Cases` that shields certain sub-expressions (matching specific pattern) from the pattern-matcher. and a (rather hacky) function `myCases` which implements a modified depth-first search, where the head is inspected before the elements (this is not what is happening in standard `Cases`, which sometimes has unwanted consequences). Yet another example here is the tiny framework I wrote to deal with the leaks of standard lexical scoping mechanism in Mathematica, which can be found [here][10]. ###Summary To conclude this section, I think that introspection-based meta-programming is a very useful and powerful technique in Mathematica, and the one that is relatively easy to implement without engaging in a fight with the system. I am also positive that it is possible to factor out the most useful introspection primitives and have a higher-level introspection-based metaprogramming library, and hope such a library will emerge soon. ##Reflection - based metaprogramming This may probably be considered a subset of the introspection-based metaprogramming, but it is particularly powerful for languages which impose more rigid rules on how code is written, particularly OO languages (Java for example). This uniform and rigid structure (e.g. all code is in classes, etc) allows for automatic querying of, for example, the methods called on the object, etc. Mathematica per se is not particularly powerful here, because "too many ways of doing things" are allowed for this to be effective, but one can surely write frameworks and / or DSLs in Mathematica which would benefit from this meta-programming style. ##Run-time code generation This type of meta-programming can be used relatively easily and brings a lot to the table in Mathematica. ###Automation and adding convenient syntax I will give a small example from [this answer][11], where an ability to generate a pure function (closure) at run-time allows us to easily define a version of SQL `select` with a more friendly Mathematica syntax, and based on the in-memory Mathematica representation of an SQL table as a nested list: ClearAll[select, where]; SetAttributes[where, HoldAll]; select[table : {colNames_List, rows__List}, where[condition_]] := With[{selF = Apply[Function, Hold[condition] /. Dispatch[Thread[colNames -> Thread[Slot[Range[Length[colNames]]]]]]]}, Select[{rows}, selF @@ # &]]; Please see the aforementioned answer for examples of use. Further developments of these ideas (also based on meta-programming) can be found in [this][12] and [this][13] discussions. ###Making JIT-compiled functions, and using `Compile` in more flexible ways An important class of applications of run-time code-generation is in improving the flexibility of `Compile`. A simple example would be to create a JIT-compiled version of `Select`, which would compile `Select` with a custom predicate: ClearAll[selectJIT]; selectJIT[pred_, listType_] := selectJIT[pred, Verbatim[listType]] = Block[{lst}, With[{decl = {Prepend[listType, lst]}}, Compile @@ Hold[decl, Select[lst, pred], CompilationTarget -> "C", RuntimeOptions -> "Speed"]]]; This function actually illustrates several techniques, but let me first show how it is used: test = RandomInteger[{-25, 25}, {10^6, 2}]; selectJIT[#[[2]] > 0 &, {_Integer, 2}][test] // Short // AbsoluteTiming selectJIT[#[[2]] > 0 &, {_Integer, 2}][test] // Short // AbsoluteTiming (* ==> {0.4707032,{{-6,9},{-5,23},{-4,4},{13,3},{-5,7},{19,22},<<489909>>,{11,25},{-6,5}, {-24,1},{-25,18},{9,19},{13,24}}} ==> {0.1250000,{{-6,9},{-5,23},{-4,4},{13,3},{-5,7},{19,22},<<489909>>,{11,25},{-6,5}, {-24,1},{-25,18},{9,19},{13,24}}} *) The second time it was several times faster because the compiled function was memoized. But even including the compilation time, it beats the standard `Select` here: Select[test,#[[2]]>0&]//Short//AbsoluteTiming (* ==> {1.6269531,{{-6,9},{-5,23},{-4,4},{13,3},{-5,7},{19,22},<<489909>>,{11,25},{-6,5}, {-24,1},{-25,18},{9,19},{13,24}}} *) The other techniques illustrated here are the use of constructs like `Compile@@Hold[...]` to fool the variable-renaming scheme (see e.g. [this answer][14] for a detailed explanation), and the use of `With` and replacement rules (pattern-based definitions) as a code-injecting device (this technique is used very commonly). Another example of a very similar nature is [here][15], and yet another, very elegant example is [here][16]. ###Custom assignment operators and automatic generation of function's definitions Another class of run-time code-generation techniques (which is somewhat closer to macros in spirit) is to use custom assignment operators, so that you can generate rather complex or large (possibly boilerplate) code from relatively simple specifications. Applications range from relatively simple cases of adding some convenience/ syntactic sugar, such as e.g. [here][17] (where we define a custom assignment operator to allow us to use option names directly in code), to somewhat more complex cases like making replacements in definitions at the definition-time, as say in the function `lex` from [this answer][18] (see also the code for a `LetL` macro below), to quite sophisticated generation of boilerplate code, happening e.g. in JLink behind the scenes (which, for JLink, is a big deal, because *this* (plus of course the great design of JLink and Java reflection) is the reason why JLink is so much easier to use than Mathlink). ###Automating error-handling and generating boilerplate code Yet another use for run-time code generation (similar to the previous) is to automate error-handling. I discussed one approach to that [here][19], but it does not have to stop there - one can go much further in factoring out (and auto-generating) the boilerplate code from the essential code. ###A digression: one general problem with various meta-programming techniques in Mathematica The problem with this and previous classes of use cases however is the lack of composition: you can not generally define several custom assignment operators and be sure that they will always work correctly in combinations. To do this, one has to write a framework, which would handle composition. While this is possible to do, the development effort can rarely be justified for simple projects. Having a general library for this would be great, provided that this is at all possible. In fact, I will argue that the lack of composibility ("out of the box") is plaguing many potentially great meta-programming techniques in Mathematica, particularly macros. Note that I don't consider this being a fundamental core language-level problem, since the relevant libraries / frameworks can surely be written. I view it more as a consequence of the extreme generality of Mathematica and it being in a transition from a niche scientific language to a general-purpose one (in terms of its typical uses, not just capabilities), so I am sure this problem has a solution and will eventually be solved. ###Proper (macro-like) run-time generation of Mathematica code A final use case for the run-time code generation I want to mention is, well, run-time Mathematica code generation. This is also similar to macros (as they are understood in Lisp) in spirit, in fact probably the closest to them from all techniques I am describing here. One relatively simple example I discuss [here][20], and a similar approach is described [here][21]. A more complex case involving generation of entire packages I used for the real-time cell-based code highlighter described [here][22]. There are also more sophisticated techniques of run-time Mathematica code generation - one of which (in a very oversimplified form) I described [here][23] ###Summary To summarize this section, I view run-time code generation as another meta-programming technique which is absolutely central to make non-trivial things with Mathematica. ##Macros First, what I mean by macros is probably not what is commonly understood by macros in other languages. Specifically, by macro in Mathematica I will mean a construct which: - Manipulates pieces of Mathematica code as data, possibly preventing them from (premature) evaluation - Expands code at run-time (not "read-time" or "compile-time", which are not so well defined in Mathematica) ###Some simple examples Here is the simplest macro I know of, which allows one to avoid introducing an intermediate variable in cases when something must be done after the result has been obtained: SetAttributes[withCodeAfter,HoldRest]; withCodeAfter[before_,after_]:=(after;before) The point here is that the argument `before` is computed before being passed in the body of `withCodeAfter`, therefore evaluating to the result we want, while the code `after` is being passed unevaluated (due to the `HoldRest` attribute), and so is evaluated already inside the body of `withCodeAfter`. Nevertheless, the returned result is the value of `before`, since it stands at the end. Even though the above macro is very simple, it illustrates the power of macros, since this kind of code manipulation requires special support from the language and is not present in many languages. ###Tools used for writing macros The main tools used for writing macros are tools of evaluation control, such as - `Hold*`- attributes, - `Evaluate` and `Unevaluated` - code injection using `With` and / or replacement rules - Pure functions with `Hold` - attributes Even in the simple example above, 2 of these tools were used (`Hold`-attribute and replacement rules, the latter hidden a bit by using global replacement rules / definitions). The discussion of the evaluation control constructs proper is outside the scope of the present discussion but a few places you can look at are [here][24] and [here][25] ###Typical classes of macros Macros can widely range in their purpose. Here are some typical classes - Making new scoping constructs or environments (very typical use case) - Used in combination with run-time code generation to inject some unevaluated code - Used in combination with some dynamic scoping, to execute code in some environments where certain global rules are modified. In this case, the "macro" - part is used to delay the evaluation until the code finds itself in a new environment, so strictly speaking these are rather custom dynamic scoping constructs. ###Examples of new scoping constructs / environments There are plenty of examples of the first type of macros available in the posts on StackOverlflow and here. One of my favorite macros, which I will reproduce here, is the `LetL` macro which allows consecutive bindings for `With` scoping construct: ClearAll[LetL]; SetAttributes[LetL, HoldAll]; LetL /: Verbatim[SetDelayed][lhs_, rhs : HoldPattern[LetL[{__}, _]]] := Block[{With}, Attributes[With] = {HoldAll}; lhs := Evaluate[rhs]]; LetL[{}, expr_] := expr; LetL[{head_}, expr_] := With[{head}, expr]; LetL[{head_, tail__}, expr_] := Block[{With}, Attributes[With] = {HoldAll}; With[{head}, Evaluate[LetL[{tail}, expr]]]]; What it does is to expand a single declaration like `LetL[{a=1,b=a+1,c = a+b},a+b+c]` into a nested `With` at run-time, and it also works for function definitions. I described in more fully [here][26] (where some subtleties associated with it are also described), and used it extensively e.g. [here][27]. A very similar example can be found in [this answer][28]. Yet another example I already mentioned - it is the macro `withGlobalFunctions` from [this answer][29], which expands all generically-defined (via patterns) global functions. The last example I want to include here (although it also is relevant for the third use case) is a macro for performing a code cleanup, discussed [here][30], and I particularly like the version by @WReach, which I will reproduce here: SetAttributes[CleanUp, HoldAll] CleanUp[expr_, cleanup_] := Module[{exprFn, result, abort = False, rethrow = True, seq}, exprFn[] := expr; result = CheckAbort[ Catch[Catch[result = exprFn[]; rethrow = False; result], _, seq[##] &], abort = True]; cleanup; If[abort, Abort[]]; If[rethrow, Throw[result /. seq -> Sequence]]; result] It is not fully "bullet-proof", but does a really good job in the majority of cases. ###Examples of run-time code generation / new functionality Actually, many of the above examples also qualify here. I'll add just one more here (in two variations): the abortable table from [this answer][31] (I will reproduce the final version here): ClearAll[abortableTableAlt]; SetAttributes[abortableTableAlt, HoldAll]; abortableTableAlt[expr_, iter : {_Symbol, __} ..] := Module[{indices, indexedRes, sowTag, depth = Length[Hold[iter]] - 1}, Hold[iter] /. {sym_Symbol, __} :> sym /. Hold[syms__] :> (indices := {syms}); indexedRes = Replace[#, {x_} :> x] &@ Last@Reap[ CheckAbort[Do[Sow[{expr, indices}, sowTag], iter], Null],sowTag]; AbortProtect[ SplitBy[indexedRes, Array[Function[x, #[[2, x]] &], {depth}]][[##,1]] & @@ Table[All, {depth + 1}] ]]; (it accepts the same syntax as `Table`, including the multidimensional case, but returns the partial list of accumulated results in the case of Abort[] - see examples of use in the mentioned answer), and its version for a conditional `Table`, which only adds an element is certain condition is fulfilled - it is described [here][32]. There are of course many other examples in this category. ###Examples of dynamic environments Dynamic environments can be very useful when you want to modify certain global variables or, which is much less trivial, functions, for a particular piece of code, so that the rest of the system remains unaffected. The typical constructs used to achieve this are `Block` and ``Internal`InheritedBlock``. The simplest and most familiar dynamic environment is obtained by changing the values of `$RecursionLimit` and / or `$IterationLimit` inside a `Block`. Some examples of use for these are in [my answer][33] in the discussion of tail call optimization in Mathematica. For a more complex example, see [my suggestion][34] for the recent question on convenient string manipulation. Some more examples can be found in my answer to [this question][35]. An example of application of this to profiling can be found [here][36]. Again, there are many more examples, many of which I probably missed here. ###Problems with writing macros in Mathematica To my mind, the main problems with writing and using macros consistently in Mathematica are these: - Hard to control evaluation. No *real* quotation mechanism (`Hold` and `HoldComplete` don't count because they create extra wrappers, and `Unevaluated` does not count since it is not permanent ans is stripped during the evaluation) - Macros as described above are expanded from outside to inside. Coupled with the lack of *real* quotation mechanism, this leads to the absence of true macro composition out of the box. This composition can be achieved, but with some efforts - The lack of the real compilation stage (The definition-time does not fully count since most definitions are delayed). To circumvent these issues, one has to apply various techniques, such as - [Trott - Strzebonski in-place evaluation technique][37] to evaluate parts of held expressions in-place (see also [this answer][38] for some more details on that) - A technique which I call (for the lack of a better name) "inverse rule-dressing", which exploits the properties of delayed rule substitution (delayed, plus intrusive), to inject some unevaluated code. I used it in the first solution in [this answer][39], in more complex way in the `SavePointers` function in [this answer][40], and in a number of other cases. It has also been used very elegantly in [this answer][41]. - using a custom `Hold`-like wrapper which is first mapped on (possibly all) parts of an expression, and later removed using rules. Two examples of this techniques are [here][42] and [here][43] - ... Despite all these techniques being useful, and in total covering most of the needs for macro-writing, the need to use them (often in combinations) and the resulting code complexity shows, to my mind, the serious need for a generic library which would provide simpler means for macro-writing. I would prefer to be able to nest macros and not think about zillion of things that may go wrong because of some unwanted evaluation, but rather about things that really matter (such as variable captures). ###Summary Macros are another very powerful meta-programming technique. While it *is* possible to write them in Mathematica, it is, as of now, a rather involved undertaking, and composing macros is an even harder task. Because composition in the key, I attribute the fact that macros are not in widespread use in Mathematica programming, to this lack of composition, plus the complexity of writing individual macros. That said, I think this is a very promising direction, and hope that some time soon we will have the tools which would make writing macros a more simple and automatic process. ##DSL creation I won't say almost anything here, except noting that this is entirely possible in Mathematica, and some nice syntax can be added easily via `UpValues`. ##Final remarks I think that meta-programming is one of the most important and promising directions in the present and future of Mathematica programming. It is also rather complex, and IMO, largely unexplored in Mathematica still. I hope that this justifies this post being so long. I tried to summarize various approaches to meta-programming in Mathematica, which I am aware of, and give references to examples of these approaches, so that the reader can look for him/herself. Since meta-programming is a complex topic, I did not attempt to write a tutorial, but rather tried to summarize various experiences of myself and others to produce a kind of a reference. One may notice that the references are dominated by the code I wrote. One reason for that is that I am a heavy user of meta-programming in Mathematica. Another reason is that everyone remembers own code the most. I have to apologize for not including some other references which did not come to my mind right away. I invite everyone to edit this post and add more references, which I missed. [1]: https://mathematica.stackexchange.com/a/2352/81 [2]: http://community.wolfram.com/web/vitaliyk [3]: https://stackoverflow.com/questions/4430998/mathematica-what-is-symbolic-programming/4435720#4435720 [4]: https://mathematica.stackexchange.com/questions/704/functions-vs-patterns/746#746 [5]: https://stackoverflow.com/questions/8867757/has-anyone-written-any-function-to-automatically-build-a-dependency-graph-of-an/8869545#8869545 [6]: https://mathematica.stackexchange.com/questions/36/file-backed-lists-variables-for-handling-large-data/209#209 [7]: https://stackoverflow.com/questions/6579644/savedefinitions-considered-dangerous/6580284#6580284 [8]: https://stackoverflow.com/questions/6451802/pattern-to-match-only-children-of-certain-elements/6453673#6453673 [9]: https://stackoverflow.com/questions/8700934/why-is-cases-so-slow-here-are-there-any-tricks-to-speed-it-up/8701756#8701756 [10]: https://gist.github.com/1683497 [11]: https://stackoverflow.com/questions/4787901/data-table-manipulation-in-mathematica/4788373#4788373 [12]: https://stackoverflow.com/questions/8240943/data-table-manipulation-in-mathematica-step-2 [13]: https://stackoverflow.com/questions/6130276/conditionnal-data-manipulation-in-mathematica [14]: https://stackoverflow.com/questions/6236458/plot-using-with-versus-plot-using-block-mathematica/6236808#6236808 [15]: https://stackoverflow.com/questions/4973424/in-mathematica-how-do-i-compile-the-function-outer-for-an-arbitrary-number-of/4973603#4973603 [16]: https://stackoverflow.com/questions/8204784/how-to-compile-a-function-that-computes-the-hessian/8210224#8210224 [17]: https://stackoverflow.com/questions/4682742/optional-named-arguments-without-wrapping-them-all-in-optionvalue/4683924#4683924 [18]: https://mathematica.stackexchange.com/questions/1602/resource-management-in-mathematica/1603#1603 [19]: https://stackoverflow.com/questions/6560116/best-practices-in-error-reporting-mathematica/6563886#6563886 [20]: https://stackoverflow.com/questions/6214946/how-to-dynamically-generate-mathematica-code/6215394#6215394 [21]: https://stackoverflow.com/questions/8741671/unevaluated-form-of-ai/8742627#8742627 [22]: https://mathematica.stackexchange.com/questions/1315/customizing-syntax-highlighting-for-private-cell-styles/1320#1320 [23]: https://stackoverflow.com/questions/8741671/unevaluated-form-of-ai/8746584#8746584 [24]: https://stackoverflow.com/questions/4856177/preventing-evaluation-of-mathematica-expressions [25]: https://stackoverflow.com/questions/1616592/mathematica-unevaluated-vs-defer-vs-hold-vs-holdform-vs-holdallcomplete-vs-etc [26]: https://stackoverflow.com/questions/5866016/question-on-condition/5869885#5869885 [27]: https://mathematica.stackexchange.com/questions/36/file-backed-lists-variables-for-handling-large-data/209#209 [28]: https://stackoverflow.com/questions/8373526/error-generating-localized-variables-as-constants/8377522#8377522 [29]: https://mathematica.stackexchange.com/questions/704/functions-vs-patterns/746#746 [30]: https://stackoverflow.com/questions/3365794/reliable-clean-up-in-mathematica [31]: https://stackoverflow.com/questions/6470625/mathematica-table-function/6471024#6471024 [32]: https://stackoverflow.com/questions/6367932/generate-a-list-in-mathematica-with-a-conditional-tested-for-each-element/6368770#6368770 [33]: https://stackoverflow.com/questions/4481301/tail-call-optimization-in-mathematica/4627671#4627671 [34]: https://mathematica.stackexchange.com/questions/344/convenient-string-manipulation/377#377 [35]: https://mathematica.stackexchange.com/questions/1162/alternative-to-overloading-set [36]: https://mathematica.stackexchange.com/questions/1786/workbench-profile-question/1798#1798 [37]: http://library.wolfram.com/conferences/devconf99/villegas/UnevaluatedExpressions/Links/index_lnk_30.html [38]: https://stackoverflow.com/questions/6633236/replace-inside-held-expression/6633334#6633334 [39]: https://stackoverflow.com/questions/6234701/how-to-block-symbols-without-evaluating-them/6236264#6236264 [40]: https://stackoverflow.com/questions/6579644/savedefinitions-considered-dangerous/6580284#6580284 [41]: https://mathematica.stackexchange.com/questions/1929/injecting-a-sequence-of-expressions-into-a-held-expression/1937#1937 [42]: https://stackoverflow.com/questions/5747742/uses-for-mapall/5749275#5749275 [43]: https://mathematica.stackexchange.com/questions/2137/truncate-treeform-to-show-only-the-top/2139#2139 Leonid Shifrin 2017-06-16T12:08:12Z https://community.wolfram.com/groups/-/m/t/1250668 This is a call for some feedback on a small utility function I am trying to design. A few times I felt the need in a continuous partitioning of space. Could you please, after reading the post, give me some feedback on: - What other **applications** this function can be used for? (Especially higher-dimensional cases) - Do you have a better **design** suggestions? # Definition The SpacePartition function is a continuous analog of [Partition][1]. It subdivides n-dimensional space into integer number of partitions. The result is a tensor of hyper-blocks spanning the hyperspace without gaps or overlaps. It means currently, and for simplicity of the demo, there are no block offsets, but they could be added in the future. SpacePartition[space_List, partitions_List] := Outer[List, ##, 1] & @@ MapThread[Partition[Subdivide @@ Append[#1, #2], 2, 1] &, {space, partitions}] #1D Examples Subdividing 1D interval {2.3,5.7} into 5 consecutive intervals: part1D = SpacePartition[{{2.3, 5.7}}, {5}] > {{{2.3, 2.98}}, {{2.98, 3.66}}, {{3.66, 4.34}}, {{4.34, 5.02}}, {{5.02, 5.7}}} NumberLinePlot[Interval @@@ part1D] ![enter image description here][2] # 2D Examples Subdividing 2D rectangle into different number of partitions along different dimensions part2D = SpacePartition[{{2.3, 5.7}, {1.2, 3.4}}, {7, 5}]; and visualizing as a grid Graphics[grid2D = {FaceForm[], EdgeForm[Black], Rectangle @@ Transpose[#]} & /@ Flatten[part2D, 1], Frame -> True] ![enter image description here][3] Subdivisions preserve the neighborhood structure Graphics[{grid2D, {Opacity[.5], Rectangle @@ Transpose[#]} & /@ (part2D[[##]] & @@@ Tuples[{1, 2, 3}, 2])}, Frame -> True] ![enter image description here][4] # 3D Examples Subdividing 3D rectangle into different number of partitions along different dimensions part3D = SpacePartition[{{2.3, 5.7}, {1.2, 3.4}, {-1.1, 2}}, {7, 5, 4}]; and visualizing as a 3D grid Graphics3D[{Opacity[.6], Cuboid @@ Transpose[#]} & /@ Flatten[part3D, 2], Axes -> True] ![enter image description here][5] Selecting random subsets of subdivisions as Region: Table[Show[Region[Cuboid @@ Transpose[#]] & /@ RandomSample[Flatten[part3D, 2], 20], Axes -> True, Boxed -> True],3] ![enter image description here][6] # Application: quarterly temperatures or partitioning PlotRange Often data are so dense it is hard to distinguish details in a standard plot. data = WeatherData["KMDZ", "Temperature", {{2015}}]; plot = DateListPlot[data] ![enter image description here][7] SpacePartition can be used to partition PlotRange and make a better visual With[{pr = PlotRange /. Options[plot]}, DateListPlot[TimeSeriesWindow[data, #], AspectRatio -> 1/10, ImageSize -> 1000, PlotRange -> {Automatic, {-30, 30}}, Filling -> Axis, PlotTheme -> "Detailed"] & /@ Map[DateList, Flatten[SpacePartition[{pr[[1]]}, {4}], 1], {2}]] // Column ![enter image description here][8] # Application: box-counting method for fractal measures Define an iterated function system (IFS) and iterate it on point sets IFS[{T__TransformationFunction}][pl_List] := Join @@ Through[{T}[pl]] IFSNest[f_IFS, pts_, n_Integer] := Nest[f, pts, n] Sierpi?ski gasket transformation: SierpinskiGasket = With[{\[ScriptCapitalD] = DiagonalMatrix[{1, 1}/2]}, IFS[{AffineTransform[{\[ScriptCapitalD]}], AffineTransform[{\[ScriptCapitalD], {1/2, 0}}], AffineTransform[{\[ScriptCapitalD], {0.25, 0.433}}]}]]; and corresponding iterated point set ptsSierp = IFSNest[N@SierpinskiGasket, RandomReal[1, {100, 2}], 4]; graSierp = Graphics[{PointSize[Tiny], Point[ptsSierp]}, Frame -> True] ![enter image description here][9] Function that makes partitions blocks[n_]:=Rectangle@@Transpose[#]&/@Flatten[N@SpacePartition[{{0,1},{0,1}},{n,n}],1] Show[graSierp,Graphics[{FaceForm[],EdgeForm[Red],blocks[7]}]] ![enter image description here][10] Of course number of partitions grows as a square for 2D case Length /@ blocks /@ Range[9] > {1, 4, 9, 16, 25, 36, 49, 64, 81} Function counting partitions that have any points in them blockCount[pts_, n_] := Length[Select[blocks[n], MemberQ[RegionMember[#, pts], True] &]] Accumulating data of partition count for different partition sizes logMes = ParallelTable[Log@{k, blockCount[ptsSierp, k]}, {k, 20}]; Fitting the log-log scale of the data linearly with the slope measuring fractal dimension fit[x] = Fit[logMes, {1, x}, x] > 0.0884774 + 1.70962 x which deviates a bit from ideal due to probably random inexact nature of IFS system N[Log[3]/Log[2]] > 1.58496 Plot[fit[x], {x, 0, 3.5}, Epilog -> {Red, PointSize[.02], Point[logMes]}] ![enter image description here][11] # Missing features The following features could be added in future: - Offset parameter for overlapping or gapped partitions - Real (non-integer) number of partitions [1]: http://reference.wolfram.com/language/ref/Partition.html [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=34q5wtreyhrgfeaw.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trtr54y5tr.png&userId=11733 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=rtyjtey5764w3q.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ehrfcxxvdasr5.png&userId=11733 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gsdfgdert5433.png&userId=11733 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ldkr43t8vad.png&userId=11733 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=45ytrwew4534yhrgfer.png&userId=11733 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=jy5674w5tq3243.png&userId=11733 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=534tyhtrer4t54thrgef.png&userId=11733 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=34t4hwrge.png&userId=11733 Vitaliy Kaurov 2017-12-20T00:36:24Z https://community.wolfram.com/groups/-/m/t/935450 Hierarchical edge bundling is an interesting graph visualization technique that can make community structure evident in a network. The D3 JavaScript library implements it and you can see a very nice interactive demo here: http://bl.ocks.org/mbostock/7607999  How does it work? Can Mathematica do this? Can we implement this from scratch in Mathematica? I will show how to do this step by step below. This is a repost of [an article I shared on Mathematica.SE yesterday][1], which in turn is based on a presentation I gave at the Wolfram seminars in Lyon and Grenoble on the preceding two days. At the end you will find a small package that wraps everything up into an easy to use function. But be warned: there is little to no error checking and it will be too slow for graphs bigger than a couple of hundred nodes. There are probably better ways to implement some of the steps, so all feedback is welcome! ---- Before we get started, I want to note that it turns out that Mathematica does include an implementation of this layout. It can be used like this: SetProperty[ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}], GraphLayout -> {"EdgeLayout" -> "HierarchicalEdgeBundling"}]  This is not exactly the usual syntax for the `GraphLayout` option, and is not clearly described in the documentation (it really should be for such a cool visualization!!), so I though it's good to share it. More info here: http://mathematica.stackexchange.com/a/127995/12 It is still interesting to implement the layout on our own. Not only can we learn about the method, we will also gain the flexibility to tweak it and gain completely different interesting outputs, e.g. a linear node arrangement instead of a circular one. ---- Below I am going to show how to implement hierarchical edge bundling from scratch. I hope that people will find this useful both from an educational point of view and to be able to customize the layout to their taste. On the way we are going to get a little help from [the IGraph/M package][2], the [igraph][3] interface for Mathematica. IGraph/M was in turn made possible by the [LTemplate](http://community.wolfram.com/groups/-/m/t/575100). ## How does the layout work? This type of layout is useful because it makes the community structure in the graph evident. It is based on [hierarchical community detection][4]. A detailed description can be found in [Y Jia, M Garland, JC Hart: Hierarchial edge bundles for general graphs](http://graphics.cs.illinois.edu/sites/default/files/edgebundles.pdf). I will admit that I didn't actually read this paper. I only looked at the figures for inspiration. After all I am doing this for fun, not for a perfect result. However, if you want to get deeper into the topic, it is probably a good idea to read it. The first reason why we need IGraph/M is that we are going to need to use a dendrogram output by some hierarchical community detection algorithm. IGraph/M has several such functions: <<IGraphM` [![enter image description here][5]][5] All these functions return an `IGClusterData` object. We can then query several `"Properties"` of such an object. As an example, let us analyse the following network: g = ExampleData[{"NetworkGraph", "DolphinSocialNetwork"}] [![enter image description here][6]][6] This is a social network between dolphins. Like most social networks, it has a relatively clear community structure. cl = IGCommunitiesEdgeBetweenness[g] [![enter image description here][7]][7] Running the edge betweenness based (Girvan-Newman) community detection algorithm on it yields 5 communities. Note that we could also get this using the builtin `FindGraphCommunities[..., Method -> "Centrality"]`, however, this function doesn't give us the full dendrogram. Notice in the above screenshot of the `IGClusterData` object that it says: "Hierarchical: True". Not all algorithms included in igraph will produce a hierarchical structure, but this one does. We can visualize the dendrogram like this: << HierarchicalClustering` DendrogramPlot[cl["HierarchicalClusters"], LeafLabels -> (Rotate[#, Pi/2] &)] [![enter image description here][8]][8] <sup>Note: In IGraph/M 0.3.0 (not released as of this writing), it will be possible to plot the dendrogram using `Dendrogram[cl["Tree"]]`. [`Dendrogram`](http://reference.wolfram.com/language/ref/Dendrogram.html) is new in M10.4.</sup> Other clustering algorithms in IGraph/M that can produce a dendrogram are Walktrap and Greedy, both being faster than EdgeBetweenness. We can also obtain this dendrogram as a clustering tree, i.e. a `Graph` object. tree = cl["Tree"] [![enter image description here][9]][9] **So how does hierarchical edge bundling work?** Instead of layout out the graph `g`, it constructs a version of the clustering tree and lays it out radially. The leaves correspond to the nodes of the original graph `g`. Then it uses this tree as a skeleton to route the edges of `g` between its nodes. The following figure from the paper gives an reasonably clear idea: [![enter image description here][10]][10] Let's go ahead then an implement this in Mathematica. ## Implementing the layout As a first step, we must simplify the clustering tree by identifying the subtrees corresponding to each cluster, and collapsing them into a single node, with all members of the community connecting directly to it. Using a radial visualization of the tree, the graph on the left is what the algorithm gave us, and the one on the right is what we can use as a practical skeleton: [![enter image description here][11]][11] First of all, we must identify the root of the tree. Since this is a *binary tree*, we can just take the single node with degree 2. Leaves will have degree 1 and intermediate nodes will have degree 3. root = First@Pick[VertexList[tree], VertexDegree[tree], 2] (* 123 *) Let us also get rid of the vertex labels and put back the nodes into the visualization, so we can see better what we are doing: tree = SetProperty[RemoveProperty[tree, VertexLabels], VertexShapeFunction -> "Circle"] [![enter image description here][12]][12] The clustering tree has integers as its nodes. We are going to need to forward and reverse mapping between the leaves of this tree and the graph g. map = AssociationThread[Range@VertexCount[g], VertexList[g]]; revmap = Association[Reverse /@ Normal[map]]; <sup>Note: In IGraph/M 0.3.0 (not released as of this writing) it will be possible to simply use `map = PropertyValue[tree, "LeafLabels"];`</sup> Now we group the leaves of the clustering tree based on which community they belong to. Note the use of Lookup and Map instead of ReplaceAll to prevent unpredictable replacements, especially in cases when some graph nodes are lists themselves. communities = Lookup[revmap, #] & /@ cl["Communities"] (* {{1, 3, 11, 29, 31, 43, 48}, {2, 6, 7, 8, 10, 14, 18, 20, 23, 26, 27, 28, 32, 33, 40, 42, 49, 55, 57, 58, 61}, {4, 9, 13, 15, 17, 21, 34, 35, 37, 38, 39, 41, 44, 45, 47, 50, 51, 53, 59, 60}, {5, 12, 16, 19, 22, 24, 25, 30, 36, 46, 52, 56}, {54, 62}} *) To extract the subtree of a community, we make use of the fact that in an (undirected) tree there is precisely one path between any two nodes. Mapping enough paths to connect any two leaves will give us the subtree. Clear[subtree] subtree[tree_, {el_}] := {el} subtree[tree_, community_] := Union @@ (First@FindPath[UndirectedGraph[tree], ##] &) @@@ Partition[community, 2, 1] HighlightGraph[tree, subtree[tree, #] & /@ communities, GraphHighlightStyle -> "DehighlightFade"] [![enter image description here][13]][13] The root of a subtree is the node that appears first in the breadth-first ordering. Alternatively we could look for the only degree-2 node in the subtree, but let's use BFS here. We can create is using [`BreadthFirtScan`](http://reference.wolfram.com/language/ref/BreadthFirtScan.html). ord = First@Last@Reap[ BreadthFirstScan[tree, root, {"PrevisitVertex" -> Sow}]; ]; For those not familiar with what breadth-first ordering is, the following animation will be educational. Nodes are visited in the order of their distance from the starting point—in this case from the tree root. Animate[ HighlightGraph[ SetProperty[RemoveProperty[tree, VertexLabels], VertexShapeFunction -> "Circle"], Take[ord, k] ], {k, 1, VertexCount[tree], 1} ] [![enter image description here][14]][14] So let's get the roots of the subtrees: posIndex = First /@ PositionIndex[ord]; subtreeRoots = First@MinimalBy[subtree[tree, #], posIndex] & /@ communities (* {101, 119, 118, 112, 63} *) HighlightGraph[tree, subtreeRoots, GraphHighlightStyle -> "Thick"] [![enter image description here][15]][15] New let's extract the tree which has these vertices as its leaves: rootTree = Subgraph[tree, VertexInComponent[tree, subtreeRoots], GraphLayout -> "LayeredDigraphEmbedding"] [![enter image description here][16]][16] Notice that this is not going to make a useful skeleton because the different leaves have different distances from the root. Let us augment it with intermediate nodes to force all leaves to the same distance. A better method would not modify the tree—it would modify how the tree is embedded in space instead. But I am lazy so I will just do the augmentation here. I will use the symbolic wrapper `a` to generate names for the new nodes. (* renaming the community roots will make things easier for cases where we have single-node communities *) rootTree = VertexReplace[rootTree, Thread[subtreeRoots -> (a[#][0]&) /@ subtreeRoots]]; subtreeRoots = (a[#][0]&) /@ subtreeRoots; dist = AssociationMap[GraphDistance[rootTree, root, #] &, subtreeRoots]; maxd = Max[dist]; augmentedRootTree = Graph[ GraphUnion[ rootTree, GraphUnion @@ Table[ PathGraph[ Prepend[Head[node] /@ Range[maxd - dist[node]], node], DirectedEdges -> True ], {node, subtreeRoots} ] ], GraphLayout -> "LayeredDigraphEmbedding" ] [![enter image description here][17]][17] This is what we need. Now we just need to "hang" all nodes of `g` on the leaves of this tree. Let's extract the leaves in the same order as the communities: rootTreeLeaves = MapThread[Head[#1][#2] &, {subtreeRoots, Values[maxd - dist]}]; augmentedTree = SetProperty[ GraphUnion[ augmentedRootTree, GraphUnion @@ MapThread[Thread[#1 -> #2] &, {rootTreeLeaves, communities}] ], GraphLayout -> {"RadialDrawing", "RootVertex" -> root} ] [![enter image description here][18]][18] This is the tree we can use as a skeleton. But if we use the built-in radial tree visualization, then the leaves are not equispaced on a circle. Thus we employ the help of IGraph/M again and use its implementation of the Reingold-Tilford algorithm: skeleton = IGLayoutReingoldTilfordCircular[augmentedTree, "RootVertices" -> {root}] [![enter image description here][19]][19] We want to route the edges of `g` guided by the paths between them in the clustering tree, e.g. spf = FindShortestPath[UndirectedGraph@augmentedTree, All, All]; HighlightGraph[ IGLayoutReingoldTilfordCircular[UndirectedGraph[augmentedTree], "RootVertices" -> {root}], Part[PathGraph /@ spf @@@ Map[revmap, EdgeList[g], {2}], 9], GraphHighlightStyle -> "Thick"] [![enter image description here][20]][20] One simple way to do this is to use a `BSplineCurve`, with the intermediate points in the clustering tree as control points. But this will result in a very tight bundling of edges. To counter this, we can create new control points by interpolating between the original ones and a straight line going through the end vertices. The following function will do this: Clear[smoothen] smoothen[curve_, v_] := Module[{s = First[curve], t = Last[curve], line}, line = Table[s + (t - s) u, {u, 0, 1, 1/(Length[curve] - 1)}]; v line + (1 - v) curve ] This function constructs the B splines: Clear[plotGraph] plotGraph[augmentedTree_, g_, v_: 0, sz_: 0.02] := Module[{pts, paths, spf}, spf = FindShortestPath[UndirectedGraph@augmentedTree, All, All]; pts = GraphEmbedding[augmentedTree]; paths = spf @@@ Map[revmap, EdgeList[g], {2}]; Graphics[ { { Opacity[0.5], ColorData["Legacy"]["RoyalBlue"], Table[ With[ {curve = PropertyValue[{augmentedTree, #}, VertexCoordinates] & /@ path}, BSplineCurve[smoothen[curve, v], SplineDegree -> Length[curve] - 1] ], {path, paths} ] }, { PointSize[sz], Black, Point[PropertyValue[{augmentedTree, #}, VertexCoordinates]] & /@ Range@VertexCount[g] } } ] ] Now let's take our skeleton and apply the visualization: plotGraph[skeleton, g, 0.1] [![enter image description here][21]][21] It's interesting to use a `Manipulate` to control the tightness of the edge bundling: Manipulate[plotGraph[skeleton, g, v], {v, 0, 1}] [![enter image description here][22]][22] Now with everything in place, we can try to use other skeletons as well. Using a standard top-to-bottom tree visualization the vertices are placed on a line: skeleton = SetProperty[augmentedTree, GraphLayout -> "LayeredDigraphEmbedding"]; Show[ plotGraph[skeleton, g, 0.2, 0.01], AspectRatio -> 1/3 ] [![enter image description here][23]][23] How about a Kamada–Kawai type layout for the tree? skeleton = IGLayoutKamadaKawai[augmentedTree]; plotGraph[skeleton, g, 0.1] [![enter image description here][24]][24] With a bit more work we can also make this dynamic with clickable vertex labels, like in the example at http://bl.ocks.org/mbostock/7607999 The code is after the break. [![enter image description here][25]][25] I hope you enjoyed this little demo. I apologize for the messy code and for not packaging this up into a single function. I might do that on a better day when I have more time. Any feedback is welcome. ---- ## Code for Dynamic version v = 0.15; paths = spf @@@ Map[revmap, EdgeList[g], {2}]; With[{augmentedTree = IGLayoutReingoldTilfordCircular[augmentedTree, "RootVertices" -> {root}]}, DynamicModule[{flags = AssociationThread[Range@VertexCount[g], ConstantArray[False, VertexCount[g]]]}, Graphics[ { { Opacity[0.5], ColorData["Legacy"]["RoyalBlue"], Table[ With[{curve = PropertyValue[{augmentedTree, #}, VertexCoordinates] & /@ path}, BSplineCurve[smoothen[curve, v], SplineDegree -> Length[curve] - 1] ], {path, paths} ], Table[ With[{curve = PropertyValue[{augmentedTree, #}, VertexCoordinates] & /@ path, f = First[path], l = Last[path]}, Dynamic@ Style[#, If[flags[f] || flags[l], Directive[Thickness[0.007], Red, Opacity[1]], Opacity[0]]] &@ BSplineCurve[smoothen[curve, v], SplineDegree -> Length[curve] - 1] ], {path, paths} ] }, { PointSize[0.02], With[{pt = PropertyValue[{augmentedTree, #}, VertexCoordinates], offset = 1.05}, EventHandler[ {Dynamic[If[flags[#], Red, Black]], Rotate[Text[VertexList[g][[#]], offset pt, {-Sign@First[pt], 0}], If[First[pt] < 0, Pi, 0] + ArcTan @@ pt, offset pt], Point[pt] }, {"MouseClicked" :> (flags[#] = ! flags[#])} ] ] & /@ Range@VertexCount[g] } }, ImageSize -> Large ] ] ] ---- ## Package This is a small package containing the above functionality. To get started, simply apply HEBPlot to a *connected* graph which is not too large. Check `Options[HEBPlot]` for more control over the output. Warning: This is a rudimentary package with limited options and very little error checking. Example: HEBPlot[ExampleData[{"NetworkGraph", "JazzMusicians"}], "CommunityDetectionFunction" -> IGCommunitiesGreedy, EdgeStyle -> Directive[Opacity[0.2], RGBColor[0.254906, 0.411802, 0.882397]], VertexSize -> 0.01] [![enter image description here][26]][26] BeginPackage["HierarchicalEdgeBundling`", {"IGraphM`"}]; HEBSkeleton::usage = "HEBSkeleton[clusterData] constructs a skeleton usable for hierarhical edge bundling. The argument must be an IGClusterData object."; HEBEmbedSkeleton::usage = "HEBEmbedSkeleton[tree, layout] lays out a skeleton tree using \"Circular\" or \"Linear\" layouts."; HEBLayout::usage = "HEBLayout[graph, tree] visualizes graph based on a precomputed skeleton tree."; HEBPlot::usage = "HEBPlot[graph] visualizes graph using hierarchical edge bundling."; Begin["`Private`"]; a; (* symbol for naming vertices augmenting the skeleton tree *) subtree[tree_, {el_}] := {el} subtree[tree_, community_?ListQ] := Union @@ (First@FindPath[UndirectedGraph[tree], ##]&) @@@ Partition[community, 2, 1] HEBSkeleton::nohr = "The cluster data does not contain hierarchical information."; HEBSkeleton[cl_IGClusterData] := Module[{tree, root, ord, revmap, communities, posIndex, subtreeRoots, rootTree, dist, maxd, augmentedRootTree, rootTreeLeaves}, If[Not@MemberQ[cl["Properties"], "Merges"], Return@Failure["NotHierarchical", <|"MessageTemplate" -> HEBSkeleton::nohr|>] ]; tree = cl["Tree"]; root = First@Pick[VertexList[tree], VertexDegree[tree], 2]; ord = First@Last@Reap[BreadthFirstScan[tree, root, {"PrevisitVertex"->Sow}];]; revmap = AssociationThread[cl["Elements"], Range@cl["ElementCount"]]; communities = Lookup[revmap, #]& /@ cl["Communities"]; posIndex = First /@ PositionIndex[ord]; subtreeRoots = First@MinimalBy[subtree[tree,#], posIndex]& /@ communities; rootTree = Subgraph[tree, VertexInComponent[tree, subtreeRoots]]; rootTree = VertexReplace[rootTree, Thread[subtreeRoots -> (a[#][0]&) /@ subtreeRoots]]; subtreeRoots = (a[#][0]&) /@ subtreeRoots; dist = AssociationMap[GraphDistance[rootTree, root, #]&, subtreeRoots]; maxd = Max[dist]; augmentedRootTree = Graph[ GraphUnion[ rootTree, GraphUnion @@ Table[ PathGraph[ Prepend[Head[node] /@ Range[maxd-dist[node]], node], DirectedEdges->True ], {node, subtreeRoots} ] ] ]; rootTreeLeaves = MapThread[Head[#1][#2]&, {subtreeRoots, Values[maxd-dist]}]; GraphUnion[ augmentedRootTree, GraphUnion@@MapThread[Thread[#1->#2]&, {rootTreeLeaves,communities}] ] ] HEBEmbedSkeleton[tree_?TreeGraphQ, layout_String : "Circular"] := Switch[layout, "Circular", IGLayoutReingoldTilfordCircular[tree, "RootVertices" -> Pick[VertexList[tree], VertexInDegree[tree], 0]], "Linear", SetProperty[tree, GraphLayout -> "LayeredDigraphEmbedding"] ] smoothen[curve_,v_]:= Module[{s = First[curve], t = Last[curve], line}, line = Table[s+(t-s)u,{u,0,1,1/(Length[curve]-1)}]; v line+(1-v) curve ] Options[HEBLayout] = { "BundleTightness" -> 0.1, VertexSize -> 0.02, VertexStyle -> Black, EdgeStyle -> Directive[Opacity[0.5], ColorData["Legacy"]["RoyalBlue"]] }; HEBLayout[g_?GraphQ, tree_?TreeGraphQ, opt : OptionsPattern[]] := Module[{paths, spf, v = OptionValue["BundleTightness"], revmap}, spf = FindShortestPath[UndirectedGraph[tree], All, All]; revmap = AssociationThread[VertexList[g], Range@VertexCount[g]]; paths = spf@@@Map[revmap, EdgeList[g], {2}]; Graphics[ { { OptionValue[EdgeStyle], Table[ With[ {curve=PropertyValue[{tree, #}, VertexCoordinates]&/@path}, BSplineCurve[smoothen[curve,v], SplineDegree -> Length[curve]-1] ], {path,paths} ] }, { PointSize@OptionValue[VertexSize], OptionValue[VertexStyle], Point[PropertyValue[{tree, #},VertexCoordinates]]&/@Range@VertexCount[g] } } ] ] Options[HEBPlot] = Options[HEBLayout] ~Join~ {"Layout" -> "Circular", "CommunityDetectionFunction" -> IGCommunitiesEdgeBetweenness}; HEBPlot[g_?ConnectedGraphQ, opt : OptionsPattern[]] := Module[{cl, skeleton}, cl = OptionValue["CommunityDetectionFunction"][g]; skeleton = HEBSkeleton[cl]; skeleton = HEBEmbedSkeleton[skeleton, OptionValue["Layout"]]; HEBLayout[g, skeleton, FilterRules[{opt}, Keys@Options[HEBLayout]]] ] End[]; EndPackage[]; [1]: http://mathematica.stackexchange.com/q/55367/12 [2]: https://github.com/szhorvat/IGraphM [3]: http://igraph.org/ [4]: https://en.wikipedia.org/wiki/Community_structure [5]: http://i.stack.imgur.com/vdM9C.png [6]: http://i.stack.imgur.com/rwRWH.png [7]: http://i.stack.imgur.com/WcEXQ.png [8]: http://i.stack.imgur.com/kmZx9.png [9]: http://i.stack.imgur.com/2PyDH.png [10]: http://i.stack.imgur.com/Qb28C.png [11]: http://i.stack.imgur.com/ywHw8.png [12]: http://i.stack.imgur.com/CdcZS.png [13]: http://i.stack.imgur.com/CcB1g.png [14]: http://i.stack.imgur.com/SBfFK.gif [15]: http://i.stack.imgur.com/6IbzH.png [16]: http://i.stack.imgur.com/IhqWp.png [17]: http://i.stack.imgur.com/KIOAn.png [18]: http://i.stack.imgur.com/x4h7N.png [19]: http://i.stack.imgur.com/ZPlaw.png [20]: http://i.stack.imgur.com/yBWMi.png [21]: http://i.stack.imgur.com/5Gyn7.png [22]: http://i.stack.imgur.com/hC5Ng.gif [23]: http://i.stack.imgur.com/5GbSe.png [24]: http://i.stack.imgur.com/h4SHo.png [25]: http://i.stack.imgur.com/yzhYK.png [26]: http://i.stack.imgur.com/e9v8k.png Szabolcs Horvát 2016-10-06T19:52:24Z https://community.wolfram.com/groups/-/m/t/550504 ![Look familiar...?][1] When last did you solve a quadratic equation by hand? Probably not since school, I'm guessing. It's an open secret that maths education is way behind the times, failing to equip kids with skills they need in the real world. As a Wolfram Community member, you may well have come across the [Computer-Based Maths initiative][2], driven by Conrad Wolfram. For those who don't know, it's a programme designed to bring coding and computers into school maths curricula worldwide, using Wolfram technology. And now the CBM team wants *your* ideas ahead of the fourth [CBM Summit in London on 19-20 November][3]. We already have Jaak Aaviksoo, Simon Peyton Jones and Raspberry Pi's Eben Upton, who [spoke at the last CBM Summit][4] in 2013. Now we'd like to hear from you... - Who would *you* like to hear speaking on this subject? - Do you have something you'd like to present yourself? - What are the most important topics that should be covered? Think about your country and your workplace too: - Are there thought leaders, education revolutionaries or forward-thinking math education projects the CBM team should know about? I'm looking forward to your comments...and maybe see you in London! [![CBM Summit, London, 19-20 November][5]][6] [1]: /c/portal/getImageAttachment?filename=_thumb_117376.png&userId=383623 [2]: https://www.computerbasedmath.org/ [3]: http://www.computerbasedmath.org/events/maths-education-summit-2015/ [4]: https://www.youtube.com/watch?v=NZvttwpeVrc&list=PLzKFBYmW-UKpLGkkprg5LkHUVPaCV85R1&index=35 [5]: /c/portal/getImageAttachment?filename=SummitFooterFullSize.jpg&userId=383623 [6]: http://www.computerbasedmath.org/events/maths-education-summit-2015/ Richard Asher 2015-08-20T15:52:37Z https://community.wolfram.com/groups/-/m/t/2030201 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/e9934595-75e0-42eb-92bc-ae38528364a7 [Original]: https://www.wolframcloud.com/obj/ss8659/Published/WSS20-Level-Index-Arithmetic-5.nb Swastik Banerjee 2020-07-14T17:07:16Z https://community.wolfram.com/groups/-/m/t/3241848 ![Retrieval augmented generation (RAG) with Wolfram Language][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2024MainImage.png&userId=20103 [2]: https://www.wolframcloud.com/obj/14c589e5-b550-4534-abda-a0ea80da3e3f Kotaro Okazaki 2024-08-06T01:55:33Z https://community.wolfram.com/groups/-/m/t/1419096 I was working on a library for my simulations. The difficult part was the shape of its input and output requires sophisticated UI. So after few days of manipulation with `Manipulate` I switched back to C++/Qt based UI and Mathematica for computation. So I was working on a C++ library to interact with Mathematica using WSTP API. It is usable but, not yet complete, however nothing is ever complete. I named it [`mathematica++`][1] and released it under FreeBSD License. it is hosted in gitlab. [gitlab project page][2]. I don't want to bloat this post, These are some of the examples copy pasted from the above links symbol x("x"); value res; std::string method = "Newton"; shell << Values(FindRoot(ArcTan(1000 * Cos(x)), List(x, 1, 2), Rule("Method") = method)); shell >> res; std::vector<double> results = cast<std::vector<double>>(res); std::cout << results[0] << std::endl; // Prints 10.9956 Example 2 mathematica::m mata = Table(Mod(i + j, 2), List(i, 1, 2), List(j, 1, 2)); mathematica::m matb = Table(Mod(i + j, 3), List(i, 1, 2), List(j, 1, 2)]; mathematica::m matc = Dot(mata, matb); mathematica::m matd = Det(matc); // Execute mathematica constructs and fetch the response shell << matd; shell >> determinant; // determinant can be converted to C++ machine sized types std::cout << determinant << std::endl; // Prints -2 `cast<T>` brings the output returned by mathematica to STL containers value result; typedef std::vector<std::vector<int>> ivv_type; shell << FactorInteger(2434500); shell >> result; ivv_type prime_powers = mathematica::cast<ivv_type>(result); for(auto pp: prime_powers){ std::cout << pp[0] << " ^ " << pp[1] << std::endl; } // Prints the following output // 2 ^ 2 // 3 ^ 2 // 5 ^ 3 // 541 ^ 1 Not limited to `std::vector` only Thank You. [1]: http://neelex.com/mathematica++ [2]: https://gitlab.com/neel.basu/mathematicapp Neel Basu 2018-08-22T12:09:39Z https://community.wolfram.com/groups/-/m/t/1066381 ![enter image description here][1] Below is an implementation of the German Enigma Machine which the German forces used to communicate encrypted messages during WWII. The machine was an ingenious design. It used a series of rotors and an elaborate electromechanical coupling to encrypt messages in German. About the mechanism, the first rotor moved with each click of the keyboard; the second rotor moved once the first rotor completed 26 moves or one complete turn; and the third rotor once the first moved 26*26 steps (one can easily understand where this is going). Since the rotors could move during the encryption process the key to deciphering the text was the "key" or the initial state of the rotors. The code was finally broken by a team of cryptographers at Bletchley Park led by Alan Turing. Some believe this caused the war to shorten by a few years. A movie titled "The Imitation Game" was released in 2014 highlighting this code breaking feat. ClearAll@rotateWheel; SetAttributes[rotateWheel, HoldFirst]; rotateWheel[wheel_] := Block[{}, wheel = RotateLeft[wheel]]; The immediate block of code above enables me to make in-place modification i.e. to rotate and preserve the state of the rotors. EnigmaEncryption[string_, staterot1_, staterot2_, staterot3_] := Module[{count = 0, RotorIn, leftRotor, middleRotor, rightRotor, reflector, reflectorOutput, rotateMiddleCheck, rotateRightCheck, inputToNext, reverseOutput}, RotorIn = ToLowerCase@CharacterRange["A", "Z"]; {leftRotor, middleRotor, rightRotor} = MapThread[Function[{x, y}, (z \[Function] RotateLeft[z, First@Position[z, ToLowerCase@y] - 1])@ Characters@ToLowerCase[x]], {{"BDFHJLCPRTXVZNYEIWGAKMUSQO", "AJDKSIRUXBLHWTMCQGZNPYFVOE", "EKMFLGDQVZNTOWYHXUSPAIBRCJ"}, {staterot1, staterot2, staterot3}}]; reflector = Characters@ToLowerCase@"YRUHQSLDPXNGOKMIEBFZCWVJAT"; inputToNext[rotor_, input_] := First@Cases[Thread[{RotorIn, rotor}], {input, map_} :> map ]; reverseOutput[rotor_, input_] := First@Cases[Thread[{RotorIn, rotor}], {map_, input} :> map ]; rotateMiddleCheck := If[count~Mod~26 == 0, rotateWheel@middleRotor, middleRotor]; rotateRightCheck := If[count~Mod~676 == 0, rotateWheel@rightRotor, rightRotor]; StringJoin@Table[ If[FreeQ[input, Alternatives[" ", ",", "'", "?" ]], count += 1; reflectorOutput = Fold[inputToNext[#2, #1] &, input, {rotateWheel@leftRotor, rotateMiddleCheck, rotateRightCheck, reflector}]; Fold[reverseOutput[#2, #1] &, reflectorOutput, {rightRotor, middleRotor, leftRotor}], input] , {input, Characters@ToLowerCase@string}] ] Now lets assume that the Germans encrypt a message with state "A", "A","A" for the three moving rotors: Style[text = EnigmaEncryption["this is the SS, Identify yourself, are you a German or are you Alan Turing?", "A", "A", "A"], {Bold, FontSize -> 24}] **uubf jw dif oo, jctjgmbn nbtqrang, pvs vsh o orgiya lq lyw svn ssui zcxuxs?** If the cryptographers at Bletchley have the incorrect key "B","A","E" they will not be able to decipher the text (it will be gibberish). Style[EnigmaEncryption[text, "B", "A", "E"], {Bold, FontSize -> 24}] **pgyy yd gnu nw, etlisxnw fnkniizh, tgy wde u gqkabx ma foe alc aifb cmavmt?** However, with the right key: Style[EnigmaEncryption[text, "A", "A", "A"], {Bold, FontSize -> 24}] **this is the ss, identify yourself, are you a german or are you alan turing?** We can make a small animation of the rotor states. For visual purposes, blue represents the forward states of the system and red the backward state. ![enter image description here][1] the code below can be used to generate the animation sequence: list = (Rasterize@*Grid /@ Module[{out, states, mergedstates, rotorstates, riffle, first, last, text = text, textout = StringReplace[text[[1]], Alternatives[" ", ",", "'", "?"] :> ""]}, out = Characters@textout; states = Partition[text[[2, 1]], 7]; mergedstates = Table[Join[states[[i]], {out[[i]]}], {i, Length@states}]; rotorstates = text[[2, 2]]; riffle = MapAt[Reverse, (Partition[#, 4] & /@ mergedstates), {All, 2}]; riffle = Apply[Composition[Partition[#, 2] &, Riffle], riffle, {1}]; Do[{first, last} = Flatten@Position[rotorstates[[j, i]], #] & /@ riffle[[j, i]]; rotorstates[[j, i, first]] = Style[First@rotorstates[[j, i, first]], {Blue, Bold, Background -> LightBlue}]; rotorstates[[j, i, last]] = Style[First@rotorstates[[j, i, last]], {Red, Bold, Background -> LightRed}]; , {j, Length@riffle}, {i, 4}]; rotorstates ]); [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1479animate.gif&userId=942204 Ali Hashmi 2017-04-20T02:10:34Z https://community.wolfram.com/groups/-/m/t/2416125 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/a5d46446-4ecd-4c49-9f10-57561e3961a5 Mohammad Bahrami 2021-11-30T17:22:04Z https://community.wolfram.com/groups/-/m/t/1109273 This sample program is developed to show the power of [Mathematica OOP][1] as shown in other my OOP projects. It is well known that the double pendulum motion becomes a chaos with time development. Also, in the time development of a pendulum, we can observe another kind of chaos caused by the initial condition. A very small fluctuation of the initial condition affect the time development deeply. In this program case, angle perturbation less than 10^-12 can have an effect on the time development. To observe this phenomenon this program traces simultaneously a several tens of double pendulums each has random initial angle difference. The pendulums are represented by the instance constructed from the OOP Lagrange equation of motion class. The Mathematica OOP can represent these number of double pendulums motion in time development with a simple and an effective way. ![50 pendulums in time development][2] Setup for global parameters and OOP class {g = 9.8, m = 1, r1 = 1, r2 = 0.5, time = 50}; case[nam_] := Module[{\[Theta]1, \[Theta]2, ans, T1, T2, V1, V2, t, L, lkeq, initcond}, initialize[nam[th1_, th2_]] ^:= ( (* Lagrangian setup *) T1 = 1/2 m*r1^2*\[Theta]1'[t]^2; V1 = -m*g*r1*Cos[\[Theta]1[t]]; T2 = 1/2 m*(r1^2*\[Theta]1'[t]^2 + r2^2*\[Theta]2'[t]^2 + 2 r1*r2*\[Theta]1'[t]*\[Theta]2'[t]*r1*r2* Cos[\[Theta]1[t] - \[Theta]2[t]]); V2 = -m*g*(r1*Cos[\[Theta]1[t]] + r2*Cos[\[Theta]2[t]]); L = T1 + T2 - (V1 + V2); (* Lagrange equation of motion *) lkeq = {D[D[L, \[Theta]1'[t]], t] - D[L, \[Theta]1[t]] == 0, D[D[L, \[Theta]2'[t]], t] - D[L, \[Theta]2[t]] == 0}; initcond = { \[Theta]1[0] == th1, \[Theta]2[0] == th2, \[Theta]1'[0] == 0, \[Theta]2'[0] == 0}; (* Numerical solve of equation *) ans = NDSolve[{lkeq, initcond}, {\[Theta]1, \[Theta]2}, {t, 0, time}, MaxSteps -> Infinity, PrecisionGoal -> \[Infinity]][[ 1]]; ); pendulum[nam[tr_]] ^:= ( (* Pendulum graphics return *) Graphics[{Line[{{0, 0}, {r1*Sin[\[Theta]1[tr]], -r1*Cos[\[Theta]1[tr]]} /. ans}], Line[{{r1*Sin[\[Theta]1[tr]], -r1* Cos[\[Theta]1[tr]]}, {(r1*Sin[\[Theta]1[tr]] + r2*Sin[\[Theta]2[tr]]), (-r1*Cos[\[Theta]1[tr]] - r2*Cos[\[Theta]2[tr]])}} /. ans]}, PlotRange -> {{-1.8, 1.8}, {-1.8, 1.8}}] ) ]; Setup initial conditions and construct instances, and display of results {pendulums = 50, angle1 = 4 Pi/3, angle2 = 4 Pi/3, butterfly = 10^-12}; objectList = Table[Unique[], {pendulums}]; Map[case[#] &, objectList]; Map[initialize[#[angle1, angle2 + butterfly*RandomReal[{-1, 1}]]] &, objectList]; Animate[Show[ Map[pendulum[#[tr]] &, objectList] ], {tr, 0, time}, AnimationRepetitions -> 1, AnimationRate -> 1] Enjoy a sudden divergence. [1]: http://community.wolfram.com/groups/-/m/t/897081?p_p_auth=tO31eCls [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2302d-pendulum.jpg&userId=897049 Hirokazu Kobayashi 2017-05-28T01:05:18Z https://community.wolfram.com/groups/-/m/t/1378496 Theory of Games has an impressive development during the last 70 years both as a domain of applied mathematics and a part of various important domains of human activity. It's somewhat strange that Mathematica doesn't include any functionality related to game theory. Our project intends to initiate a game theory Mathematica package. At the first initiation stage of the project development, we consider strategic finite (multi-matrix) games and some solution concepts: Nash equilibrium, Stackelberg equilibrium, and MaxMin strategies: Game statement ------------------------------------- A strategic game is defined by the tuple: $$\Gamma = \langle N, \{X_i\}_{i\in N}, \{f_i (x)\}_{i\in N}\rangle,$$ where $N=\{1,2,...,n\}$ is a set of players, $X_i$ is a set of strategies of player $i\in N$ and $f_i:X\rightarrow R$ is a player's $i\in N$ payoff function defined on the Cartesian product $X = \times_{i \in N} X_i$. Elements of $X$ are called outcomes of the game (strategy profiles). An outcome $x^*\in X$ of is a Nash equilibrium (shortly NE) of $\Gamma$ if $$f_i ( x_i, x_{-i}^*) \le f_i ( x^*_i, x_{-i}^* ), \forall x_i \in X_i,\,\, \forall i \in N,$$ where $$x_{-i}^* = (x^*_1, x^*_2, ..., x^*_{i-1}, x^*_{i+1}, ..., x^*_n),$$ $$x_{-i}^* \in X_{-i}=X_1 \times X_2 \times ... \times X_{i-1} \times X_{i+1} \times ... \times X_n,$$ $$(x_i,x_{-i}^*) = (x^*_1, x^*_2, ..., x^*_{i-1},x_i, x^*_{i+1}, ..., x^*_n)\in X.$$ We study Nash equilibrium sets as an intersection of best response mapping graphs [5,1, 2], i.e. the intersection of the sets: $$Gr_i=\{(x_i,x_{-i})\in X: x_{-i}\in X_{-i}, x_i\in {\rm Arg}\max_{x_i\in X_i} f_i(x_i,x_{-i})\},\,\, i\in N.$$ Theorem 1. The outcome $x^*\in X$ is a Nash equilibrium if and only if $x^*\in \bigcap_{i \in N}Gr_i$. Theorem 1 stands for a main method that we will use to find Nash equilibrium set. So, we are looking to finding Nash equilibrium sets as the intersection of best response mapping graphs, both in pure and mixed strategy games. Package design ------------------------------------- We have designed package structure and features that have to be applied to all its functions, their titles and options. Main functions of the package a `GameTheory[]` and `GameTheoryPlot[]`. There is an idea to recall them `GameSolve[]` and `GameSolvePlot[]`. Formal parameters of the functions are initial data of the games, as well all the concepts that specifies a concrete game theory problem: testOptionValue["Criteria" -> crit, {"Maximize", "Minimize"}]; testOptionValue["Strategy" -> type, {"Pure", "Mixed"}]; testOptionValue["Concept" -> concept, {"NashEquilibrium", "MaxMin", "StackelbergEquilibrium"}] We have created algorithms and corresponding codes that solve problems of Nash equilibrium set finding, as well as MaxMin solutions computing. In this context we need to mention the following functions: pureNashEquilibria[matr_] := ... maxMin[matr_] :=... pureStackelbergEquilibria[matr_] :=... We have also programmed the code that solves two-matrix mixed strategy games. mixedNashEquilibria[m_] := ... The package includes, withal, a function that plot Nash equilibrium set in $2\times 2$ mixed strategy games. game2x2Plot[m_]:= ... Some private functions and their application ------------------------------------- For the problem of Nash equilibrium set computing the main function is: bestResponse[m_]:=With[{ind=indexSets[Dimensions[m[[1]]]]}, Intersection@@Table[ Flatten[ Thread/@Table[ Replace[i, All:>maxPositions@m[[player,Sequence@@i]], {1}], {i, Tuples[ind[[player]]]} ], 1 ], {player, Length[m]} ] ] The notation `m` is for payoff matrices of the players. `Length[m]` gives the number of players. `Tuples[]` gives all possible tuples formed by player strategies. `maxPositions[]` gives positions on which maximal values are obtained. The intersection of all `Length[m]` lists of players offers the set of Nash equilibria. In practice, this function is called by `GameTheory[]` as in the following examples: In[1]:= Clear[a, b] a = {{2, 2, 3}, {7, 2, 2}, {1, 1, 4}}; b = {{5, 6, 1}, {5, 2, 3}, {3, 5, 7}}; MatrixForm /@ {a, b}; In[2]:= GameTheory[{a, b}, Method -> {"Criteria" -> "Maximize", "Concept" -> "NashEquilibrium", "Strategy" -> "Pure"}] Out[2]= {<|"Player 1" -> 1, "Player 2" -> 2|> -> {2, 6}, <|"Player 1" -> 2, "Player 2" -> 1|> -> {7, 5}, <|"Player 1" -> 3, "Player 2" -> 3|> -> {4, 7}} Another private function is: (* ------ MaxMin strategies ------ *) maxMin[matr_]:=Module[{dim=Dimensions[matr[[1]]], min, ind, tuples, payoffTuples},(*matr\[LeftDoubleBracket]1\[RightDoubleBracket] has the same dimensions as all other m\[LeftDoubleBracket]2\[RightDoubleBracket],...,m\[LeftDoubleBracket]n\[RightDoubleBracket]*) Table[ min=Table[0,dim[[player]]]; Do[ ind=Table[Range[dim[[j]]],{j,Length[matr]}]; (* list of strategy sets *) ind[[player]]={str}; (* strategy set of the player is set simply formed by one element: {str} *) tuples=Tuples[ind]; (* generate the tuples *) payoffTuples=Table[matr[[player,Sequence@@t]],{t,tuples}]; (* the variable player gives the matrix of the player; other indeces give the payoff value *) min[[str]]=Min[payoffTuples], (* for every player *) {str,dim[[player]]} ]; "Player "<>ToString[player] -> <|"Strategy"->maxPositions[min],"Payoff"->min[[maxPositions[min]]][[1]]|>, {player,Length[matr]} ] ] It is used to compute MaxMin strategies. This concept is more simple in comparison with the Nash equilibrium. It needs finding for every fixed strategy of the player the worst response of the other players. After knowing all such worst responses, every player computes the best from them, that being the MaxMin strategy. The following example illustrates how the function is applied really for the same above matrices: In[3]:= GameTheory[{a, b}, Method -> {"Criteria" -> "Maximize", "Concept" -> "MaxMin", "Strategy" -> "Pure"}] Out[3]= {"Player 1" -> <|"Strategy" -> {1, 2}, "Payoff" -> 2|>, "Player 2" -> <|"Strategy" -> {1}, "Payoff" -> 3|>} Sure, the function solves the above problems for an arbitrary number of players: ------------------------------------------------------------------ 5 player game --------------------------------------------------------------- In[4]:= Clear[a, b, c, d, e] a = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; b = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; c = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; d = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; e = RandomInteger[{-10, 1000}, {5, 5, 5, 5, 5}]; MatrixForm /@ {a, b, c, d, e}; In[5]:= GameTheory[{a, b, c, d, e}, Method -> {"Criteria" -> "Maximize", "Concept" -> "MaxMin", "Strategy" -> "Pure"}] Out[5]= {"Player 1" -> <|"Strategy" -> {5}, "Payoff" -> -7|>, "Player 2" -> <|"Strategy" -> {1, 5}, "Payoff" -> -7|>, "Player 3" -> <|"Strategy" -> {2}, "Payoff" -> -7|>, "Player 4" -> <|"Strategy" -> {4}, "Payoff" -> -8|>, "Player 5" -> <|"Strategy" -> {3}, "Payoff" -> -8|>} In[6]:= GameTheory[{a, b, c, d, e}, Method -> {"Criteria" -> "Maximize", "Concept" -> "NashEquilibrium", "Strategy" -> "Pure"}] Out[6]= {<|"Player 1" -> 1, "Player 2" -> 1, "Player 3" -> 2, "Player 4" -> 2, "Player 5" -> 4|> -> {807, 935, 772, 829, 986}, <|"Player 1" -> 3, "Player 2" -> 1, "Player 3" -> 5, "Player 4" -> 5, "Player 5" -> 3|> -> {824, 939, 621, 776, 874}} It is important to remark here that not all pure strategy games have Nash equilibria. But, all mixed-strategy games have Nash equilibria. Next private function solve the problem of Nash equilibrium set finding in two-matrix mixed-strategy games: mixedNashEquilibria[m_]:=With[{a=m[[1]],b=m[[2]]}, NESet={}; Do[ \[DoubleStruckCapitalU]=Range[i+1,Dimensions[a][[1]]]; Do[ Do[ If[X[b,i,j,\[DoubleStruckCapitalI],{}]==0,Break,Continue]; \[DoubleStruckCapitalV]=Range[j+1,Dimensions[a][[2]]]; Do[ If[Y[a,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]]!=0&&X[b,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]]!=0, NESet=AppendTo[NESet,{XOut[b,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]],YOut[a,i,j,\[DoubleStruckCapitalI],\[DoubleStruckCapitalJ]]}], Break ], {\[DoubleStruckCapitalJ],Subsets[\[DoubleStruckCapitalV]]} ], {j,Dimensions[a][[2]]} ], {\[DoubleStruckCapitalI],Subsets[\[DoubleStruckCapitalU]]} ], {i,Dimensions[a][[1]]} ]; DeleteDuplicates@NESet ] The intersection method used for two-matrix mixed strategy games is described in details in [2]. Next, we illustrate its working out in the above form codding: Clear[a, b] a = {{2, 2, 3}, {7, 2, 2}, {1, 1, 4}}; b = {{5, 6, 1}, {5, 2, 3}, {3, 5, 7}}; MatrixForm /@ {a, b}; ![enter image description here][1] For some strategic games it is possible to present graphically the set of Nash equilibria [6]. All the code is very large, so we present here only on function used to manipulate all graphics objects appearing in the final image: game2x2Plot[m_]:=Module[{matr=m}, {{{\[DoubleStruckA]11,\[DoubleStruckA]12},{\[DoubleStruckA]21,\[DoubleStruckA]22}},{{\[DoubleStruckB]11,\[DoubleStruckB]12},{\[DoubleStruckB]21,\[DoubleStruckB]22}}}=matr; Manipulate[ Grid[{{Graphics[{Thick, Blue,g1[a11-a12-a21+a22,a12-a22], Green,g2[b11-b12-b21+b22,b21-b22], Red,PointSize[Large],nes[a11-a12-a21+a22,a12-a22,b11-b12-b21+b22,b21-b22]}, PlotRange->{{0,1},{0,1}},Axes->True,AxesLabel->{"\!\(\*SubscriptBox[\(x\), \(1\)]\)","\!\(\*SubscriptBox[\(y\), \(1\)]\)"}, ImageSize->{300,300}]},{" "},{Text@Style["Reference Nash Equilibria",Bold]}, {Text@Style[nes[a11-a12-a21+a22,a12-a22,b11-b12-b21+b22,b21-b22][[1,1]],Bold]}},ItemSize->{Automatic,{10,1,1,3}},Alignment->{Center,Top} ], Style["Matrix A",Bold], {{a11,\[DoubleStruckA]11,"\!\(\*SubscriptBox[\(a\), \(11\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, {{a12,\[DoubleStruckA]12,"\!\(\*SubscriptBox[\(a\), \(12\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, {{a21,\[DoubleStruckA]21,"\!\(\*SubscriptBox[\(a\), \(21\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, {{a22,\[DoubleStruckA]22,"\!\(\*SubscriptBox[\(a\), \(22\)]\)"},-10,10,1,Appearance-> "Labeled",ImageSize->Tiny}, Delimiter,{{NonAntagonistic,True, "NonAntagonistic"},{True,False}}, Delimiter,Style["Matrix B",Bold], {{b11,\[DoubleStruckB]11,"\!\(\*SubscriptBox[\(b\), \(11\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, {{b12,\[DoubleStruckB]12,"\!\(\*SubscriptBox[\(b\), \(12\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, {{b21,\[DoubleStruckB]21,"\!\(\*SubscriptBox[\(b\), \(21\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, {{b22,\[DoubleStruckB]22,"\!\(\*SubscriptBox[\(b\), \(22\)]\)"},-10,10,1,Enabled->NonAntagonistic,Appearance-> "Labeled",ImageSize->Tiny}, Delimiter, Style["Matrices A and B",Bold], Dynamic[ TableForm[ {{ToString[a11]<>" , "<>ToString[If[NonAntagonistic,b11,b11=-a11]], ToString[a12]<>" , "<>ToString[If[NonAntagonistic,b12,b12=-a12]]}, {ToString[a21]<>" , "<>ToString[If[NonAntagonistic,b21,b21=-a21]], ToString[a22]<>" , "<>ToString[If[NonAntagonistic,b22,b22=-a22]]}}, TableHeadings->{{"1","2"},{" 1"," 2"}}, TableSpacing->{2,2} ] ], SaveDefinitions->True ] ] In practice, the function is used at it follows: Clear[a, b] a = {{5, 3}, {7, 2}}; b = {{3, 6}, {5, 3}}; MatrixForm /@ {a, b}; GameTheoryPlot[{a, b}] ![enter image description here][2] Conclusions ------------------------------------- We have passed only a first pre-initial state of the package construction. There is a lot of things that must be done to establish a successful game theory package. We can only emphasised here some other stages. So, we intend to develop the package in several successive stages and directions: 1. At the first initiation stage we plan to enlarge the number of strategic form game theory problems solved by the package, and to include more plotting possibilities. 2. At the second stage we intend to develop package functionality in order to solve extensive form games, and to include their abundant plotting functionality. 3. At the third stage, we are considering adding support for cooperative games. 4. At the fourth stage, we plan to consider differential games and control. 5. Next stages will include multi-criteria mixtures of simultaneous and sequential games, as well as a lot of applied problems from all the human activity. Bibliography ----------- 1. [Ungureanu, Valeriu, Nash equilibria set computing in finite extended games, CSJM, 2006, Vol. 14, No. 3 (42), pp. 345-365.][3] 2. [Ungureanu, Valeriu, "Pareto-Nash-Stackelberg Game and Control Theory", Springer International Publishing, 2018, XXI + 343 pp.][4] 3. [Ungureanu, Valeriu, Nash equilibrium set function in dyadic mixed-strategy games, CSJM v .25, n .1 (73), 2017.][5] 4. [Nash J.F., Noncooperative game, Annals of Mathematics, 54, 1951, pp. 280-295.][6] 5. Sagaidac, M., and Ungureanu, V., Operational research, Chi\sinau, CEP USM, 2004, 296 p. (in Romanian) 6. [Ungureanu, V., Nash Equilibrium Sets in Dyadic Bimatrix Mixed-Strategy Games,][7] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=TwoMatrixMixedStrategyGame.png&userId=159033 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=game2x2Image.png&userId=159033 [3]: http://www.math.md/files/csjm/v14-n3/v14-n3-%28pp345-365%29.pdf [4]: https://www.springer.com/gp/book/9783319751504 [5]: http://www.math.md/files/csjm/v25-n1/v25-n1-%28pp3-20%29.pdf [6]: https://www.jstor.org/stable/1969529?seq=1#page_scan_tab_contents [7]: http://community.wolfram.com/groups/-/m/t/892544?p_p_auth=LiMRfo3d Valeriu Ungureanu 2018-07-11T16:36:01Z https://community.wolfram.com/groups/-/m/t/1112012 [Shadow mapping][1] is a process of applying shadows to a computer graphic. `Graphics3D` allows the user to specify lighting conditions for the surfaces of 3D graphical primitives, however, visualising the shadow an object projects onto a surface requires the processes of shadow mapping. Each pixel of the projection surface must check if it is visible from the light source; if this check returns false then the pixel forms a shadow. This becomes a problem of geometric intersections, i.e., for this case, the intersection between a line and a triangle. For a 3D model with 100s and more of polygons, repeated intersection tests across the entire model for each pixel is an extremely costly (and inefficient) task. Now this becomes a problem of search optimisation. ![enter image description here][2] Obtaining Data -------------- This project uses 3D models from [SketchUp's online repository][3] which are converted to COLLADA files using SketchUp. The functions used are held in a package, accessible via [github][4] along with all the data referenced throughout. (* load package and 3D model *) << "https://raw.githubusercontent.com/b-goodman/\ GeometricIntersections3D/master/GeometricIntersections3D.wl"; modelPath = "https://raw.githubusercontent.com/b-goodman/\ GeometricIntersections3D/master/Demo/House/houseModel4.dae"; (* vertices of model's polygons *) polyPoints = Delete[0]@Import[modelPath, "PolygonObjects"]; (* import model as region *) modelRegion = Import[modelPath, "MeshRegion"]; (* use region to generate minimal bounding volume *) cuboidPartition = Delete[0]@BoundingRegion[modelRegion, "MinCuboid"]; (* verify *) Graphics3D[{ Polygon[polyPoints], {Hue[0, 0, 0, 0], EdgeForm[Black], Cuboid[cuboidPartition]} }, Boxed -> False] ![imported model data][5] Generate a Bounding Volume Hierarchy (BVH) ------------------------------------------ Shadow mapping (and more generally collision testing) may be optimised via space partitioning achieved by dividing the 3D model's space into a hierarchy of bounding volumes (BV) stored as a graph, thus forming a [bounding volume hierarchy][6]. The simplest case uses the result of an intersection between a ray and a single BV for the entire model to discard all rays which don't come close to any of the model's polygons. Of course, those which do pass the first test must still be tested against the entire model so the initial BV is subdivided with each sub BV assigned to a particular part of the model hence reducing the total amount of polygons to be tested against. The initial BV forms the root of the tree and it's subdivisions (leaf boxes) are joined via edges. We can add more levels to the tree by repeating the subdivision for each of the leaf boxes and ultimately refining the search for potential intersecting polygons. (* Begin tree. Initial AABB is root. Subdivide root AABB and link returns to root *) newBVH[cuboidPartitions_,polyPoints_]:=Block[{ newLevel,edges }, newLevel=Quiet[cullIntersectingPartitions[cuboidSubdivide[cuboidPartitions],polyPoints]]; edges=cuboidPartitions\[DirectedEdge]#&/@newLevel; Return[<| "Tree"->TreeGraph[edges], "PolygonObjects"->polyPoints |>]; ]; bvh = newBVH[{cuboidPartition}, polyPoints]; The BVH is a tree graph with the model's polygon vertices encapsulated within an association Keys[bvh] {"Tree", "PolygonObjects"} The BVH consists of a root box derived from the model's minimal bounding volume and it's 8 sub-divisions bvh["Tree"] ![enter image description here][7] The boxes at the lowest level of the BVH are the leaf boxes leafBoxesLV1 = Select[VertexList[bvh["Tree"]], VertexOutDegree[bvh["Tree"], #] == 0 &]; Graphics3D[{ Polygon[polyPoints], {Hue[0, 0, 0, 0], EdgeForm[Black], Cuboid /@ leafBoxesLV1} }, Boxed -> False] ![enter image description here][8] Adding a new level sub-divides each leaf box into 8 sub-divisions. With[{ testCuboid = {{0, 0, 0}, {10, 10, 10}} }, Manipulate[ Graphics3D[{ If[n == 0, Cuboid[testCuboid], Cuboid /@ Nest[cuboidSubdivide, testCuboid, n]] }, Boxed -> False, Axes -> {True, False}], {{n, 0}, 0, 4, 1} ] ] ![enter image description here][9] The time needed for each addition to the BVH increases dramatically. Length /@ NestList[cuboidSubdivide, {{{0, 0, 0}, {1, 1, 1}}}, 5] {1, 8, 64, 512, 4096, 32768} 1-2 added levels is usually enough for the models used in this project. (* Each new subdivision acts as root. For each, subdivide further and remove any non-intersecting boxes. Link back to parent box as directed edge *) addLevelBVH[BVH_]:=Block[{ tree=BVH["Tree"],polyPoints=BVH["PolygonObjects"],returnEdges }, Module[{ subEdges=Map[ Function[{levelComponent},levelComponent\[DirectedEdge]#&/@Quiet@cullIntersectingPartitions[cuboidSubdivide[levelComponent],polyPoints]], Pick[VertexList[tree],VertexOutDegree[tree],0]] }, returnEdges=ConstantArray[0,Length[subEdges]]; Do[returnEdges[[i]]=EdgeAdd[tree,subEdges[[i]]],{i,1,Length[subEdges],1}]; ]; returnEdges=DeleteDuplicates[Flatten[Join[EdgeList/@returnEdges]]]; Return[<| "Tree"->TreeGraph[returnEdges], "PolygonObjects"->polyPoints |>] ]; bvh2 = addLevelBVH[bvh]; bvh2["Tree"] ![enter image description here][10] Any subs which don't intersect with the model don't contribute to the BVH and so are removed as part of the process. cullIntersectingPartitions=Compile[{ {cuboidPartitions,_Real,3}, {polyPoints,_Real,3} }, Select[cuboidPartitions,Function[{partitions},MemberQ[ParallelMap[Quiet@intersectTriangleBox[partitions,#]&,polyPoints],True]]], CompilationTarget->"C" ]; Visualising the leaf boxes shows that empty BVs are removed. leafBoxesLV2 = Select[VertexList[bvh2["Tree"]], VertexOutDegree[bvh2["Tree"], #] == 0 &]; Graphics3D[{ Polygon[polyPoints], {Hue[0, 0, 0, 0], EdgeForm[Black], Cuboid /@ leafBoxesLV2} }, Boxed -> False] ![enter image description here][11] Once all levels are added, the BVH is finalised by linking each leaf box to its associated polygons. This does not effect the tree structure as the link association is held seperate. (*For each outermost subdivision (leaf box), find intersecting polygons. Link to intersecting box via directed edge. Append to graph *) finalizeBVH[BVH_]:=Block[{ (* all leaf boxes for BVH *) leafBoxes=Select[ VertexList[BVH["Tree"]], VertexOutDegree[BVH["Tree"],#]==0& ], (* setup temp association *) temp=<||>, (* block varaibles *) leafPolygons, leafPolygonsEdges }, (* For each BVH leaf box *) Do[ (* 3.1. intersecitng polygons for specified BVH leaf box *) leafPolygons=Select[ BVH["PolygonObjects"], Quiet@intersectTriangleBox[leafBoxes[[i]],#]==True& ]; (* 3.2. associate each specified BVH leaf box to its intersecting polygon(s) *) AppendTo[temp,leafBoxes[[i]]->leafPolygons], {i,1,Length[leafBoxes],1} ]; Return[<| "Tree"->BVH["Tree"], "LeafObjects"->temp, "PolygonObjects"->BVH["PolygonObjects"] |>] ]; bvh2 = finalizeBVH[bvh2]; While it only needs doing once, generating the BVH is often the longest part of the procedure so it's a good idea to export it on completion. Generating The Scene -------------------- The scene is an encapsulation of all data and parameters used for the ray caster. It's initially structured as: scene=<| "BVH"->BVHobj, -- (*The BVH previously generated*) "SourcePositions"->lightingPath, -- (*The 3D position(s) of the light source*) "FrameCount"->frameCount, -- (*A timestep for animation and a parameter if lightingPath is continuous*) "Refinement"->rayRefinement, -- (*Ray density; smaller values give finer results.*) "ProjectionPoints"->planeSpec, -- (*3D points forming surface(s) that shadow(s) are cast onto.*) "FrameData"-><||> -- (*Initially empty, data from the ray caster will be stored here.*) |> Generating The Projection Surface ----------------------------- The house should look like its casting it's shadow onto the earth so we define a list of points which represent the discrete plane it stands on. Each ray is a line drawn between each point on the projection surface and the position of the scene's light source. (* rayRefinement *) ref = 20; (* the height of the projection surface *) planeZoffset = 0; (* the discrete projection surface - each point is the origin of a \ ray *) projectionPts = Catenate[Table[{x, y, planeZoffset}, {x, -900, 1200, ref}, {y, -600, 1000, ref}]]; Graphics3D[{ Polygon[polyPoints], Cuboid /@ ({##, ## + {ref, ref, 0}} & /@ projectionPts) }, Axes -> True, AxesLabel -> {"X", "Y", "Z"}, ImageSize -> Large] ![enter image description here][12] Specifying A Light Source ------------------------- The light source is typically a continuous BSplineFunction which is sampled according to the number of frames the user wants. But it may also be a discrete list of 3D points too (in which case the number of frames is equal to the length of the list). Using a modification of a `SunPosition` example in the documentation, a list of the 3D Cartesian positions of the sun between sunrise and sunset, with a time step 30 minutes, is produced. ![enter image description here][13] solarPositionPts0[location_:Here, date_:DateValue[Now,{"Year","Month","Day"}],tSpec_:{30,"Minute"}]:= Evaluate[CoordinateTransformData["Spherical"->"Cartesian","Mapping",{1,\[Pi]/2-(#2 Degree),2Pi-(#1 Degree)}]]&@@@(Function[{series},Map[QuantityMagnitude,series["Values"],{2}]]@SunPosition[location,DateRange[Sunrise[#],Sunset[#],tSpec]&[DateObject[date]]]) solarPositionPts[Here, DateObject[{2017, 6, 1}], {30, "Minute"}] {{0.4700, -0.88253, -0.0155}, {0.4026, -0.91178, 0.0809},...,{0.4219, 0.90493, 0.0554}} It's easier to rotate the sun's path rather than the model and projection plane. Different transforms may also be applied to best-fit the path into the scene. solarXoffset = 0; solarYoffset = 0; solarZoffset = 0; zRotation = \[Pi]/3.5; scale = 1300; sourceSpec = RotationTransform[zRotation, {0, 0, 1}][ # + {solarXoffset, solarYoffset, solarZoffset} & /@ (solarPositionPts[Here, DateObject[{2017, 6, 1}], {30, "Minute"}] scale) ]; lightingPath = BSplineCurve[sourceSpec]; Specify A Frame Count --------------------- A frame count must be specified to discretize the light path into 3D points. Each of these points forms the end of each ray. If the light source is a discrete list, then its length is used to infer the frame count instead and does not need specifying by the user. frameCount = 30; Constructing The Scene ---------------------- Now we can preview the scene Graphics3D[{ Polygon[polyPoints], Cuboid /@ ({##, ## + {ref, ref, 0}} & /@ projectionPts), lightingPath, {Darker@Yellow, PointSize[0.03], Point[BSplineFunction[sourceSpec] /@ Range[0, 1, N[1/frameCount]]]} }, Axes -> True, AxesLabel -> {"X", "Y", "Z"}, ImageSize -> Large] ![enter image description here][14] All paramaters have been set, it's time to construct the scene. Specifying a continuous lighting path must be done using a `BSPlineCurve`. scene = newScene[bvh2, lightingPath, frameCount, ref, projectionPts] ![enter image description here][15] Processing A Scene For Shadow Mapping ------------------------------------- The BVH optimises the ray caster by reducing the number of polygons to search against for an intersection. If the ray intersects with the BVH root box then a breadth-first search along the BVH tree is initiated. Starting with the root box,the out-components are selected by their intersection with a ray and are used as roots for the search's next level. (* select peripheral out-components of root box that intersect with ray *) intersectingSubBoxes[BVHObj_,initialVertex_,rayOrigin_,raySource_]:=Select[Rest[VertexOutComponent[BVHObj["Tree"],{initialVertex},1]],intersectRayBox[#,rayOrigin,raySource]==True&]; (* for root box intersecting rays, find which leaf box(es) intersect with ray *) BVHLeafBoxIntersection[BVHObj_,rayInt_,rayDest_]:=Block[{v0}, (*initialize search *)v0=intersectingSubBoxes[BVHObj,VertexList[BVHObj["Tree"]][[1]],rayInt,rayDest]; (* breadth search *) If[v0=={},Return[v0], While[ (* check that vertex isn't a polygon - true if !0. Check that intersection isn't empty *) AllTrue[VertexOutDegree[BVHObj["Tree"],#]&/@v0,#=!=0&], v0=Flatten[intersectingSubBoxes[BVHObj,#,rayInt,rayDest]&/@v0,1]; If[v0==={},Break[]] ]; Return[v0]; ] ]; The code below generates a visualisation of this process using the input data from the scene generated. raySource = scene["ProjectionPoints"][[3700]]; rayDestination = scene["FrameData"][16]["SourcePosition"]; lv1Intersection = BVHLeafBoxIntersection[bvh, raySource, rayDestination]; lv2Intersection = BVHLeafBoxIntersection[bvh2, raySource, rayDestination]; lv1Subgraph = Subgraph[Graph[EdgeList[bvh2["Tree"]]], First[VertexList[bvh2["Tree"]]] \[DirectedEdge] # & /@ lv1Intersection]; lv2Subgraphs = Subgraph[Graph[EdgeList[bvh2["Tree"]]], Flatten[Table[ lv1Intersection[[ i]] \[DirectedEdge] # & /@ (Intersection[#, lv2Intersection] & /@ ((Rest@ VertexOutComponent[bvh2["Tree"], #] & /@ lv1Intersection)))[[i]], {i, 1, Length[lv1Intersection], 1} ], 1]]; lbl = ((#[[1]] -> #[[2]]) & /@ (Transpose[{lv2Intersection, ToString /@ Range[Length[lv2Intersection]]}])); edgeStyle = Join[ ReleaseHold@ Thread[(# -> HoldForm@{Thick, Blue}) &[EdgeList[lv2Subgraphs]]], ReleaseHold@ Thread[(# -> HoldForm@{Thick, Red}) &[EdgeList[lv1Subgraph]]] ]; rayBVHTraversal = Graph[EdgeList[bvh2["Tree"]], EdgeStyle -> edgeStyle, VertexLabels -> lbl, GraphHighlight -> lv2Intersection, ImageSize -> Medium]; rayModelIntersection = Graphics3D[{ {Green, Thickness[0.01], Line[{raySource, rayDestination - {220, -400, 400}}]}, {Hue[0, 0, 0, 0], EdgeForm[{Thick, Red}], Cuboid /@ lv1Intersection}, {Hue[.6, 1, 1, .3], EdgeForm[{Thick, Blue}], Cuboid /@ lv2Intersection}, {Opacity[0.5], Polygon[polyPoints]}, Inset @@@ Transpose[{ToString /@ Range[Length[lv2Intersection]], RegionCentroid /@ Cuboid @@@ lv2Intersection}] }]; Column[{ Row[ Show[rayModelIntersection, ViewPoint -> #, Boxed -> False, ImageSize -> Medium] & /@ {{-\[Infinity], 0, 0}, {0, -\[Infinity], 0}} ], rayBVHTraversal }] ![enter image description here][17] At the centre of the graph lies the vertex representing the root BV where all searches originate from. The search continues out form all vertices which have intersected with the ray. (* test intersection between ray and object polygon via BVH search *) intersectionRayBVH[BVHObj_,rayOrigin_,rayDest_]:=With[{ intersectionLeafBoxes=BVHLeafBoxIntersection[BVHObj,rayOrigin,rayDest] }, Block[{i},If[intersectionLeafBoxes=!={}, Return[Catch[For[i=1,i<Length[#],i++, Function[{thowQ},If[thowQ,Throw[thowQ]]][intersectRayTriangle[#[[1]],#[[2]],#[[3]],rayOrigin,rayDest]&@#[[i]]] ]&[DeleteDuplicates[Flatten[Lookup[BVHObj["LeafObjects"],intersectionLeafBoxes],1]]]]===True], Return[False] ]] ]; Once the tree has been fully searched, the remaining boxes are used to lookup their associated polygons. Since the same polygon may intersect more than one box, any duplicates are deleted. A line-triangle intersection test is iteratively applied over the resultant list, breaking at the first instance of a True return. This ray has now been found to intersect a part of the 3D model thus its origin point (from the `projectionPts` list) will represent a single point of shadow on the projection surface. This point is stored in a list which will be used to draw the shadow for a single frame. candidatePolys = DeleteDuplicates[Flatten[Lookup[ bvh2["LeafObjects"], BVHLeafBoxIntersection[bvh2, raySource, rayDestination] ], 1]]; intersectingPolys = Select[candidatePolys,PrimitiveIntersectionQ3D[Line[{raySource, rayDestination}],Triangle[#]] &]; rayModelIntersectionPolys = Graphics3D[{ {Green, Thickness[0.01], Line[{raySource, rayDestination - {220, -400, 400}}]}, {Hue[1, 1, 1, .5], EdgeForm[Black], Polygon[candidatePolys]}, {Hue[0.3, 1, 1, .5], Polygon[intersectingPolys]} }, Boxed -> False]; Row[Show[rayModelIntersectionPolys, ViewPoint -> #, ImageSize -> Medium] & /@ {{0, 0, \[Infinity]}, {0, \[Infinity], 0}}] Highlighted in green, the ray has been found to intersect with 2 polygons. ![enter image description here][18] The BVH search is performed for each ray, for each frame. A scene is the input for the ray caster. If a scene is to be re-processed with different parameters then a new scene must be made. The output of the ray caster is held within a scene object. The data for each frame is associated to its frame index and is all held in the scene's "FrameData" field. Begin processing. A status bar will indicate progress in terms of frames rendered. scene = renderScene[scene]; it's best to save any progress by exporting afterwards. Export["House_scene.txt", Compress[scene]] Reviewing Processed Scenes -------------------------- Each frame holds the shadow and ground data separately and have been expressed as zero-thickness cuboids (tiles) and each with side length equal to the `rayRefinement` parameter (recall that smaller values yield finer results). Individual frames are accessed by their frame index. This examines frame 10. Keys[scene["FrameData"][10]] {"ShadowPts", "SourcePosition", "GroundPts"} Accessing the processed scene's "FrameData" field allows a single specified frame to be drawn in Graphics3D. Graphics3D[{ Polygon[scene["BVH"]["PolygonObjects"]], {GrayLevel[0.3], EdgeForm[], Cuboid /@ scene["FrameData"][10]["ShadowPts"]}, {EdgeForm[], Cuboid /@ scene["FrameData"][10]["GroundPts"]}, {Darker@Yellow, PointSize[0.04], Point[scene["FrameData"][10]["SourcePosition"]]} }, Boxed -> False, Background -> LightBlue] ![enter image description here][23] `viewSceneFrame` does the task above for any processed scene and specified frame. It inherits Graphics3D options as well as custom ones affecting the scene elements (shadow and ground style, toggle source drawing and gridlines). viewSceneFrame[scene, 10, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue] ![enter image description here][24] Show[viewSceneFrame[scene, 10, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue], ViewPoint -> {0, 0, \[Infinity]}] ![enter image description here][25] sceneBounds = Join[ Most[MinMax /@ Transpose[scene["ProjectionPoints"]]], {MinMax[ Last /@ Values[scene["FrameData"][[All, "SourcePosition"]]]]} ]; viewSceneFrame[scene, 10, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue, Axes -> True, AxesLabel -> {"X", "Y", "Z"}, PlotRange -> sceneBounds] ![enter image description here][26] Retaining the same options, the scene may also be animated. To ensure a smooth playback, each frame is exported as .gif into `$TemporaryDirectory`, imported back as a list and animated. The animation is also exported for future use. animateScene[scene, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue, PlotRange -> sceneBounds, ImageSize -> {{800}, {600}} ] ![enter image description here][27] We can also plot the cumulative solar exposure. All points from the projection plane which don't intersect with the model (i.e, aren't shadow points) are extracted from the scene's frames exposure = Values[scene["FrameData"][[All, "GroundPts"]]] ![enter image description here][28] The occurrences of each exposure point is tallied tally = Tally[Flatten[exposure, 1]] ![enter image description here][29] And the range of frequencies from which is generated tallyRange = Range @@ Insert[MinMax[Last /@ SortBy[tally, Last]], 1, -1] {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, \ 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30} A color scale corresponding to the range of frequencies from above will be used to colorize the plot colorScale = ColorData["SolarColors", "ColorFunction"] /@ Rescale[tallyRange] ![enter image description here][30] Replacement rules are used to replace each exposure point's frequency with it's corresponding color colorScaleRules = Thread @@ {tallyRange -> colorScale} ![enter image description here][31] The resultant exposure map is a list of tiles, each coloured according to it's positional frequency. heatMap = Insert[MapAt[Cuboid, Reverse@MapAt[Replace[colorScaleRules], #, -1], -1], EdgeForm[], 2] & /@ tally ![enter image description here][32] Finally, the map is drawn. It's still a `Graphics3D` object so it may be rotated and viewed from any angle. Row[{ Show[Graphics3D[{ {Opacity[0.3], Green, Polygon[scene["BVH"]["PolygonObjects"]]}, heatMap }, Boxed -> False, ImageSize -> Large], ViewPoint -> Above], BarLegend[{"SolarColors", MinMax[tallyRange]}] }] ![enter image description here][33] The process of generating an exposure map forms a function within the `GeometricIntersections3D` package. Alternative color schemes may also be specified. sceneExposureMap[scene, "TemperatureMap"] ![enter image description here][34] The bar scale for the exposure plot measures duration in frames but a time scale may be recovered. Given that the solar path used to light the scene lasts about 14 hours and the scene was rendered for 30 frames, that gives about 30 minutes per frame. dailySunHours = UnitConvert[DateDifference[Sunrise[], Sunset[]], MixedRadix["Hours", "Minutes", "Seconds"]] ![enter image description here][35] dailySunHours/30 ![enter image description here][36] This has been a very rewarding project with some exciting potentials beyond computer graphics. Indeed, much optimisations can be made to the intersections package. The different methods of space partitioning for BVH construction should be investigated as the one currently employed is rather rudimentary. Anti-aliasing methods to be investigated also. Both the House and Sundial processes are documented in the notebooks attached. All necessary data may also be downloaded to save time. [1]: https://en.wikipedia.org/wiki/Shadow_mapping [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=animation.gif&userId=605083 [3]: https://3dwarehouse.sketchup.com/ [4]: https://github.com/b-goodman/GeometricIntersections3D [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_Import.png&userId=605083 [6]: https://en.wikipedia.org/wiki/Bounding_volume_hierarchy [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_TreeLV1.png&userId=605083 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_leafBoxesLV1.png&userId=605083 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cuboidSubdivide.gif&userId=605083 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_TreeLV2.png&userId=605083 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_leafBoxesLV2.png&userId=605083 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solarPosition.PNG&userId=605083 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_scenePreview.png&userId=605083 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_sceneConstructor.png&userId=605083 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_raySearch.png&userId=605083 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_rayIntersection.png&userId=605083 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_1.png&userId=605083 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_2.png&userId=605083 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_3.png&userId=605083 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_4.png&userId=605083 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=animation_House.gif&userId=605083 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_A.png&userId=605083 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_B.png&userId=605083 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_C.png&userId=605083 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_D.png&userId=605083 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_E.png&userId=605083 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_solarMap_A.png&userId=605083 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_solarMap_B.png&userId=605083 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sunHours.png&userId=605083 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sunHoursPerFrame.png&userId=605083 Benjamin Goodman 2017-06-01T07:01:10Z https://community.wolfram.com/groups/-/m/t/802316 Just last spring, we began the process of hand-picking the best and brightest U.S College students to represent us as Wolfram Student Ambassadors. We wanted to see what we could create if we gave those with a pre-existing passion for all-things-Wolfram the resources and support to do what many of them were already doing by their own accord – introducing their peers to the Wolfram Technology stack, and showing them first-hand its accessibility. Over the past year, it’s been fascinating to see how many different academic disciplines yield enthusiastic and talented applicants. More fascinating yet, were the applicants that defied our original demographic parameters: our *Student* Ambassador Program was receiving applications from *professors*, and even people without any academic affiliation at all. Which made sense – while Wolfram software has had a steady, growing popularity amongst students in recent years, its most loyal fans have been users since Mathematica’s conception in the late 80’s. Knowing this, coupled with the positive precedent set by the success of our Student Ambassador Program, it became apparent we needed to create a new program - something especially designed for our original Ambassadors. So who are we looking for? Odds are, you’ve been with us since the beginning. You’re most likely a natural leader, and love to get your friends/colleagues/students to that “light bulb” moment on projects and collaborations. Or maybe you’re an especially active member on community.wolfram.com, and you excel at performing solo projects with our software. Whatever it may be, we want to empower you to be able to do even more of it. This program will offer support to our professional enthusiasts, and give us the opportunity to say thank you by providing complimentary benefits, support, and tools for establishing a community or developing a personal project. We’d like to encourage anyone who has either considered or possibly already created a group to contact us in order to discuss getting involved in this new partnership opportunity. Benefits, which will vary in accordance to background/ area of expertise, may include: ---------- - Free Access to select Wolfram technologies - Cloud Credits (up to 1,000,000) - Training and workshop access - Materials and marketing merchandise for meetups/workshops - Opportunity for professional development as you give talks, organize meetups, and inspire others - Potential publication opportunities through Wolfram Media We’ve provided the platform – now we’re passing you the baton. This is our chance to thank you for the help you’ve already provided us, and support you as you help nurture and inspire the next generation of Wolfram Users. If you would like to know more, contact us at wca@wolfram.com Samantha Newman 2016-02-24T23:29:52Z