6
$\begingroup$

The desire font as in the document which could be found by FindShortestCurve -> Scope -> Mesh Region -> the last example

https://reference.wolfram.com/language/ref/FindShortestCurve.html#2042635632

enter image description here

enter image description here

RegionProduct could not get such result.

reg1 = BoundaryDiscretizeGraphics[
   Text[Style["a", FontFamily -> "Helvetica"]], _Text];
RegionProduct[reg1, Line[{{0.}, {1.}}]]

enter image description here

Improve this question
$\endgroup$
4
  • $\begingroup$ @user21, the example is available in 14.3 for FindShortestCurve in Scope > Mesh regions, then last example (3D). $\endgroup$ Commented Feb 25 at 20:19
  • $\begingroup$ @Domen, thanks. My bad. I looked at FindShortestTour. $\endgroup$ Commented Feb 25 at 22:21
  • $\begingroup$ Do the 14.3 functions SmoothMesh or SubdivisionRegion give smooth meshes that you want? $\endgroup$ Commented Feb 25 at 23:14
  • $\begingroup$ @tad Thanks. My goal is not to smooth the font, I want to cut the boundary of the sharp edge to a slop. $\endgroup$ Commented Feb 26 at 0:32

3 Answers 3

Reset to default
4
$\begingroup$

Simplified:

Here is a simplified workflow:

Needs["OpenCascadeLink`"]
reg1 = BoundaryDiscretizeGraphics[
   Text[Style["a", FontFamily -> "Helvetica"]], _Text];
mp = MeshPrimitives[reg1, {1, All}, "Multicells" -> True];
faces = OpenCascadeShapeFace[OpenCascadeShape[#]] & /@ mp;
(* this is the manual part: sort and construct the region *)
f3 = OpenCascadeShapeDifference @@ faces[[{2, 1}]];
(*OpenCascadeShapeSurfaceMeshToBoundaryMesh[f3]["Wireframe"]*)
sweep = OpenCascadeShapeLinearSweep[f3, {{0, 0, 0}, {0, 0, 1}}];
(*OpenCascadeShapeSurfaceMeshToBoundaryMesh[sweep]["Wireframe"]*)
cham = OpenCascadeShapeChamfer[sweep, 0.075];
bmesh = OpenCascadeShapeSurfaceMeshToBoundaryMesh[cham];
BoundaryMeshRegion[bmesh]

enter image description here

Original:

I do not know, how that chamfered mesh was created. Here is a way to do it, after a fashion...

We create the boundary discretized graphics and extract the lines that make up this:

dgr = BoundaryDiscretizeGraphics[
   Text[Style["a", FontFamily -> "Helvetica"]]];
lns = MeshPrimitives[RegionBoundary[dgr], 1];
Length[lns]

Now, we re-create this in OpenCascade. There seems to be some problem with the original data, so we have to do it on a lower level than I'd like to.

We manually get the outer boundary:

outer = lns[[29 ;; -1]];
Graphics[outer]

enter image description here

And the inner one:

inner = lns[[1 ;; 28]];
Graphics[inner]

enter image description here

Next, we regenerate the shape:

Needs["OpenCascadeLink`"]
w1 = OpenCascadeShapeWire[OpenCascadeShape /@ outer];
f1 = OpenCascadeShapeFace[w1];
w2 = OpenCascadeShapeWire[OpenCascadeShape /@ inner];
f2 = OpenCascadeShapeFace[w2];
f3 = OpenCascadeShapeDifference[f1, f2];

If you want to look at that:

OpenCascadeShapeSurfaceMeshToBoundaryMesh[f3]["Wireframe"]

enter image description here

Next, we sweep it to the 3D dimension

sweep = OpenCascadeShapeLinearSweep[f3, {{0, 0, 0}, {0, 0, 1}}];

And look at it:

OpenCascadeShapeSurfaceMeshToBoundaryMesh[sweep]["Wireframe"]

enter image description here

Now, we add the champfer:

cham = OpenCascadeShapeChamfer[sweep, 0.075];

This is about the maximum you can add - otherwise the geometry runs into trouble.

(bmesh = OpenCascadeShapeSurfaceMeshToBoundaryMesh[cham])["Wireframe"]

enter image description here

And finally the boundary mesh region:

BoundaryMeshRegion[bmesh]

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ Very nice. Any idea why OpenCascadeShapeChamfer fails when I construct my OpenCascadeShape this way? In[17]:= reg1 = BoundaryDiscretizeGraphics[ Text[Style["a", FontFamily -> "Helvetica"]], _Text]; mr = Region`Mesh`TriangulateMeshCells[ RegionBoundary[RegionProduct[reg1, Line[{{0.}, {1.}}]]], MaxCellMeasure -> \[Infinity]]; expr = OpenCascadeShape[ BoundaryMeshRegion[MeshCoordinates[mr], MeshCells[mr, 2]]]; OpenCascadeShapeChamfer[expr, 0.05] Out[20]= $Failed $\endgroup$ Commented 2 days ago
  • $\begingroup$ @GregHurst, I think that's because the boundary discretized graphics is bad and the reason why I had to resort to manually re-create the geometry. Even FindMeshDefects[mr] hangs. $\endgroup$ Commented 2 days ago
  • $\begingroup$ @user21 Thanks! It seems that the chamfer is not so robust. For the simple regular polygon,it work for n=70 but not for n=60 etc. Needs["OpenCascadeLink`"]; n = 70; pts = CirclePoints[n]; face = OpenCascadeShapeFace@OpenCascadeShape[Polygon[pts]]; shape = OpenCascadeShapeLinearSweep[face, {{0, 0, 0}, {0, 0, 1}}]; cham = OpenCascadeShapeChamfer[shape, .25]; OpenCascadeShapeSurfaceMeshToBoundaryMesh[cham] // BoundaryMeshRegion $\endgroup$ Commented yesterday
8
$\begingroup$

Updated version:

This version works also with characters that consist of several parts or even with several characters.

er[tr_, x_] := (1 - 2*Boole[PositivelyOrientedPoints[#]]) x*
     Normalize[#[[2]] - TriangleCenter[#, "Incenter"]] + #[[2]] &@tr

ff2[ch_, e_, pts_, pts1_, pts2_] := 
 Block[{n1, n2}, 
  n1 = er[#, e] & /@ Partition[pts[[pts1]], 3, 1, 1] // RotateRight;
  n2 = (er[#, -e] & /@ Partition[pts[[#]], 3, 1, 1] // 
       RotateRight) & /@ pts2;
  {Polygon[
      Flatten[#, 1] & /@ 
       Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[#]], 2, 1,
           1], Reverse /@ 
          Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[#]], 2, 1, 
           1]}]] & /@ pts2, 
   Polygon[Flatten[#, 1] & /@ 
     Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[pts1]], 2, 
        1, 1], Reverse /@ 
        Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[pts1]], 2, 1, 1]}]],
    If[n2 === {}, Polygon[(Append[#, 0] + {0, 0, -e} & /@ n1)], 
    Polygon[(Append[#, 0] + {0, 0, -e} & /@ 
        n1) -> ((Append[#, 0] + {0, 0, -e} & /@ #) & /@ n2)]], 
   If[n2 === {}, Polygon[(Append[#, 0] + {0, 0, 1 + e} & /@ n1)], 
    Polygon[(Append[#, 0] + {0, 0, 1 + e} & /@ 
        n1) -> ((Append[#, 0] + {0, 0, 1 + e} & /@ #) & /@ n2)]], 
   Polygon[Flatten[#, 1] & /@ 
       Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[#[[1]]]], 
          2, 1, 1], 
         Reverse /@ 
          Partition[Append[#, 0] + {0, 0, -e} & /@ #[[2]], 2, 1, 
           1]}]] & /@ Thread[{pts2, n2}], 
   Polygon[Flatten[#, 1] & /@ 
       Thread[{Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[#[[1]]]], 
          2, 1, 1], 
         Reverse /@ 
          Partition[Append[#, 0] + {0, 0, 1 + e} & /@ #[[2]], 2, 1, 
           1]}]] & /@ Thread[{pts2, n2}], 
   Polygon[Flatten[#, 1] & /@ 
     Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[pts1]], 2, 
        1, 1], Reverse /@ 
        Partition[Append[#, 0] + {0, 0, -e} & /@ n1, 2, 1, 1]}]], 
   Polygon[Flatten[#, 1] & /@ 
     Thread[{Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[pts1]], 2, 
        1, 1], Reverse /@ 
        Partition[Append[#, 0] + {0, 0, 1 + e} & /@ n1, 2, 1, 1]}]]}]

ff3[ch_, e_] := 
 Block[{r, data, pts}, 
  r = BoundaryDiscretizeGraphics[
    Text[Style[ch, FontFamily -> "Helvetica"]], _Text];
  data = 
   BoundaryDiscretizeGraphics[
     Text[Style[ch, FontFamily -> "Helvetica"]], _Text] // Show;
  pts = data[[1, 1]];
  
  ff2[ch, e, 
     pts, #[[1]], #[[2]]] & /@ (Join[{First@#, 
        Rest@#} & /@ (Cases[#, Line[x__] :> x, All] & /@ 
        Cases[data, _FilledCurve, All]), 
     If[# === {}, {}, 
        Append[{#}, {}] & /@ #[[1]]] &@((Cases[data, 
         Polygon[x__] :> x, All]))])
  ]

Examples:

Graphics3D[ff3["‰", 0.2], Boxed -> False]
Graphics3D[ff3["i~", 0.2], Boxed -> False]
Graphics3D[ff3["8€", 0.2], Boxed -> False]
Graphics3D[ff3["φπ", 0.2], Boxed -> False]

enter image description here

Old version:

This does not work with characters that consist of several parts like "i", or %. For those characters the mesh should be divided into pieces and code executed separately for each piece.

er[tr_, x_] := (1 - 2*Boole[PositivelyOrientedPoints[#]]) x*
     Normalize[#[[2]] - TriangleCenter[#, "Incenter"]] + #[[2]] &@tr

ff[ch_, e_] := 
 Block[{r, data, pts, pts1, pts2, n1, n2}, 
  r = BoundaryDiscretizeGraphics[
    Text[Style[ch, FontFamily -> "Helvetica"]], _Text];
  data = 
   ToExpression[
    StringReplace[ToString[r, InputForm], 
     "BoundaryMeshRegion" -> "List"]];
  pts = data[[1]];
  pts1 = DeleteDuplicates[Flatten[List @@ data[[2, 1]]]];
  pts2 = DeleteDuplicates[Flatten[List @@ #]] & /@ data[[3 ;; -2, 1]];
  n1 = er[#, e] & /@ Partition[pts[[pts1]], 3, 1, 1] // RotateRight;
  n2 = (er[#, -e] & /@ Partition[pts[[#]], 3, 1, 1] // 
       RotateRight) & /@ pts2;
  {Polygon[
      Flatten[#, 1] & /@ 
       Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[#]], 2, 1,
           1], Reverse /@ 
          Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[#]], 2, 1, 
           1]}]] & /@ pts2, 
   Polygon[Flatten[#, 1] & /@ 
     Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[pts1]], 2, 
        1, 1], Reverse /@ 
        Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[pts1]], 2, 1, 1]}]],
    If[n2 === {}, Polygon[(Append[#, 0] + {0, 0, -e} & /@ n1)], 
    Polygon[(Append[#, 0] + {0, 0, -e} & /@ 
        n1) -> ((Append[#, 0] + {0, 0, -e} & /@ #) & /@ n2)]], 
   If[n2 === {}, Polygon[(Append[#, 0] + {0, 0, 1 + e} & /@ n1)], 
    Polygon[(Append[#, 0] + {0, 0, 1 + e} & /@ 
        n1) -> ((Append[#, 0] + {0, 0, 1 + e} & /@ #) & /@ n2)]], 
   Polygon[Flatten[#, 1] & /@ 
       Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[#[[1]]]], 
          2, 1, 1], 
         Reverse /@ 
          Partition[Append[#, 0] + {0, 0, -e} & /@ #[[2]], 2, 1, 
           1]}]] & /@ Thread[{pts2, n2}], 
   Polygon[Flatten[#, 1] & /@ 
       Thread[{Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[#[[1]]]], 
          2, 1, 1], 
         Reverse /@ 
          Partition[Append[#, 0] + {0, 0, 1 + e} & /@ #[[2]], 2, 1, 
           1]}]] & /@ Thread[{pts2, n2}], 
   Polygon[Flatten[#, 1] & /@ 
     Thread[{Partition[Append[#, 0] + {0, 0, 0} & /@ pts[[pts1]], 2, 
        1, 1], Reverse /@ 
        Partition[Append[#, 0] + {0, 0, -e} & /@ n1, 2, 1, 1]}]], 
   Polygon[
    Flatten[#, 1] & /@ 
     Thread[{Partition[Append[#, 0] + {0, 0, 1} & /@ pts[[pts1]], 2, 
        1, 1], Reverse /@ 
        Partition[Append[#, 0] + {0, 0, 1 + e} & /@ n1, 2, 1, 1]}]]}]

Here are some examples:

Graphics3D[ff["a", 0.2], Boxed -> False]
Graphics3D[ff["@", 0.2], Boxed -> False]
Graphics3D[ff["B", 0.2], Boxed -> False]
Graphics3D[ff["Q", 0.2], Boxed -> False]
Graphics3D[ff["&", 0.2], Boxed -> False]
Graphics3D[ff["#", 0.2], Boxed -> False]
Graphics3D[ff["§", 0.2], Boxed -> False]
Graphics3D[ff["y", 0.2], Boxed -> False]

enter image description here

enter image description here

Improve this answer
$\endgroup$
6
  • $\begingroup$ (+1) None of the available answer could make a Boundary Mesh Region for a&b, maybe we should not use the uniform factor 0.2 $\endgroup$ Commented 2 days ago
  • $\begingroup$ @cvgmt It works for me for "a&b", what do you mean? Try Graphics3D[ff3["a&b", 0.2], Boxed -> False] or if you wish MeshPrimitives[ Graphics3D[ff3["a&b", 0.2], Boxed -> False] // DiscretizeGraphics, 1] // Graphics3D. $\endgroup$ Commented yesterday
  • $\begingroup$ @cvgmt i.sstatic.net/LR1vl1Yd.png $\endgroup$ Commented yesterday
  • $\begingroup$ BoundaryMeshRegion is waterproof,which could get its Volume,not only the graphics3d. See the Volume result in my answer. $\endgroup$ Commented yesterday
  • $\begingroup$ @cvgmt I see... but I guess that is not a concern of OP to compute volume. $\endgroup$ Commented yesterday
5
$\begingroup$
  • We directly construct such region by at first contract the outer region to a small inner region and then lift such regions to three levels and build a solid.
  • Edit To get the accurately contract small region, we have to change SignedRegionDistance+ImplicitRegion to SignedRegionDistance+ContourPlot or RegionErosion.
Clear["Global`*"];
outer = BoundaryDiscretizeGraphics[
   Text[Style["a", FontFamily -> "Helvetica"]], _Text];
inner0 = 
  ContourPlot[
    SignedRegionDistance[outer]@{x, y}, {x, y} ∈ outer, 
    Contours -> {-.2}, ContourShading -> {Red, None}, 
    PlotRange -> All, MaxRecursion -> 2, PlotPoints -> 80] // 
   DiscretizeGraphics;
inner = MeshRegion[MeshCoordinates[inner0], MeshCells[inner0, 2]] // 
   BoundaryMesh;
(*inner=BoundaryDiscretizeRegion[ImplicitRegion[SignedRegionDistance[\
outer]@{x,y}<=-.2,{x,y}],MaxCellMeasure->.1];*)
(*inner=RegionErosion[outer,.2];*)
nf = inner // RegionNearest;
n = Length@MeshCells[outer, 0];
pts = MeshCoordinates[outer];
indexes = MeshCells[outer, 1, "Multicells" -> True];
regs = MeshRegion[
   Join[PadRight[#, 3, 0.] & /@ pts, PadRight[#, 3, 1.] & /@ pts, 
    PadRight[#, 3, 1.2] & /@ 
     nf /@ pts], {indexes /. {i_Integer, j_Integer} :> {i, n + i, 
        n + j, j} /. Line -> Polygon, 
    indexes /. {i_Integer, j_Integer} :> 
       Sequence @@ {{n + i, 2 n + i, n + j}, {n + j, 2 n + i, 
          2 n + j}} /. Line -> Polygon}];
{bottom, 
   top} = {MeshRegion[PadRight[#, 3, 0.] & /@ pts, 
    MeshCells[RegionProduct[outer, Point[{0.}]], 2]], 
   MeshRegion[PadRight[#, 3, 1.2] & /@ nf /@ pts, 
    MeshCells[RegionProduct[outer, Point[{0.}]], 2]]};
mr = RegionUnion[regs, bottom, top]
bm = BoundaryMeshRegion[MeshCoordinates[mr], MeshCells[mr, 2]];
bm // Volume
{bm, HighlightMesh[bm, {Style[top, Red], Style[bottom, Blue]}]}

15.3558.

enter image description here

  • for "a‰"

36.576.

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ Nice (+1). But does not work with @, &, :,%, §... There are minor (or bigger) defects. $\endgroup$ Commented 2 days ago
  • $\begingroup$ @azerbajdzan Thanks. The OpenCascadeShapeChamfer method by @user21 is powerfully for such tasks , but it seems that it does not work for the current version 14.3. $\endgroup$ Commented 2 days ago

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.