How to make a Spherical Cow?

cow = ExampleData[{"Geometry3D", "Cow"}];
Manipulate[cow /. GraphicsComplex[array1_, rest___] :>  
                  GraphicsComplex[(# (Norm[#]^-coeff)) & /@ array1, rest],
           {{coeff, .25}, 0, 1}]

enter image description here

Edit

To answer to Clément's comment, here is same thing with constant plot range :

enter image description here


Get cow as a mesh region:

cow = ExampleData[{"Geometry3D", "Cow"}, "MeshRegion"];

Take coordinates of 0 cells:

coords = MeshCoordinates[cow];

Get outer sphere that bounds cow:

boundary = RegionBoundary @ BoundingRegion[cow, "MinBall"];

You could also try other bounds like "FastCapsule". For example,

boundary = RegionBoundary @ BoundingRegion[cow, "FastCapsule"];

Compute nearest points on the sphere from cow:

npts = RegionNearest[boundary, coords];

Manipulate results using a linear transformation:

cells = MeshCells[cow, 2];
Manipulate[MeshRegion[(1 - t) coords + t npts, cells], {t, 0, 1}]

enter image description here


This answer does not produce very pretty outcomes, but it does correspond to the question request:

I was wondering if there is a way to apply a continuous deformation to the data to get the final sphere (like blowing a balloon).

One thing this solution is good for -- i.e. more useful than the other solutions :) -- is to derive autostereograms. See the last section.

Cow points

Generate random cow points:

region = DiscretizeGraphics@ExampleData[{"Geometry3D", "Cow"}];
cowPoints = RandomPoint[region, 6000];
ListPointPlot3D[cowPoints, BoxRatios -> Automatic]

enter image description here

Blowing up the cow (points)

Using this function:

Clear[BlowUp]
BlowUp[points_, center_, sfunc_] :=
  Map[sfunc[Abs[# - center]] (# - center) + center &, points]

and the continuous function:

Plot[Evaluate@
  With[{a = 0.11}, 
    Piecewise[{{#, # < a}, {a Exp[2 (a - #)], # >= a}}] &][x], 
{x, 0, 0.6}, PlotRange -> All]

enter image description here

we can blow up the cow points to get something close to a sphere:

sphCowPoints = 
  BlowUp[cowPoints, Median[cowPoints], 
   With[{a = 0.11, k = 2}, {1, 1.8, 2} 
     Piecewise[{{k Norm[#], Norm[#] < a}, 
                {k a Exp[2 (a - Norm[#])], Norm[#] >= a}}] &]];
ListPointPlot3D[sphCowPoints, BoxRatios -> Automatic]

enter image description here

Magic eye spherical cows

Since Yves Klet mentioned the WTC-2012 one-liners competition and one of my entries was an autostereogram one-liner here is code that generates a simple spherical cows autostereogram:

rmat = N@RotationMatrix[-\[Pi]/4, {0, 0, 1}];
tVec = {0.1, 0, 0};
sirdPoints = NestList[Map[# + tVec &, #] &, sphCowPoints.rmat, 5];
Graphics3D[{PointSize[0.002], 
  MapThread[{GrayLevel[0.8 - #2], Point[#1]} &, {Flatten[sirdPoints, 
     1], 0.8 Rescale[Flatten[sirdPoints, 1][[All, 2]]]}](*,Lighter[
  Blue],fence*)}, ViewPoint -> Front, Boxed -> False, 
 ImageSize -> 1200]

enter image description here

Tags:

Geometry

Image3D

Recent Posts