How can I wrap text around a circle?

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;}
]

curved text

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


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]

Mathematica graphics

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}]

Mathematica graphics


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}]
]

Mathematica graphics

Tags:

Text

Graphics