67
$\begingroup$

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

enter image description here

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

enter image description here enter image description here

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

enter image description here

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.

$\endgroup$
  • 1
    $\begingroup$ I really shouldn't have tapped on this before going yo bed... Now I'm going to be seeing these in my dreams... $\endgroup$ – Jojodmo Aug 30 '16 at 5:06
  • 3
    $\begingroup$ You don't have to make it spherical. Assume it is spherical! $\endgroup$ – Tony Ennis Aug 30 '16 at 11:36
  • 1
    $\begingroup$ I'm just glad this question isn't on Seasoned Advice! $\endgroup$ – Adrian Larson Aug 30 '16 at 22:37
  • $\begingroup$ @Sumit I think you can apply NIntegrate to a sequence of gradually transformed cows, apply SequenceLimit, and evaluate the results for spherical adherence. Also I have to say, the attention this question and answers have is getting blown up of proportion. $\endgroup$ – Anton Antonov Aug 31 '16 at 13:06
  • $\begingroup$ @AntonAntonov , I must confess I don't know what is a spherical adherence. What I am trying to do is to reduce the overcounting due to overlapping of layers. There should be a way to generate a new MeshRegion removing the duplicate points. One thing for sure - spherical cow is not the simplest cow as it claimed to be. $\endgroup$ – Sumit Aug 31 '16 at 14:25
74
$\begingroup$
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

$\endgroup$
  • 1
    $\begingroup$ Neat and simple mapping to a sphere - I like it :) $\endgroup$ – Sumit Aug 29 '16 at 14:03
  • 3
    $\begingroup$ This is math and physics as their best. :) $\endgroup$ – Tim S. Aug 29 '16 at 15:14
  • 3
    $\begingroup$ What would this look like if you wanted to conserve volume? I get the impression that the final sphere is a bit bigger than the original cow. $\endgroup$ – user3490 Aug 29 '16 at 15:51
  • 1
    $\begingroup$ you can do it by integrating over the region. Integrate[1, {x, y, z} ∈ ExampleData[{"Geometry3D", "Cow"}, "MeshRegion"]]. I added it in my question as an edit. $\endgroup$ – Sumit Aug 30 '16 at 13:39
  • 1
    $\begingroup$ I joined mathematica.SE just to be able to upvote this question and this answer. $\endgroup$ – Arek' Fu Aug 30 '16 at 15:20
27
$\begingroup$

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

$\endgroup$
  • $\begingroup$ Very clever solution! $\endgroup$ – Anton Antonov Aug 29 '16 at 13:47
12
$\begingroup$

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

$\endgroup$
  • $\begingroup$ Thanks, Anton. Would it be possible to draw an outer surface (something like a 3DMesh)? I tried to replace the coordinates of the original image with sphCowPoints, but it looks like the polygon order also has changed in this process. $\endgroup$ – Sumit Aug 29 '16 at 13:16
  • $\begingroup$ I tried to produce a 3D surface too, but did not get good results. At this point if I continue working on this I would use Nearest and related functions to find the points close to each other and make polygons. $\endgroup$ – Anton Antonov Aug 29 '16 at 13:28
  • $\begingroup$ I use your BlowUp with with ReplaceAll and it seems to work. I put it as an edit. $\endgroup$ – Sumit Aug 29 '16 at 13:30
  • $\begingroup$ @Sumit Ah, of course -- it didn't occur to me to use ReplaceAll! $\endgroup$ – Anton Antonov Aug 29 '16 at 13:36
  • $\begingroup$ You don't need that RegionDistribution function if you have version 10.2 or above, you can use RandomPoint instead. So you can just write cowPoints = RandomPoint[region, 6000]. $\endgroup$ – RunnyKine Aug 30 '16 at 15:12
9
$\begingroup$

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

Mathematica graphics

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

$\endgroup$
  • $\begingroup$ Now I am feeling great about myself :). BTW, since you used colour, do you have an idea about how to put spots on the cow? I tried VertexColors -> (RandomChoice[{Black, White}] & /@ p)... with your oneliner but the cow looks more like a zebra. I am trying to use Graphics[Disk[RandomReal[10, 2], RandomReal[]] & /@ Range[20]] as a texture like the second example in my question - but nothing good so far. $\endgroup$ – Sumit Aug 30 '16 at 17:19
  • $\begingroup$ Textures may work, however here the transformation-induced distortions are quite bad here, so probably you'll be better off with some of the other solutions. This one was optimized for brevity only 😉. $\endgroup$ – Yves Klett Aug 30 '16 at 19:53
6
$\begingroup$

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]

enter image description here

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

$\endgroup$
  • $\begingroup$ umm, it doesn't look like you are exactly blowing the cow. I was looking for a way to radially expand its outer surface. $\endgroup$ – Sumit Aug 29 '16 at 13:33
0
$\begingroup$

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

enter image description here

$\endgroup$
  • $\begingroup$ "This should be rather straightforward to implement in Mathematica." - then you should show a "straightforward" implementation for this to be a proper answer, no? ;) $\endgroup$ – J. M. will be back soon Jan 13 '17 at 12:58
  • $\begingroup$ A simple variant of the discrete laplacian operator applied at a vertex computes the difference between a vertex' location and the average location of its neighbors. The smoothing operation resulting from this simply sets each vertex' position to the average of its neighbors. CurvatureFlowFilter does something similar for images. There, that's some more pointers for looking up the theory, I'm not giving out the full answers here ;) $\endgroup$ – masterxilo Jan 14 '17 at 17:31
  • 3
    $\begingroup$ To anybody else reading this: since the answerer is not willing or able to post sundry code, you might be able to use some pieces from this answer if you wish to pursue this approach. $\endgroup$ – J. M. will be back soon Jan 14 '17 at 18:17

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.