15

Update: I have managed to fix the distortion of the polygons, so now only the glow is missing Update 2: I have added a hacky "glow" to the polygons by adding partially transparent polygons slightly above the white polygons to give them some kind of "volumetric glow" Update 3: I have tweaked the lighting settings a bit to give the image a ...


5

A possible way. ParametricPlot3D[{x - y, x + y, Sin[x*y]}, {x, -8, 8}, {y, -8, 8}, Axes -> False, Boxed -> False, ColorFunction -> Function[{x, y, z}, ColorData["Rainbow"][x]], RegionFunction -> Function[{x, y, z}, x^2 + y^2 <= 36], MaxRecursion -> 0, Mesh -> None, Background -> Black, PlotPoints -> 80] /. ...


3

An alternative implementation of the idea in მამუკაჯიბლაძე's answer: abrade = Nest[ConvexHullMesh[PropertyValue[{#, 2}, MeshCellCentroid]] &, #, #2] &; Examples: abrade[ConvexHullMesh[{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}, {-.0001, -.000002, -.000000004}, {-.000000000005, 0, -.1}}], 10] SeedRandom[1]; abrade[ConvexHullMesh[RandomReal[1, {10, 3}]], ...


2

You can extract lines (and other graphics primitives, like points for vertices, and polygons for faces) using MeshPrimitives. ArrayPlot3D seems to use a convoluted specification consisting of translating a single Cuboid around, but in any case the following seems to work: ArrayPlot3D[ConstantArray[1, {4, 4, 4}]] /. Cuboid[a_] :> MeshPrimitives[Cuboid[a],...


2

Try Graphics3D[Map[symbols, list1], BoxRatios -> {1, 1, 1}]


2

Too long for a comment: I interpret these sorts of questions as a request for brainstorming. Here's how one might tackle the problem of reverse-engineering the colors: let's get every distinct color of the image, and try to identify a simple function to reproduce the non-black colors img=ImageTake[#, Last@ImageDimensions@# - 200] &@ Import["http://...


1

Add WindowClickSelect -> True to CreatePalette. CreatePalette[ Manipulate[ Plot3D[Sin[x y], {x, 0, 3}, {y, 0, 3}, ColorFunction -> color, ImageSize -> {480, 480}], {color, {"Rainbow", "NeonColors", "BlueGreenYellow"}}], WindowFloating -> True, WindowSize -> All, WindowTitle -> "Nice Plot&...


1

f[x_, y_] := 15 - 2 x + 2 y; reg1 = Polygon[ Flatten[#, 1] &@{#[[1]], #[[2]], f[#[[1]], #[[2]]]} & /@ {{-10, -10}, {-10, 10}, {10, 10}, {10, -10}}]; reg2 = Sphere[{1, -1, 2}, 5]; int = DiscretizeRegion@RegionIntersection[reg1, reg2]; Graphics3D[{{Opacity[0.5], Cyan, reg2}, {Red, reg1}, {Yellow, Thickness[.02], int}}, Boxed -> ...


1

You could display the datasets as polygons that extend down to z=0. dat = Join[#, {{#[[-1, 1]], #[[-1, 2]], 0}, {#[[1, 1]], #[[-1, 2]], 0}}] & /@ datatest; Graphics3D[{{Red, Polygon[{{-50, 0, 0.1}, {-50, 5, 0}, {320, 5, 0}, {320, 0, 0}}]}, {(*EdgeForm[None]*) Table[Polygon[i, VertexColors -> Map[Blend[{Blue, White}, #] &...


1

The answer was given in a comment: @flinty Many thanks. The problem is solved by changing 3DRenderingMethod to BSPTree. – zrysky Jun 18 '20 at 14:28


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