We’re rewarding the question askers & reputations are being recalculated! Read more.
94

Amusingly enough, the images above actually arose as an accidental by-product of browsing inane YouTube conspiracy theory videos. I happened across a rather beautiful video of a "mirror cube" device produced by a man in Germany named Ben Palmer, who apparently produced it in an attempt to bring recognition to a philosopher named Walter Russell (the first ...


89

TL;DR: A package (Mathematica v10) can be found at the very bottom of this post. UPDATES 6: Tiny update: Import can now use the ".bvh" extension to determine the import type. The code that does this is ugly, but I don't see any other way at the moment. out = Import["C:\\Female1_C03_Run.bvh"] 5: Added error checking and registered the package as an ...


45

EDIT: I found a version of the source image with fewer jpeg artifacts. My idea would be to extract pixels along the border of the shadow, inside and outside of the shadow. Then I have a list of pairs of RGB values, and I can find a suitable transformation from "shadowed" pixels to "non-shadowed" pixels. But first, I must find the shadow area. I would ...


45

Edit Here is a different approach using Graphics to actually draw some brush strokes. I run a GradientOrientationFilter on a smaller version of the image to estimate the local image gradient, and use that information to create a collection of randomly shaded lines: img = Import["http://i.stack.imgur.com/XwYg7.jpg"]; im = img ~ImageResize~ 200 ~...


44

First, define the dimensions and colors associated with our matrix: {mheight, mwidth} = mdim = {12, 20}; mdepth = 20; mcolors = Reverse@Array[ Blend[{{0, Darker[Green, 0.9]}, {0.4, Darker[Green]}, {0.6, Darker[Green]}, {0.90, Lighter[Green]}, {1, Lighter[Green, 0.8]}}, #/(mdepth - 1)] &, mdepth, 0]; Next, define some useful ...


41

There are two aspects of this question that distinguish it from previous questions: The request for a general template, as opposed to just a single example. The fact that the given example is a polynomial of degree three, whereas as opposed to the quadratic examples which appear in many places, including Stan's book. To deal with the first issue, in part, ...


37

I am not sure, if one can separate one curve out of the image. There is, however, another possibility to do what you want. It is possible to get the curve points out of the image. I am not sure, if I have already published here this answer. I checked but did not find it. Hence, I am publishing it. The task is fulfilled by a copyCurve function first described ...


34

Forward Mapping One way to do it is to create the texture for one tile and then transform repeated copies of it in a way that resembles the original illusion. First we create the tile: tile = Module[{KeyHole}, KeyHole[base_] := Sequence[ Disk[{0, 1/3} + base, 1/10], Rectangle[{-1/30, 1/15} + base, {1/30, 1/3} + base] ]; Image@Rasterize@...


28

You'll be interested in the (undocumented!) functions Graphics`Mesh`IntersectQ[] (for checking the intersections) and Graphics`Mesh`FindIntersections[] (for actually finding them). As a sample: BlockRandom[SeedRandom[42, Method -> "MersenneTwister"]; (* for reproducibility *) lins = Table[{Line[RandomReal[1, {2, 2}]]}, {42}];] Graphics`Mesh`...


28

I got my CIE color matching functions from here. These are the CIE 1931 2-deg, XYZ CMFs modified by Judd (1951) and Vos (1978). {λ, x, y, z} = Import["http://www.cvrl.org/database/data/cmfs/ciexyzjv.csv"]\[Transpose]; ListLinePlot[{{λ, x}\[Transpose], {λ,y}\[Transpose], {λ, z}\[Transpose]}, PlotLegends -> {"X", "Y", "Z"}] Conversion of color ...


25

The kite-domino tiling is based the pinwheel tiling which is falls out of a particular decomposition of a right triangle with legs of length 1 and 2. In the code that follows, rt[{a,b,c}] represents such a right triangle and dissect indicates how such a triangle should be decomposed into smaller copies of itself. We simply iterate the dissect function on ...


25

Hyperbolic lines in the Poincare disk are arcs of circles which, if extended, would meet the unit circle boundary orthogonally. Tiling the disk requires reflection of a tile's vertices and circular edges in those same circular edges. This corresponds to inversion in a circle. Begin with a central polygon having p edges, with q such polygons meeting at each ...


24

Found this somewhere: ϕ = GoldenRatio; s = 1.75; ContourPlot3D[ -(4*(ϕ^2*x^2 - y^2)*(ϕ^2*y^2 - z^2)*(ϕ^2*z^2 - x^2) - (1 + 2 ϕ)*(x^2 + y^2 + z^2 - 1)^2) == 1.1, {x, -s, s}, {y, -s, s}, {z, -s, s}, ContourStyle -> White, Boxed -> False, Axes -> False, SphericalRegion -> True, Mesh -> 5, BoundaryStyle -> None, PlotPoints -> 45, ...


23

This small app allows you to select data points and put them in a bin. In that way you can manually select several curves. I imagine this might be useful to someone who has complex plots where lines might intersect, making it hard or impossible to extract the data programmatically. You first have to set the image at the first line. After that when you want ...


23

Usually viruses have icosahedron symmetry. So I propose to generate a random chain of balls and translate it appropriately n = 2000; f = GaussianFilter[#, 5] &; p = f@RandomReal[{3.0, 4.0}, n] #/Sqrt@Total[#^2, {2}] &@ Accumulate@Prepend[0.08 f@RandomReal[NormalDistribution[], {n - 1, 3}], Normalize@RandomReal[NormalDistribution[], 3]]; r = f@...


22

You can use the LCE package by Dr Sandri Marco. It is updated for version 7 and I just tried in on your system for V9 and it worked. Download lcm.zip and use the package as instructed Here is the result of running your system on it on my PC << lce.m ?LCEsC These are the 3 Lyapunov Exponents for the Rossler system: rossler[{x_, y_, z_}] := {-y - z,...


22

Show it: RegionPlot[ region = RegionUnion[ Sequence @@ RegionIntersection @@@ Subsets[{Disk[{-1, 0}], Disk[{0, -1}], Disk[{1, 0}], Disk[{0, 1}]}, {2}], Fold[RegionDifference, {Disk[{0, 0}, 2], Disk[{-1, 0}], Disk[{0, -1}], Disk[{1, 0}], Disk[{0, 1}]}]], Frame -> False] Area Area[region] 4 (-2 + π) Perimeter ...


21

I thought I'd share my attempt at this, even though it doesn't seem to have worked properly. The CIE color matching functions are tabulated in the Image`ColorOperationsDump context which is used by ChromaticityPlot. The context can be loaded by calling ChromaticityPlot and then we can interpolate the data to obtain functions: ChromaticityPlot["RGB"]; {x, ...


21

The Pitsianis-Van Loan algorithm turns out to be surprisingly easy to implement in Mathematica: nearestKroneckerProductSum[mat_?MatrixQ, dim1_?VectorQ, dim2_?VectorQ, k_Integer?Positive, opts___] /; TrueQ[Dimensions[mat] == dim1 dim2] := Module[{tmp}, Check[tmp = SingularValueDecomposition[Flatten[...


20

Definition GaussCurvature[f_] := With[{dfu = D[f, u], dfv = D[f, v]}, Simplify[(Det[{D[dfu, u], dfu, dfv}] Det[{D[dfv, v], dfu, dfv}] - Det[{D[f, u, v], dfu, dfv}]^2) / (dfu.dfu dfv.dfv - (dfu.dfv)^2)^2]]; Sphere As @ ubpdqn already remarked GaussCurvature[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}] 1 Ellipsoid ellipsoid = {2 Cos[u] Sin[v], ...


19

Edit Old answer follows below The features of your new set are very different from the first image. For example: There are components "touching" the borders. They have "hidden" structures like this: So it needs a different approach: l = {"http://i.stack.imgur.com/OZEvk.png", "http://i.stack.imgur.com/Tl1Pm.png", "http://i.stack.imgur.com/8enYZ.png"}...


19

Catmull-Clark Subdivision Indeed, I have some code for Catmull-Clark subdivision and I planned to post it here for quite some time. This seems to be a good opportunity. The code is optimized for performance, so it involves a lot of CompiledFunction and SparseArray hacks. I am sorry if you find it somewhat unidiomatic. CatmullClarkSubdivisionMatrix creates ...


18

Update: If you want 4-neighborhood, you can use MorphologicalComponents to do most of the work, which is fast and easy to implement (that was my original attempt, see below). But I don't think this can be adapted for 8-neighborhood. For 8-neighborhood, I would implement the standard 2-pass connected component labeling algorithm (this might be what ...


18

You may use Interpretation. You will need some fancy formatting function that I will proxy here with Style. The following will create a column of the code snippet and its annotation that can be directly used in input cells. Interpretation[ Column[ { HoldForm[RandomVariate[NormalDistribution[], 20]], Style["Twenty random numbers", Blue, "Output"] ...


17

You could start to scrape allowed characters in that font, e.g.: mcolors = Blend[{{0.00, Darker[Green, 0.7]}, {0.90, Darker@Green}, {0.90, Lighter[Green]}, {1.00, Lighter[Green, 0.9]}}, #] &; $unic := $unic = Join[{"\[Wolf]", "\[MathematicaIcon]", "\[HappySmiley]"}, Drop[ToExpression[ "\"" <> StringReplace[#, "U+" -> "...


17

A simple numerical maximization using NMaximize as suggested by b.gatessucks: pts = Array[{x[#], y[#]} &, 10]; mindist2 = Min[#.# & /@ Subtract @@@ Subsets[pts, {2}]]; vars = Flatten[pts]; constraints = Thread[0 <= vars <= 1]; {md2, rules} = NMaximize[{mindist2, constraints}, vars]; minimaldistance = Sqrt[md2] (* 0.381759 *) Graphics[{Yellow,...


17

I have seen your question on math.SE and I know how it is when you don't find the right place to ask a question. Consider this a one-time present. If you truly want to learn Mathematica, you need to put in some effort in understanding what's going on here. Basically, your iteration can be written down almost as you have it: s[x_] := x^Log[x]; t[x_] := 1/81*...


17

Using CirclePoints, Mod, Throughand Range More than enough lines Multicolumn@With[ { n = 500, m = 17 }, Table[ Graphics[ {Opacity[0.1], Through@{Point, Line}[ Part[CirclePoints[n], Mod[{1, k } #, n] + 1]] & /@ Range[n] } ] , {k, 2, m}] ] Simpler Multicolumn@With[ { n = 100, m = 7 }, Table[ ...


15

Update Nov 6, 2018: Tweaked to work on nonautonomous systems, to fix problem reported here. Here's an updated implementation (works with MMA v11) that generalizes Housam Binous & Nasri Zakia's update to Marco Sandri's package and incorporates ideas from @bbgodfrey. First, define @halirutan's GramSchmidt: GramSchmidt[w_?MatrixQ] := Module[{v = ...


15

I decided to take a slightly different approach. Instead of transforming an image, I thought of constructing a function that will look like the illusory figure in the OP after performing the log-polar transform. Here's what I came up with: checkerboard[x_, y_] := Boole[EvenQ[Floor[x] - Floor[y]]] keyholes[x_, y_] := Boole[(Mod[x - 1/2, 1] - 1/2)^2 + (Mod[y, ...


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