Skip to main content

Rotating perspective of an image in the z axis


A purely recreational question, but one I hoped the community would find interesting enough to suggest a way to approach it.


Let me preface this question with the admission that I have done nothing to date with Mathematica's image processing or any other program's image processing. I don't even take photos.


I have an photo of a wall mural:


mural


taken at an angle of approximately 40 degrees to its center. The mural no longer exists so I can't rephotograph it. I'd like to process this image so that I would get an image as if I had a perspective perpendicular to the center (or approximate center) of the mural. One could think of it as say anchoring the right edge of the image and then pulling the left edge forward. Or think of it as the plane of the white wall having an x and y axis with the origin at the center of the image, then I want to rotate the image in the z axis.


I've reviewed Mathematica's image processing functions. I hoped I'd find an obvious way to do this, perhaps using the Morphological Analysis capabilities, but everything appears 2D oriented.


I recognize the difficulty of the problem. Rotating the perspective would require everything to the left of the y axis to enlarge relative to its distance from the y axis while simultaneously doing the inverse to the right of the axis.



3D plots do this inherently, which is why I thought one ought to be able to do this.


ImageData[] and RotationTransform[]


seem likely candidates to do this. The documentation show how to create a


TransformationFunction[]:


enter image description here


The ideas to do this exist, but I haven't found an example of this applied to an image in the way I want to do it.


In the end, I only want the colors of the mural on a white background, like a poster image, I don't need the lighting or the floor or gradations of color. Solid colors for each of the elements would work fine. Doing these things seems relatively straightforward and should reduce the size of a raster file or the amount of data one needs to process and move around.


Can anyone direct me towards any examples or even documentation on how to approach this?


P.S., Can everyone see the wolf in the mural?





I wanted to show what I got to with Vitaliy Kaurov's solution:


 t = FindGeometricTransform[{{1924.19`, 880.846`}, {154.761`, 
1200.69`}, {190.872`, 189.582`}, {1893.24`,
297.914`}}, {{1924.19`, 880.846`}, {175.395`,
1283.22`}, {175.395`, 571.325`}, {1893.24`, 297.914`}},
"Transformation" -> "Perspective"];

ImagePerspectiveTransformation[image, t[[2]], 1000, DataRange -> Full,
PlotRange -> All];
ImageTake[%, {100, 480}, {120, 965}];

ImageAdjust[Lighter[Lighter[%]], 0.85]

enter image description here


This gets me closer to what I hoped than I imagined possible. Given that the original artist constructed the mural as a collage from rectangular sheets of paper, most of which have gone trapezoidalish I still need to twist the image to restore some of what original photo and image processing has skewed. If I figure it out in a reasonable time I'll post the final image. Thanks to all.



Answer



EDIT: Interactive -----------------------------


You may also want to read this blog post.


Here is interactive of the method below. Some initial things:


enter image description here


img = ImageResize[img, 300];

id = img // ImageDimensions


{300, 225}



Now put everything together


Manipulate[
Row[{Show[img,
Graphics[{{FaceForm[None],
EdgeForm[Directive[Dashed, Thick, Blue]], Polygon[pt]}, {Red,

PointSize[Large],
Point[{id/4, {id[[1]]/4, 3 id[[2]]/4},
3 id/4, {3 id[[1]]/4, id[[2]]/4}}]}}]],
Image[ImagePerspectiveTransformation[img,
FindGeometricTransform[
pt, {id/4, {id[[1]]/4, 3 id[[2]]/4},
3 id/4, {3 id[[1]]/4, id[[2]]/4}},
"Transformation" -> "Perspective"][[2]], DataRange -> Full,
PlotRange -> All], ImageSize -> 300]
}]

, {{pt, {id/4, {id[[1]]/4, 3 id[[2]]/4},
3 id/4, {3 id[[1]]/4, id[[2]]/4}}}, Locator}]

enter image description here


OLDER: Manual ----------------------------------------------


Here I explain in detail a manual version of app above. CTRL+d will bring the Drawing Tools palette. Then using the tools below you need to specify 2 set of 4 points for transformation. Basically to show where 4 points on original image map on the image you want. Click on the image with that tool green-circled and CTRL-c to copy the pixel coordinate.


enter image description here


t = FindGeometricTransform[
{{1924.19`, 880.846`},{154.761`, 1200.69`},{190.872`,189.582`},{1893.24`, 297.914`}},
{{1924.19`, 880.846`},{175.395`, 1283.22`},{175.395`,571.325`},{1893.24`, 297.914`}},

"Transformation" -> "Perspective"]

enter image description here


The apply


ImagePerspectiveTransformation[img, t[[2]], 500,DataRange ->Full,PlotRange -> All]

enter image description here


And crop the part you need


ImageTake[%, {5, 250}, {30, 490}]


enter image description here


Comments

Popular posts from this blog

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

What is and isn't a valid variable specification for Manipulate?

I have an expression whose terms have arguments (representing subscripts), like this: myExpr = A[0] + V[1,T] I would like to put it inside a Manipulate to see its value as I move around the parameters. (The goal is eventually to plot it wrt one of the variables inside.) However, Mathematica complains when I set V[1,T] as a manipulated variable: Manipulate[Evaluate[myExpr], {A[0], 0, 1}, {V[1, T], 0, 1}] (*Manipulate::vsform: Manipulate argument {V[1,T],0,1} does not have the correct form for a variable specification. >> *) As a workaround, if I get rid of the symbol T inside the argument, it works fine: Manipulate[ Evaluate[myExpr /. T -> 15], {A[0], 0, 1}, {V[1, 15], 0, 1}] Why this behavior? Can anyone point me to the documentation that says what counts as a valid variable? And is there a way to get Manpiulate to accept an expression with a symbolic argument as a variable? Investigations I've done so far: I tried using variableQ from this answer , but it says V[1...