Is it possible to ask Mathematica to draw a plot like the given one?

Question

Is it possible to ask Mathematica to draw a plot like this?

MarcoB · Accepted Answer

Graphics[{

(* The diamonds, built as rotated and translated Rectangle objects *)
  {
   FaceForm[None], EdgeForm[Black],
   Translate[Rotate[Rectangle[{-1, -1}, {1, 1}], 45 Degree], {-2, 0}],
   Translate[Rotate[Rectangle[{-1, -1}, {1, 1}], 45 Degree], {2, 0}]
  },

(* The dashed rectangle *)
  {
   FaceForm[None], EdgeForm[Dashed],
   Rectangle[{-2, -7/4}, {2, 7/4}]
  },

(* The thick horizontal line *)
  {Thickness[0.01], Line[{{-Pi/2, -1}, {Pi/2, -1}}]},

(* The thick inner sides of the diamonds *)
  {Thickness[0.01],
   Line[{{-2, Sqrt[2]}, {-2 + Sqrt[2], 0}, {-2, -Sqrt[2]}}],
   Line[{{2, Sqrt[2]}, {2 - Sqrt[2], 0}, {2, -Sqrt[2]}}]
  },

(* The text labels *)
  {
   Inset[Style["x", FontSize -> Scaled[0.05], FontFamily -> "Times"], {-1.1, 1}],
   Inset[Style["y", FontSize -> Scaled[0.05], FontFamily -> "Times"], {-1.1, -0.75}]
  }
 }
]

This is exactly the kind of exercise the tickles my OCD tendencies, so I enjoyed building it by hand, but it would be far quicker (and probably overall more sensible) to build this in a vector graphics software :-) .

kglr · Answer

We can resize the dashed rectangle interactively using LocatorPane and use custom arrowheads to add the labels:
Custom arrowheads:
{ahx, ahy} = Graphics @ Text[Style[#, 16], {0, 0}, {0, # /. {"x" -> -3/2, "y" -> 1}}]&/@
   {"x", "y"};

Unit square with two thick edges and labels:
diamondlines = {Line[{{0, 0}, {0, 1}, {1, 1}}], Thick, 
   Arrowheads[{{.05, .75, {ahy, 1}}}], Arrow[{{0, 0}, {1, 0}}], 
   Arrowheads[{{.05, .5, {ahx, 1}}}], Arrow[{{1, 1}, {1, 0}}]};

Graphics[diamondlines, PlotRangePadding -> Scaled[.1]]

locatorshape = Graphics[{Opacity[0], Point[{1, 1}/2], Opacity[1, Red], 
    Polygon[{{-1, 0}, {0, 0}, {0, -1}}]}, ImageSize -> 30];

We rotate and translate diamondlines to get the two diamonds and combine them with the dashed rectangle and the thick horizontal line:
DynamicModule[{pt = {{2.2, 2}}}, 
  LocatorPane[Dynamic[pt], 
   Dynamic @ Framed @ Graphics[{
     {#, Translate[Rotate[# /. Arrow -> Line, Pi, {0, pt[[1, 2]]/2}], 
          {pt[[1, 1]], 0}]}& @ Translate[Rotate[diamondlines, Pi/4, {0, 0}], 
          {0, (pt[[1, 2]] - Sqrt[2])/2}],
      Thick, Line[{{Sqrt[2]/4, (2 pt[[1, 2]] - Sqrt[2])/4}, 
        {pt[[1, 1]] - Sqrt[2]/4, (2 pt[[1, 2]] - Sqrt[2])/4}}], 
      EdgeForm[Dashed], FaceForm[], Rectangle[{0, 0}, pt[[1]]]}, 
    PlotRange -> {{-1, pt[[1, 1]] + 1}, {-1, pt[[1, 2]] + 1}}, 
    ImageSize -> 500], 
   Appearance -> locatorshape]]

Is it possible to ask Mathematica to draw a plot like the given one?

2 Answers

Add your own answers!

Ask a Question