Skip to main content
replaced http://mathematica.stackexchange.com/ with https://mathematica.stackexchange.com/
Source Link

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

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

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

added 1049 characters in body
Source Link
Anton Antonov
  • 38.5k
  • 3
  • 104
  • 184

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

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

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

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

deleted 749 characters in body
Source Link
Anton Antonov
  • 38.5k
  • 3
  • 104
  • 184

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

RegionDistribution

This function is taken from from http://mathematica.stackexchange.com/a/61677/34008

RegionDistribution /: Random`DistributionVector[RegionDistribution[reg_MeshRegion], n_Integer, prec_?Positive] := Module[{d = RegionDimension@reg, cells, measures, s, m}, cells = Developer`ToPackedArray@MeshPrimitives[reg, d][[All, 1]]; s = RandomVariate[DirichletDistribution@ConstantArray[1, d + 1], n]; measures = PropertyValue[{reg, d}, MeshCellMeasure]; m = RandomVariate[#, n] &@ EmpiricalDistribution[measures -> Range@Length@cells]; #[[All, 1]] (1 - Total[s, {2}]) + Total[#[[All, 2 ;;]] s, {2}] &@cells[[m]]] 

Cow points

Using the function above we generateGenerate random cow points:

region = DiscretizeGraphics@ExampleData[{"Geometry3D", "Cow"}]; cowPoints = RandomVariate[RegionDistribution[region]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

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

RegionDistribution

This function is taken from from http://mathematica.stackexchange.com/a/61677/34008

RegionDistribution /: Random`DistributionVector[RegionDistribution[reg_MeshRegion], n_Integer, prec_?Positive] := Module[{d = RegionDimension@reg, cells, measures, s, m}, cells = Developer`ToPackedArray@MeshPrimitives[reg, d][[All, 1]]; s = RandomVariate[DirichletDistribution@ConstantArray[1, d + 1], n]; measures = PropertyValue[{reg, d}, MeshCellMeasure]; m = RandomVariate[#, n] &@ EmpiricalDistribution[measures -> Range@Length@cells]; #[[All, 1]] (1 - Total[s, {2}]) + Total[#[[All, 2 ;;]] s, {2}] &@cells[[m]]] 

Cow points

Using the function above we generate cow points:

region = DiscretizeGraphics@ExampleData[{"Geometry3D", "Cow"}]; cowPoints = RandomVariate[RegionDistribution[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

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

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

deleted 23 characters in body
Source Link
Anton Antonov
  • 38.5k
  • 3
  • 104
  • 184
Loading
added 79 characters in body
Source Link
Anton Antonov
  • 38.5k
  • 3
  • 104
  • 184
Loading
Source Link
Anton Antonov
  • 38.5k
  • 3
  • 104
  • 184
Loading