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