Csdrhrt

So here's somewhat of the general goal first: Here's an example of image-based line patterns
Here is an example of an artists work in creating imagery using only lines
bent as though distorted by an actual 3D form.

Seemed to me that something like this could be accomplished in Mathematica using a 2D image and a line pattern.

Processing the 2D image in such a way as to maintain the edges then use some of the original pixel luminance to extrude a depth map. Then use this new 3D form to deform the line pattern and create this artistic effect.

Here's an image to begin with:link

Here's some code that may (or may not) get the creative juices flowing.
converting Images

In my application, I will need to use a second image to warp over the new 3D form because the pattern effect is going to be very different than this example image.

Other approach using NetModel:

net = NetModel[

   "Single-Image Depth Perception Net Trained on NYU Depth V2 and 

Depth in the Wild Data"];

Create depthMap and build an interpolation function:

depthMap = net[image];    

depthFunc = 

  Interpolation[

   Flatten[MapIndexed[{#2, #1} &, -Reverse@depthMap, {2}], 1]];

Apply depthFunc to line segments and plot it:

lines = Table[{j, i, 7 depthFunc[i, j]}, {i, 1, 240, 4}, {j, 1, 320, 

3}];



lineart3d = 

 Graphics3D[{AbsoluteThickness[2], 

   GeometricTransformation[Line[lines], 

    RotationTransform[-Pi/12, {1, 0, 0}]]}, ViewPoint -> Top, 

  ViewProjection -> "Orthographic", Boxed -> False, ImageSize -> 500]

You can rasterize if you want a 2d image:

Rasterize[lineart3d, ImageResolution -> 300]

Here's my attempt, which uses the neural net Carl Lange referred to, plots mesh lines with ListPlot3D, and finds a 'nice' view point to see the lines.

net = NetModel["Single-Image Depth Perception Net Trained on NYU Depth V2 and Depth in the Wild Data"];

img = Import["https://www.liveenhanced.com/wp-content/uploads/2017/12/Beauty-Of-Bears-Ears-National-Monument.jpg"];

{x, y} = ImageDimensions[img];



height = 1 - Rescale[ArrayResample[net[img], Round[{x, y}/4]]];



meshlines = ListPlot3D[

  400 Reverse[height], 

  Mesh -> 100, MeshFunctions -> {#2 &}, 

  DataRange -> {{0, x}, {0, y}}, PlotStyle -> None

];



mr = DiscretizeGraphics[meshlines, 

  MeshCellStyle -> {1 -> Black}, PlotTheme -> "Lines"];



M = MomentOfInertia[Point[MeshCoordinates[mr]]];



{v1, v2} = Rest[Eigenvectors[M]];



Show[mr, ViewVertical -> {0, 0, -1}, 

  ViewPoint -> {0, 10, 10} Normalize[Cross[v1, v2]]]

It might be possible to accentuate the detail better by finding a suitable power to raise height to, e.g. height^2, etc.

Here's a way to project into 2D, rather than adjusting the ViewPoint in 3D:

MeshRegion[

  -PrincipalComponents[MeshCoordinates[mr]][[All, 1 ;; 2]], 

  MeshCells[mr, 1], 

  PlotTheme -> "Lines", MeshCellStyle -> {1 -> Black}

]

Here's a way to add some smooth edge lines. There's room for improvement here -- both in the implementation and output -- and the high degree splines take some time to render.

The idea is to edge detect, break up branch points to get a collection of path curves, approximate each path with a smooth curve, then map into 3D.

boundary = Thinning[EdgeDetect[im, 10]];



brokenboundary = ImageMultiply[boundary, ColorNegate[MorphologicalBranchPoints[boundary]]];



ones = Position[Reverse[Transpose[ImageData[brokenboundary]], {2}], 1];



g = NearestNeighborGraph[ones, {All, 1.5}];



comps = WeaklyConnectedGraphComponents[g];



paths = FindHamiltonianPath /@ comps;



hmap = ListInterpolation[400 Reverse[Transpose[height], {2}], {{0, x}, {0, y}}];

paths3d = Apply[{##, hmap[##]} &, paths, {2}];



Show[

  mr, 

  Graphics3D[{AbsoluteThickness[1], BSplineCurve[#, SplineDegree -> Length[#] - 1] & /@ paths3d}], 

  ViewVertical -> {0, 0, -1}, 

  ViewPoint -> {0, 10, 10} Normalize[Cross[v1, v2]]

]

We can get some of the way there by using ListContourPlot.

Now we grab a neural network to get the depth map for us:

net = NetModel[

  "Single-Image Depth Perception Net Trained on NYU Depth V2 and Depth in the Wild Data"]

Now we can see our depth map:

Great. Let's put that in a list, after a little bit of cajoling (Blurring, ImageAdjusting so it's all between 0 and 1)

depth = ImageData@Blur@ImageAdjust@Image@net[i]

Now we can try and ListContourPlot it:

ListContourPlot[Reverse@depth, Contours -> 25, 

 ColorFunction -> (White &), Axes -> None, Frame -> None, 

 AspectRatio -> ImageAspectRatio@i]

Or, with the image you linked to:

Other options I thought about but didn't execute on:

• convolving an image of lines with the depth map


• converting the depthmap to a weighted graph and using FindShortestPath (I still like this one, but I think the output would be pretty similar to this attempt)


• There's always good old ImageRestyle, which if given enough time might do a really nice job of this...

ImageRestyle is an obvious thing to try:

Import["https://www.liveenhanced.com/wp-content/uploads/2017/12/Beauty-Of-Bears-Ears-National-Monument.jpg"];

imgBW = ColorConvert[img, "Grayscale"];

imgLines = Import["https://i.stack.imgur.com/bR9kS.png"];

ColorConvert[ImageRestyle[imgBW, imgLines], "Grayscale"]

If you are willing to wait a while, ImageRestyle has options:

resty = ImageRestyle[imgBW, imgLines, PerformanceGoal -> "Quality"]; 

ColorConvert[resty, "Grayscale"]