Creating a custom e-seal

Question

Well, the question is obvious: how can I create the following e-seal (with the rotated wrapped text, inserted image etc) with Mathematica?

The central image is the following

So, the following issues should be solved:

(1). How to embed an image inside circles.

(2). How to wrap text along a circle with a specific radius and orientation. Any good ideas?!

Here is my try

g1 = Circle[{0, 0}, 1.3];
g2 = Circle[{0, 0}, 1.6];
g3 = Circle[{0, 0}, 1.7];
plot = Graphics[{{Thickness[0.008], g1}, {Thickness[0.008], g2}, {Thickness[0.018], g3}, Inset[img, {0, 0}]}];
Show[plot, ImageSize -> 300]

Now two main things are missing:

(a) The wrapped text inside the circles.

(b) A way to rotate the central image and control its relative size.

Any suggestions?

Possible duplicate? And, while this is not a duplicate, it seems to be filled with good ideas. — aardvark2012, Nov 02 '17 at 10:19
@aardvark2012 Well, this is not a simple duplicate, since it involves much more complex tasks. — Vaggelis_Z, Nov 02 '17 at 11:54
It's not "much more complex". The rest is just creating circles with Graphics and inserting the image into it using Inset. I think you should show us what you have tried because I have a hard time believing that with a reputation score of more than 3000 and after having asked over 150 questions, you do not know how to even get started on this. Maybe others don't feel the same way, but I would really like to see an attempt here so that I can see what the issues really are that need solving, or otherwise I am inclined to consider it a duplicate. — C. E., Nov 02 '17 at 12:17
@C.E. You are absolutely right, I should have posted a try by myself (please see the edit). — Vaggelis_Z, Nov 02 '17 at 13:27

LLlAMnYP · Accepted Answer · 2017-11-02T16:00:31.023

Credit goes to this answer in the linked thread, but I used a somewhat simpler geometric transformation to wrap the text around a circle.

Maybe this will get you started (updated to include rotation of central image, clear and reload all symbols):

Clear[a, plot, intermediate]

pts = Point[1.45 ({Cos@#, Sin@#} & /@ {-Pi/2 + 1/2, 3 Pi/2 - 1/2})]
g1 = Circle[{0, 0}, 1.3, {-Pi/2 + 1/2, 3 Pi/2 - 1/2}];
g2 = Circle[{0, 0}, 1.6];
g3 = Circle[{0, 0}, 1.7];
plot[a_] = 
  Graphics[{{Thickness[0.008], g1}, {Thickness[0.008], 
     g2}, {Thickness[0.018], g3}, 
    Inset[img, {0, 0}, Center, 2, {Cos[a], Sin[a]}]}];

intermediate[a_] = Show[plot[a], ImageSize -> 300]
Clear[text]

text[txt_, p1_, p2_, p3_, p4_] :=
 With[{l = text[txt]},
  {{l /. {x_Real, y_Real} :> (p1 + y)/
       p2 {Sin[1/p3 x + p4], Cos[1/p3 x + p4]}}}]
text[txt_String] := 
 text[txt] = 
  Cases[First[
    First[ImportString[
      ExportString[
       Style[txt, Bold, FontFamily -> "Calibri", FontSize -> 12], 
       "PDF"], "TextMode" -> "Outlines"]]], 
   FilledCurve[a__] :> {EdgeForm[Black], Gray, FilledCurve[a]}, 
   Infinity]

Manipulate[
 Show[{intermediate[p5], 
   Graphics[{PointSize[Large], pts}, PlotRange -> 2], 
   Graphics[text["This is a test", p1, p2, p3, p4]]}], {{p1, 33}, 1, 
  50}, {{p2, 27}, 1, 50}, {{p3, 22}, 1, 40}, {{p4, -1}, -Pi, Pi}, {p5,
   0, 2 Pi}]

To get the text to wrap around the other way, you can do the following:

text2[txt_, p1_, p2_, p3_, p4_] :=
 With[{l = text[txt]},
  {{l /. {x_Real, y_Real} :> (p1 + y)/
       p2 {-Sin[1/p3 x + p4], Cos[1/p3 x + p4]}}}]
Manipulate[
 Show[{intermediate[p5], 
   Graphics[{PointSize[Large], pts}, PlotRange -> 2], 
   Graphics[text2["Test", p1, p2, p3, p4]]}], {{p1, -38.4}, -50, 
  50}, {{p2, -27}, -50, 50}, {{p3, 22}, 1, 40}, {{p4, 2.8}, -Pi, 
  Pi}, {p5, 0, 2 Pi}]

This is just a slightly modified geometric transformation.

The Manipulate is just a means to play around with the parameters, once you find appropriate values, you can stick Graphics[{text[...], text[...], text2[...]}] inside theShow` with appropriate numeric values and export the result.

That's almost perfect! However the most difficult part is still missing. That is the text at the bottom between the two dots, where the text splits into two lines. I have no idea how to achieve this. — Vaggelis_Z, Nov 02 '17 at 15:52
@Vaggelis_Z added that as well and a short pointer on how to proceed. Time to head home, I'm sure there's enough info to get to your desired result now. — LLlAMnYP, Nov 02 '17 at 16:01

score 3 · Answer 2 · answered Nov 02 '17 at 11:13

A lazy method for regenerating the shamrock would be to start from the image in the OP and use FourierCurve[] on the result of applying ImageMesh[] to it:

(* https://mathematica.stackexchange.com/a/23302 *)
PolygonCentroid[pts_?MatrixQ] := With[{dif = Map[Det, Partition[pts, 2, 1, {1, 1}]]}, 
       ListConvolve[{{1, 1}}, Transpose[pts], {-1, -1}].dif/(3 Total[dif])]

FourierCurve[x_, m_, t_, tol_: 0.01] := Module[{rat = Rationalize[#, tol] &, fc},
  fc = Take[Chop[Fourier[x, FourierParameters -> {-1, 1}]], Min[m, Ceiling[Length[x]/2]]];
  2 rat[Abs[fc]].Cos[Pi (2 Range[0, Length[fc] - 1] t - rat[Arg[fc]/Pi])]]

img = Import["https://i.stack.imgur.com/dllfB.png"];
p1 = ConnectedMeshComponents[ImageMesh[ColorNegate[img]]];

sh = MeshCoordinates[p1[[1]]]; st = MeshCoordinates[p1[[2]]];
ph = PolygonCentroid[sh]; pt = PolygonCentroid[st];

ParametricPlot[Evaluate[{ph + (FourierCurve[#, 30, t] & /@ (Transpose[sh] - ph)), 
                         pt + (FourierCurve[#, 30, t] & /@ (Transpose[st] - pt))}],
               {t, 0, 1}, Axes -> None, Frame -> True, PlotPoints -> 75]

shamrock

Nice but this is not what I want. I don't want to recreate the image with Mathematica. I just want to use the original image and place it inside some circles and wrapped text! — Vaggelis_Z, Nov 02 '17 at 11:22
Then your question is indeed a dupe of the first question linked in the comments. — J. M.'s missing motivation, Nov 02 '17 at 11:23
It's not really a duplicate because that question only deals with the wrapped text, while the present problem has more issues (e.g., placement of a figure, wrapped text, etc). So this is a much more complex question. — Vaggelis_Z, Nov 02 '17 at 11:30

Creating a custom e-seal

2 Answers2