Description
This project was prompted by this question on Mathematics chat, to which I posted this reply. I saw that the resultant diagram, if colored properly, looked somewhat like the Yellow Brick Road from The Wizard of Oz, and so I set out to write code to draw text along a path to get the first example below.
This code operates similarly to Michael E2's, but it does not solve a differential equation, so I hope it might be a bit faster. I guess that this depends on the function defining the curve being followed. If the curve being followed is defined by an InterpolatingFunction, then this approach should be faster.
This code is also organized into functions that might be easier to use.
GetMetrics[curve, arg1, arg2, n]
This function processes the segment of curve between arg1 and arg2. It breaks that segment up into n pieces and returns the cumulative distances to these segments along with curve, arg1, and arg2 for later use by CurveText and LoopText.
If arg1 is greater than arg2, then CurveText and LoopText will render on the other side of curve going in the opposite direction.
FindArg[metrics, dist, loop]
This function is usually ony called by CurveText and LoopText. It takes the metrics returned by GetMetrics and finds the point that corresponds to dist along curve. If loop is True, then dist is reduced modulo the length of curve.
GetPDF[text]
This function returns information about the layout and outlines of text. It does this by converting text to a PDF and reading it back in. This information will later be passed to CurveText and LoopText.
CurveText[metrics, pdf, scale, toff, noff]
This function uses the metrics from GetMetrics and the pdf from GetPDF to return a Graphics object that will render text mapped along curve.
scale determines the rendered size of text; a scale of 1 will fill the entire length of curve.
toff is the tangential offset of text along curve; 1 offsets by the length of curve.
noff is the normal offset of text from curve; 1 offsets by the height of text.
If toff is negative or scale plus toff is greater than 1, rendering will be extrapolated as far as curve will allow.
LoopText[metrics, pdf, scale, toff, noff]
This function operates almost identically to CurveText except that out of bound rendering is wrapped modulo the length of curve. LoopText assumes that curve[arg1] and curve[arg2] are equal and that curve'[arg1] and curve'[arg2] are in exactly the same direction.
Here is the code that implements these functions:
GetMetrics[curve_, arg1_, arg2_, n_] :=
Module[{dist = N[0], dlist, last = curve[arg1], next, k},
dlist = First@First@Rest@Reap[
Sow[dist];
For[k = 1, k <= n, ++k,
next = curve[arg1 + (arg2 - arg1) k/n];
Sow[dist += Norm[next - last]]; last = next]];
{curve, arg1, arg2, dlist}]
FindArg[metrics_, dist_, loop_] :=
Module[{curve, arg1, arg2, dlist, find, lo, hi, n, dlo, dhi, mid, dst, arg},
{curve, arg1, arg2, dlist} = metrics;
find = If[loop, Mod[dist, Last@dlist], dist];
n = Length[dlist] - 1;
lo = 1; hi = n + 1;
dlo = dlist[[lo]]; dhi = dlist[[hi]];
While[hi - lo > 1,
mid = Floor[(hi + lo)/2]; dst = dlist[[mid]];
If[find >= dst,
lo = mid; dlo = dst,
hi = mid; dhi = dst]];
If[dhi > dlo,
arg1 + (arg2 - arg1) (lo - 1 + (find - dlo)/(dhi - dlo))/n,
If[n > 0, arg1 + (arg2 - arg1) (lo - 1)/n, arg1]]]
GetPDF[text_] := ImportString[ExportString[text, "PDF"], "PDF"]
CurveText[metrics_, pdf_, scale_, toff_, noff_, loop_: False] :=
Module[{curve, length, grfx, range, width, height, slw, nh, tl, unit, newpt},
curve = First@metrics;
length = Last@Last@metrics;
grfx = First@First@pdf;
range = PlotRange /. First@AbsoluteOptions[pdf, PlotRange];
{width, height} = range.{-1, 1};
slw = scale length/width;
nh = noff height;
tl = toff length;
unit = If[Greater @@ metrics[[2 ;; 3]],
Normalize[#].{{0, -1}, {1, 0}} &,
Normalize[#].{{0, 1}, {-1, 0}} &];
newpt = ({1, slw (#2 + nh)}.({curve[#], unit[curve'[#]]} &
@FindArg[metrics, slw #1 + tl, loop])) &;
(grfx /. {x_Real, y_Real} :> newpt[x, y])]
LoopText[metrics_, pdf_, scale_, toff_, noff_] :=
CurveText[metrics, pdf, scale, toff, noff, True]
A Change for Version 12.2
Lou notes that as of Version 12.2, the default for Importing PDF is bitmap. To get outlines, we need to use
GetPDF[text_] :=
ImportString[ExportString[text, "PDF"], "PageGraphics",
"TextOutlines" -> True]
This does not seem to work on earlier versions, so I have not included this change in the code above.
Examples
Follow the Yellow Brick Road
On Mathematics chat, it was noted that the lines parametrized by
$$
r\cos(\theta-a)=a\tag1
$$
for $a\in[0,4\pi]$ form a spiral and it was asked what that spiral was. After replying that the envelope was parametrized by
$$
(a\cos(a)-\sin(a),a\sin(a)+\cos(a))\tag2
$$
I noted that the result, if colored properly, was reminiscent of the Yellow Brick Road from The Wizard of Oz. I set out to add text along the path.
envelope = {# Cos[#] - Sin[#], # Sin[#] + Cos[#]} &;
metrics = GetMetrics[envelope, 0, 4 Pi, 100];
pdf1 = GetPDF[Style["Follow the Yellow Brick Road ", Lighter[Orange, 1/4],
FontSize -> 36, FontFamily -> "Times"]];
pdf2 = GetPDF[Style["There's No Place Like Home", Lighter[Orange, 1/4],
FontSize -> 36, FontFamily -> "Times"]];
ParametricPlot[envelope[t], {t, 0, 4 Pi},
PlotStyle -> {Directive[Lighter[Orange, 1/4], Thickness[1/200]]},
Prolog -> {Darker[Yellow, 1/6], Thickness[1/600],
Line[{{# Cos[#], # Sin[#]} + 100 {Sin[#], -Cos[#]},
{# Cos[#], # Sin[#]} - 100 {Sin[#], -Cos[#]}}&
/@ Range[Pi/180, 4 Pi, Pi/90]]},
Epilog -> {CurveText[metrics, pdf1, 1/2, 1/4, -1/6],
CurveText[metrics, pdf2, 1/4, 3/4, -1/6],
CurveText[metrics, pdf2, 1/4, 3/4, 5/6],
CurveText[metrics, pdf2, 1/4, 3/4, 11/6]},
ImageSize -> 400]
Lissajous Live
This is the curve and text from Michael E2's answer, but I have put text on both sides of the curve.
lissajous[x_] := {Cos[2 Pi x], Sin[6 Pi x]}
fmetrics = GetMetrics[lissajous, 0, 1, 100];
rmetrics = GetMetrics[lissajous, 1, 0, 100];
pdf = GetPDF["some moveable text"];
Manipulate[
ParametricPlot[lissajous[t], {t, 0, 1},
Epilog -> {Dynamic[LoopText[fmetrics, pdf, s, t, n]],
Dynamic[LoopText[rmetrics, pdf, s, 1 - s - t, n]]},
ImageSize -> 400],
{{s, 1/10}, 0, 1}, {{t, 5/8}, 0, 1}, {{n, -1/10}, -1, 1}]
