12
$\begingroup$

Charles Demuth (1883 - 1935) was an American painter who developed a style of painting known as Precisionism. Precisionist artists reduced subjects to their essential geometric shapes and were fascinated by the sleekness and sheen of machine forms.

enter image description here

Demuth's most famous painting, I Saw the Figure 5 in Gold (1928), was inspired by a poem of his friend William Carlos Williams about a firetruck rumbling through a dark city. More at The Met Fifth Avenue

Since ChatGPT told me that

"the New York City Fire Department uses a custom-designed font called FDNY Standard",

I tried to find similar fonts with

{#, Style["5", 16, FontFamily -> #]} & /@ $FontFamilies // Short

enter image description here

(13.3.0 for Mac OS X ARM (64-bit) (June 3, 2023))

five[font_] :=
  Graphics[{
    RGBColor[0.8, 0.5, 0.0],
    BoundaryDiscretizeGraphics[
     Text[Style["5", FontFamily -> font]], _Text]},
   AspectRatio -> 1.5,
   Background -> GrayLevel[0.3]]

I found two fonts which could be used for a reproduction of the Demuth 5:

Row[{five["Bodoni 72"], Spacer[10], five["Bangla MN"]}]

enter image description here

I also found this badge at the

New York City Fire Museum

enter image description here

My Request

I don't want to reproduce the complicated background, but would like to know how I can place the three diminishing fives one behind the other. If possible, also include the No. and a reddish middle bar to symbolize the firetruck.

$\endgroup$
7
  • $\begingroup$ You can delete the poem, which adds nothing here. $\endgroup$ Commented Dec 18, 2023 at 1:14
  • 1
    $\begingroup$ Done, one can easily find it in the net. $\endgroup$
    – eldo
    Commented Dec 18, 2023 at 7:03
  • 7
    $\begingroup$ I liked the poem. Sure it did not add to the question, but these artistic questions by eldo are not only for the shake of coding. At least that's my point of view $\endgroup$
    – bmf
    Commented Dec 18, 2023 at 7:04
  • 1
    $\begingroup$ @bmf: First, I should point out that I'm an art scholar (see my recent book Pixels & paintings), and know that painting (in the Art Institute of Chicago) and poem well. But I don't believe the poem belongs here because it takes time away from potential question answerers. There are far better venues for discussing that matter. $\endgroup$ Commented Dec 18, 2023 at 11:46
  • 2
    $\begingroup$ @DavidG.Stork as I said earlier, my only concern is to maintain a positive atmosphere here. So, I hope all is well and there are no misunderstandings. As for your remark ` poem doesn't belong it is for Stack Exchange reasons` I can definitely see the merit and the point you are making. $\endgroup$
    – bmf
    Commented Dec 19, 2023 at 5:22

1 Answer 1

17
$\begingroup$
  • We using Scaling Transform according to a proper center.
  • pt is the upper right corner point.
  • We draw line from pt and go to some boundary point qt of the region.
  • Extend the line pt,qt to a point center,and set the center as the center of the scaling transformation.
  • The scaling tranformation tranlate the pt to qt, that is ScalingTransform[{1, 1}*x, center]@pt == qt.
Clear["Global`*"];
reg = BoundaryDiscretizeGraphics[
   Text[Style["5", FontFamily -> "Bell MT"]], _Text];
pt = {x, y} /. 
   Last@NMaximize[{x + y, {x, y} ∈ reg}, {x, y}];
dist = SignedRegionDistance@BoundaryDiscretizeRegion@reg;
dir = AngleVector[-110 Degree];
sol = NDSolve[{r'[s] == dir, r[0] == pt, 
     WhenEvent[dist[r[s]] == 0, Sow@s]}, r, {s, 0, 20}, 
    MaxStepSize -> .01] // Reap;
index = 4;
s0 = sol[[2, 1]][[index]];
qt = pt + s0*dir;
center = pt + 1.5 (qt - pt);
scalingfactor = 
  First@SolveValues[ScalingTransform[{1, 1}*x, center]@pt == qt, x, 
    Reals];
(* scalingfactor=Norm[qt-center]/Norm[pt-center]; *)
Graphics[{RGBColor[0.8, 0.5, 0.0], reg, 
  ScalingTransform[{1, 1}*scalingfactor, center]@reg, 
  ScalingTransform[{1, 1}*scalingfactor^2, center]@reg, 
  ScalingTransform[{1, 1}*scalingfactor^3, center]@
   reg, {AbsolutePointSize[8], Red, Point@pt, Point@qt}, {Cyan, 
   Point[center]}, Cyan, Dashed, Line[{pt, center}]}, 
 Background -> GrayLevel[0.2]]

enter image description here

Region`Mesh`FindSegmentIntersections[......,"ReturnSegmentIndex" -> True, "Ignore" -> {"EndPointsTouching"}]

We can find the intersection of boundary lines and one extra line ,avoid using the NDSolve.

Clear["Global`*"];
reg = BoundaryDiscretizeGraphics[
   Text[Style["5", FontFamily -> "Bell MT"]], _Text];
{{x1, x2}, {y1, y2}} = RegionBounds[reg];
pt = {x, y} /. 
   Last@NMaximize[{x + y, {x, y} ∈ reg}, {x, y}];
dist = SignedRegionDistance@BoundaryDiscretizeRegion@reg;
dir = AngleVector[-110 Degree];
lines = MeshPrimitives[RegionBoundary@reg, 1];
intersections = 
  Region`Mesh`FindSegmentIntersections[
   Join[lines, {Line[{pt, pt + 10*dir}]}], 
   "ReturnSegmentIndex" -> True, "Ignore" -> {"EndPointsTouching"}];
index = -4;
qt = intersections[[1, index]];
center = pt + 1.5 (qt - pt);
scalingfactor = 
  First@SolveValues[
    ScalingTransform[{1, 1}*scalingfactor, center]@pt == qt, 
    scalingfactor, Reals];
Graphics[{RGBColor[0.8, 0.5, 0.0], reg, 
  Lighter[RGBColor[0.8, 0.5, 0.0]], Lighter[RGBColor[0.8, 0.5, 0.0]], 
  ScalingTransform[{1, 1}*scalingfactor, center]@reg, 
  Lighter@Lighter[RGBColor[0.8, 0.5, 0.0]], 
  ScalingTransform[{1, 1}*scalingfactor^2, center]@reg, 
  ScalingTransform[{1, 1}*scalingfactor^3, center]@
   reg, {AbsolutePointSize[8], Red, Point@pt, Point@qt}, {Cyan, 
   Point[center]}, Cyan, Dashed, Line[{pt, center}], 
  Text[Style["No.", 30, RGBColor[0.8, 0.5, 0.0]], Scaled[{.36, .4}]]},
  Background -> GrayLevel[0.2]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.