How to make a Spherical Cow?

Question

Being a theoretical physicist, I always have a great respect for Spherical Cow. So I thought about making one myself. I am not sure how can I create (something considered to be the simplest!) this marvel.

One possible way could be using the ExampleData for Cow and map it on a sphere - something like

Show[ExampleData[{"Geometry3D", "Cow"}], 
     Graphics3D[Sphere[{-.1, 0, 0.05}, .25]]]

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

Another possible way (which is probably the Spherical cow approach of making a Spherical cow) is to map an image of a cow on a sphere.

face = Import["http://cliparts.co/cliparts/6Ty/ogn/6TyognE8c.png"]

cow = Graphics[{Disk[10 {RandomReal[], RandomReal[]}, RandomReal[]] & /@ Range[20],
                Inset[face]}, AspectRatio -> 1,ImageSize -> 500];

ParametricPlot3D[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}, {u, 0, 2 Pi},
{v, 0, Pi}, Mesh -> None, PlotPoints -> 100, 
TextureCoordinateFunction -> ({#4, 1 - #5} &), Boxed -> False, 
PlotStyle -> Texture[Show[cow, ImageSize -> 1000]], 
Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip"]

Then it is difficult to manage the legs and the tail.

---

Fixed volume cow

Based (copying) on andre's answer here is a modification.

First, we calculate the volume of the cow and the radius of equivalent sphere

cow = ExampleData[{"Geometry3D", "Cow"}];
Vcow = NIntegrate[1, {x, y, z} ∈ MeshRegion[cow[[1, 2, 1]], cow[[1, 2, 2]]]]
Rcow = (3/(4 Pi) Vcow)^(1/3)

0.674671

0.544086

Now insert Rcow in the scaling

Table[vcow = NIntegrate[1, {x, y, z} ∈ MeshRegion[(# ((Norm[#]/Rcow)^-coeff)) & /@
 cow[[1, 2, 1]], cow[[1, 2, 2]]]];
Show[cow /. GraphicsComplex[array1_, rest___] :> 
 GraphicsComplex[(# ((Norm[#]/Rcow)^-coeff)) & /@ array1, rest], 
 Axes -> True, PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}} 0.6,
 Boxed -> True, PlotLabel -> StringForm["(``), V=``", coeff, vcow], ImageSize -> 200], 
{coeff, 0, 1, 0.25}]

Although the final radius is same as Rcow, the volume keeps increasing because, on this sphere, several layers are overlapping on each other (reminds me the length of British coastline) which causes overcounting during the numerical integration.

Answer 1

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

Edit

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

Answer 2

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}]

Answer 3

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]

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]

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]

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]

Answer 4

Great minds think alike (either that, or silly ideas rule eternal)... Something quite similar was also part of the 2012 oneliner competition. I pull all vertices through the origin to make it a bit more flashy.

This is the golfed version (which arrives at 131 characters, if properly typeset. Also, note bovino-onomatopoeic use of Greek characters):

{{g},{p}} := {{ExampleData@{"Geometry3D", "Cow"}}, {g[[1, 2, 1]]}};
Manipulate[
 g /. g[[1, 2, 3]] -> VertexColors -> (Hue@Random[] & /@ p) /. 
  p -> (# (μ - (1 - μ)/Sqrt[#.#]) & /@ p), {μ, 0, 1}]

You can see the detailed discussion on this one here. Don't miss out on the actual winners, they are amazing.

Answer 5

Here's a simple way of making the blow-up cow:

Manipulate[Show[ExampleData[{"Geometry3D", "Cow"}], 
  Graphics3D[Sphere[{-.1, 0, 0.05}, r]]], {r, 0, 0.5},
  SynchronousUpdating -> False]

Changing r changes the size of the sphere. If your computer is slow, you may need to add the ContinuousAction -> False option.

Answer 6

You can do this using the discrete laplacian computed on the mesh by transforming along the thusly computed mean curvature flow. This operation is often called called smoothing in Geometry Processing.

You need to take precautions to preserve the volume of the mesh, otherwise it shrinks to 0.

This should be rather straightforward to implement in Mathematica.

Here's a pointer: https://libigl.github.io/libigl/tutorial/tutorial.html#laplacian