How to make a two letter monogram in 3d like the one on www.mymo.is? [duplicate]

Question

I want to achieve the same effect like the project on http://www.mymo.is/. By taking two letters and combine them in 3d, you can get a complex shape that looks like one letter on the one side and the other letter on the other side. I tried several ways of doing this, but all failed. Maybe I way of making it is totally wrong. Can anyone give a suggestion? I think making this will be fun.

this is how a monogram of letter "C" and "K" looks like. Here are some ways I tried: (1)

t = Text[Style["A", Bold]];
regionmeasure = 
Flatten[Differences /@ 
Transpose[
List @@ BoundingRegion[
RandomPoint[
RegionBoundary@
BoundaryDiscretizeGraphics[t, _Text, MaxCellMeasure -> 0.01], 1000]]]];
(*measure the bounding box of the measure, then used to convert the region to fit in a 1*1 square*)
region = TransformedRegion[
DiscretizeGraphics[t, _Text, MaxCellMeasure -> 0.1], 
ScalingTransform[Reverse[1/Times @@ regionmeasure regionmeasure]]];
(*the 2dregion*)
region3d = 
RegionProduct[region, 
BoundaryMeshRegion[{{0}, {1}}, Point[{{1}, {2}}]]];(*generates a 3d region*)
region3d2 = 
TransformedRegion[region3d, 
RotationTransform[Pi/2, {0, 1, 0}, {0, 0, 0.5}]](*generates the rotated  region*)

Now we have the two regions in hand, it seems a simple task to get their intersection with the built-in function RegionIntersection. But this function do not support the MeshRegion format in 3D!

(2) I convert the 2d region of letter "A" into many polygons by first generating randompoints within the region then using BoundingRegion. But this will make hundreds of polygons to achieve a not so bad covering of the original letter, and become impossible to calculate their union and intersection in 3d.

(3) I want to just export the 3d letter "A" denoted by region3d in (1) and simply manipulate it in other CAD software. But although Export claims to support export MeshRegion object into STL file, it does not. Now I am completely out of idea...

Answer 1

As I continuing seeking the final answer, I came up with some solution lacking smoothness over the surface.

The first one just discretize the two letter, finding the discrete points that is in the disired area.

showtwoletter[a_, b_, n_] := 
Module[{t1 = Text[Style[a, Bold, 50]], t2 = Text[Style[b, Bold, 50]],
data1, data2, points1, points2}, 
data1 = ImageData[
Binarize[
ImageResize[
ImageCrop[Image[Graphics[t1, ImageSize -> Large]]], {n, n}]]];
data2 = 
ImageData[
Binarize[
ImageResize[
ImageCrop[Image[Graphics[t2, ImageSize -> Large]]], {n, n}]]];
points1 = 
Drop[DeleteDuplicates[
Flatten[Table[
If[data1[[i, j]] == 0, {i - n/2, j - n/2, k - n/2}], {i, 1, 
n}, {j, 1, n}, {k, 1, n}], 2]], 1];
points2 = 
Drop[DeleteDuplicates[
Flatten[Table[
If[data2[[i, j]] == 0, {i - n/2, j - n/2, k - n/2}], {i, 1, 
n}, {j, 1, n}, {k, 1, n}], 2]], 1];
points2 = points2 /. {x_, y_, z_} -> {x, z, y};
Graphics3D[
Cuboid[#, # + {1.1, 1.1, 1.1}] & /@ Intersection[points1, points2]]
] 

The final result is shown below:

The second method works only on letters without curly boundaries. It first change the two letters into a set of polygons in 2d (for letters with curly boundaries, this would have to generate hundreds of polygons to cover it, so is computationally difficult). Then transform these polygons into prisms in 3d, and we will be able to find their intersection. However after rotating one letter and finding their intersection, the desired region is no longer a graphics3d object, so it needs to be discretized in order to be viewed. The DiscretizedRegion function would put mesh on the edges of the region, screw it up...

t1 = Text[Style["K", Bold, "Graphics"]];
t2 = Text[Style["Y", Bold, "Graphics"]]; regionmeasure1 = 
Flatten[Differences /@ 
Transpose[
List @@ BoundingRegion[
RandomPoint[
RegionBoundary@
BoundaryDiscretizeGraphics[t1, _Text, MaxCellMeasure -> 0.01],
10000]]]];
regionmeasure2 = 
Flatten[Differences /@ 
Transpose[
List @@ BoundingRegion[
RandomPoint[
RegionBoundary@
BoundaryDiscretizeGraphics[t2, _Text, 
MaxCellMeasure -> 0.01], 10000]]]];
region1 = 
TransformedRegion[
DiscretizeGraphics[t1, _Text, MaxCellMeasure -> 0.5], 
ScalingTransform[Reverse[1/Times @@ regionmeasure1 regionmeasure1]]]
region2 = 
TransformedRegion[
DiscretizeGraphics[t2, _Text, MaxCellMeasure -> 0.5], 
ScalingTransform[Reverse[1/Times @@ regionmeasure2 regionmeasure2]]]
region13d = 
RegionUnion @@ (RegionProduct[#, Line[{{0}, {1}}]] & /@ 
MeshPrimitives[region1, 2]);
region23d = 
TransformedRegion[
RegionUnion @@ (RegionProduct[#, Line[{{0}, {1}}]] & /@ 
MeshPrimitives[region2, 2]), 
RotationTransform[Pi/2, {0, 1, 0}, {0, 0, 0.5}]];
finalregion = RegionIntersection[region13d, region23d];
DiscretizeRegion[finalregion, MeshQualityGoal -> "Maximal", 
MaxCellMeasure -> 2, PerformanceGoal -> "Quality", 
MaxCellMeasure -> 0.0001]