How can I wrap text around a circle?

Question

How can I wrap text around a circle?

For example: the text in the sectors of this chord plot.

Perhaps one could use FilledCurve[] and then apply a GeometricTransformation[]?

Answer 1

The following response borrows shamelessly from Mr.Wizard:

Manipulate[
  Graphics[{{Dashed, If[circle, Circle[{0, 0}, r], {}]},
  Rotate[MapThread[
      Rotate[Text[Style[#, FontFamily -> "Courier", fs], #2], 
      90° - #3] &, {txt, {-r Cos[#], r Sin[#]} & /@ (range =
      Range[0, arc, arc/(Length@txt - 1)]), range}], θ, {0,
      0}]},
  ContentSelectable -> True,
  PlotRange -> 3,
  PlotRangePadding -> .5,
  ImageSize -> {500, 400}, Axes -> axes],
  {{fs, 20, "font size"}, 5, 50, Appearance -> "Labeled"},
  {{r, 2, "radius"}, 0.1, 3, Appearance -> "Labeled"},
  {{arc, 2.5, "arc length"}, 0, 2 π, Appearance -> "Labeled"},
  {{θ, 0, "location on arc"}, 0, 2 π},
  {{circle, True}, {True, False}},
  {{axes, True}, {True, False}},
  Initialization :> {txt = "This is some text to wrap" // Characters;}
]

Note: "Arc length" is based on the unit circle. $2 \pi$, or approximately 6.28 corresponds to a $360^\circ$ arc on the unit circle. The actual full arc length will be $2\pi r$.

Answer 2

This places a string on the outside of a unit circle. It works for variable width fonts.

circularText[str_, ang : {a0_, a1_} : {0, 2 Pi}, scale:(_?NumericQ): 1] := 
 Module[{text, curves, pts, xrange, ymin, xrlst, subgroups, maxwidth, centers},
  (* transform string to FilledCurves *)
  text = ImportString[
     ExportString[Style[str, Bold, FontFamily -> "Helvetica", FontSize -> 12], "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {curves, pts} = 
   Flatten[Cases[text, FilledCurve[a_, b_] :> {a, b}, 
     Infinity], {{2}, {1, 3}}];

  (* Find coordinate range for each character *)
  xrlst = {Min[#1], Max[#1]} & /@ pts[[All, All, 1]];
  xrange = {Min[xrlst[[All, 1]]], Max[xrlst[[All, 2]]]};
  ymin = Min[pts[[All, All, 2]]];

  (* collect curves whose xrange overlap. They indicate letters with holes. *)
  subgroups = Gather[Range[Length[xrlst]],
    (IntervalMemberQ[#1, #2] || 
         IntervalMemberQ[#2, #1]) & @@ {Interval[xrlst[[#1]]], 
       Interval[xrlst[[#2]]]} &];
  xrlst = (Interval @@ xrlst[[#]])[[1]] & /@ subgroups;

  (* calculate maximum width of all letters, and centers of each letter *)
  maxwidth = Max[xrlst[[All, 2]] - xrlst[[All, 1]]];
  centers = Mean /@ xrlst;

  (* translate and rescale points *)
  pts = MapIndexed[
    pts[[#1]] /. {a_, b_?NumericQ} :> {a - centers[[#2[[1]]]], b - ymin}/maxwidth/
          Length[subgroups] (a1 - a0) scale + {0, 1} &, subgroups];

  (* plot text *)
  Graphics[{MapThread[
     Rotate[FilledCurve[#1, #2], #3, {0, 0}] &, {curves[[#]] & /@ 
       subgroups, pts, -Rescale[centers, xrange, ang]}]}]]

Here, str is the string you want to place along the circle, and scale is the scaling of the text.

Example

string = "The brown fox jumped over the lazy dog";

circularText[string]

Edit

I've adapted the code. You can now specify an arc along which you want to place the text, for example

circularText[string, {-Pi/4, Pi}]

Answer 3

Here is a starting point:

txt = "This is some text to warp." // Characters;
arc = 1;
range = Range[0, arc, arc/(Length@txt - 1)];
coords = {-Cos[#], Sin[#]} & /@ range;
Graphics[
  MapThread[
   Rotate[Text[Style[#, FontFamily -> "Courier"], #2], 90° - #3] &,
   {txt, coords, range}]
]

Answer 4

My solution, which does not try to place the letters, but rather transform the space they inhabit. This has an extra feature/bug/property that parallel lines in the letters may no longer be parallel after the transformation.

WrapText[str_, transformation_] := Module[{text},
  text = Style[str, Bold, FontFamily -> "Helvetica", FontSize -> 12, LineBreakWithin -> False];
  Graphics@Cases[
    ImportString[ExportString[text, "PDF"], 
       "TextMode" -> "Outlines"][[1, 1]],
     FilledCurve[a__] :> FilledCurve[a],
     Infinity] /. transformation 
  ]

To run it we need to supply the appropriate transformation (it may be necessary to fiddle with the constants a bit):

transformationCircle = {x_Real, y_Real} :> {Cos[-x/(12 Pi)]*(y + 2), Sin[-x/(12 Pi)]*(y + 2)}; 
WrapText["The quick brown fox jumps over the lazy dog", transformationCircle]

Will produce:

It can do more funky stuff though:

transformationSpiral = {x_Real, y_Real} :> {Cos[-x/(12 Pi)]*(y + 4 + x/18),  Sin[-x/(12 Pi)]*(y + 4 + x/18)};
WrapText["All human beings are born free and equal in dignity and rights. They are endowed with reason and conscience and should act towards one another in a spirit of brotherhood.", transformationSpiral]

Results into:

Answer 5

Modifying an example from the help on FilledCurve[]:

Module[{l = 
   Cases[First[First[ImportString[ExportString[Style["CIRCLE", Bold, FontFamily -> "Courier", 
         FontSize -> 12], "PDF"], "TextMode" -> "Outlines"]]], 
   FilledCurve[a__] :> {EdgeForm[Black], Yellow, FilledCurve[a]}, Infinity]}, 
 Animate[Graphics[{Red, Circle[{0, 0}, 1.5], {l /. {x_Real, y_Real} :> 
       y^(1/10) { Sin[t + 1/100 Norm[x, y]], 
                  Cos[t + 1/100 Norm[x, y]]}}}], {t, 0, 2 Pi}, 
  AnimationRunning -> False, SaveDefinitions -> True]]

Answer 6

Here's an approach that works alright with both fixed width and proportional fonts, and gives you some flexibility when it comes to the style of the text. It uses the common, hacky trick of rasterizing the text beforehand to work out the approximate sizes of the letters, and it uses the Framed option to rasterize all the letters at once so we can pick the frames out of the ImageData using cases (which is much, much faster than rasterizing the letters one by one).

sizes[text_String, style_] :=
 With[{data =
    ImageData@Rasterize@Row[Map[
        Framed[Text[Style[#1, style]], FrameStyle -> Magenta] &,
        Characters@text], " "],
   pixel = List @@ (N@Magenta) 
   },
  With[{row = Part[data, First@First@Position[data, pixel, 2, 1]]},
   Part[Length /@ Split[row], Span[1, All, 2]]]]

The frames are magic pink to make them even easier to pick out. Then all that remains is to draw the text on the circle. I use the relative sizes of the letters to work out the angles, and use Scaled with the FontSize option to Style to make the letters the right size in the graphics. I also introduced some (hard-coded) fudge factors to make things look OK and not get cut off; playing with them some more (or better, setting up a Manipulate to do it interactively!) may get you results you like better.

circularize[text_String, style_: "Subtitle"] :=
 With[{sizes = sizes[text, style], n = StringLength@text, 
   imageSize = 400},
  With[{
    angles = 2 Pi (Accumulate@sizes - First@sizes)/Total[sizes],
    scale = 0.8*2 Pi/n
    },
   Graphics[
    MapThread[
     Rotate[
       Text[Style[#1, style, FontSize -> Scaled[scale]], 
        Through[{Sin, Cos}@#2]], -#2] &,
     {Characters@text, angles}]]
   ]]

EDIT because this answer is useless without pics!