# Tag Info

## Hot answers tagged code-request

78

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 ...

76

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 ...

40

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 ...

38

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 ~...

37

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 ...

33

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@...

23

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 ...

22

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 ...

18

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....

18

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, ...

18

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, ...

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

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@...

16

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,...

15

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,...

14

This is a difficult problem, as the referenced literature in the linked SE questions may attest. I can provide some steps towards your goal, but I don't have the full answer. im = ImageTake[Import["http://i.stack.imgur.com/rSOow.png"], {10, -10}, {10, 220}] First, trying to find the shadow mask, ChanVeseBinarize seems to work best here. Note that I ...

14

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, ...

13

Edit: Shorter ImageTrim version as pointed out by Matthias Odisio Use MorphologicalComponents and utilize ComponentMeasures to extract the "BoundingBox" which is already the row- and column-number you can then feed directly to ImageTake or even better to ImageTrim. ImageTrim has the big advantage that it can handle the bounding box coordinates directly: ...

13

One major improvement to any matching algorithm in this specific case will be to get rid of the diacritical marks in the first list that don't appear in the second list. I'm not aware of any Mathematica function to do that and too lazy to roll a conversion table myself, but there is a simple Java routine to be found here that does this. I slightly modified ...

13

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[...

13

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 ...

13

Simple solution with numerous spheres: n = 10000; r1 = RandomReal[{2, 2.1}, n]; r2 = RandomReal[{0.1, 0.12}, n]; aa = RandomReal[{-(Pi/2), Pi/2}, n]; bb = RandomReal[{0, 2 2Pi}, n]; s[p_, r_] := {Hue[10 r], Sphere[p, r]}; p[r_, a_, b] := r {Cos[a] Sin[b], Cos[a] Cos[b], Sin[a]}; Graphics3D[{Specularity[White, 30], MapThread[s, {MapThread[p, {r1, aa, bb}], ...

12

Your functions take two arguments as input. Yet they return one argument as output. So the output of f cannot serve as the input of g and vice versa. You can't compose the functions with until the outputs of one function can serve as the input for the other function. Reduce your arguments in f, g by placing them in a list. This appears to work: f[{x_, y_}] ...

12

This one is very close to your Python code Join @@ Table[Append[a, i], {a, A}, {i, Intersection[Range[3], a]}] {{1, 2, 3, 1}, {1, 2, 3, 2}, {1, 2, 3, 3}, {2, 3, 4, 2}, {2, 3, 4, 3}, {3, 4, 5, 3}}

12

Generating test data data = Table[{x, Sin[x] + Sin[3. x/2]}, {x, 0, 6. Pi, Pi/5.}]; Clear[f] The interpolation function for the data is f = Interpolation[data]; Maxima occur for f'[x] == 0 and f''[x] < 0 xValues = x /. Select[ FindRoot[f'[x], {x, #}] & /@ Range[0, 6 Pi, Pi/4] // Union[#, SameTest -> (Abs[#1[[1, -1]] - #...

12

Using Bob Hanlon's example data: data = Table[{x, Sin[x] + Sin[3. x/2]}, {x, 0, 6. Pi, Pi/5.}]; peaks = FindPeaks[data[[All,2]]][[All,1]] (* {3,10,15,23,30} *) Mean@Differences@peaks (* 27/4 *) Mean@Differences@data[[peaks, 1]] (* 4.24115 *) Or, use PeakDetect: Mean @ Differences @ Pick[#1, PeakDetect @ #2, 1] & @@Transpose[data] (* 4.24115 *) ...

12

The Pitsianis-Van Loan algorithm turns out to be surprisingly easy to implement in Mathematica: nearestKroneckerProduct[mat_?MatrixQ, dim1_?VectorQ, dim2_?VectorQ] /; TrueQ[Dimensions[mat] == dim1 dim2] := Module[{bv, cv, sig}, {bv, sig, cv} = SingularValueDecomposition[Flatten[ Map[Composition[Flatten, Transpose], ...

11

The two standard methods are SlotSequence, and the "injector pattern." Related question on StackOverflow: How to Block Symbols without evaluating them? SlotSequence ClearAll[myBlock] SetAttributes[myBlock, HoldAll] varList = {"a", "b", "c", "d"}; myBlock[args_] := Function[Null, Block[{##}, args], HoldAll] @@ (MapIndexed[Set, Join @@ MakeExpression@...

11

Mathematica has a few very limited 'effects' built-in: i = Import["http://i.stack.imgur.com/XwYg7.jpg"]; oil = ImageEffect[i, {"OilPainting", 4}] boss = ImageEffect[i, {"Embossing", 15}] Combining them: ImageAdjust[ImageCompose[boss, {oil, .5}], {1, 0}] But for the best effects, you'll have to start drinking absinthe...

11

You can achieve an effect like this by using CurvatureFlowFilter and GaborFilter. The effects are best viewed in full resolution. Here is the original image: img = Import["http://i.stack.imgur.com/XwYg7.jpg"] Now we smooth is nicely with the CurvatureFlowFilter: imgsmooth = CurvatureFlowFilter[img, 2] And generate a gradient image of the original ...

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