How can I make this pipe network shape?

Question

I want to draw this shape in Mathematica. I don't know what to start with. Can I use BezierCurve? Or should I try to form an equation that could end up in this shape?

Answer 1

A spline solution:

    Module[{th, rl, ll, pts, join, liquid}, th = 20;
 rl = {{0, -1}, {0, 0}, {0, 2/3}, {1/2, 1}, {1, 4/3}, {1, 2}};
 ll = {{2, -1}, {2, 0}, {2, 2/3}, {3/2, 1}, {1, 4/3}, {1, 2}};
 pts = {Flatten[{rl, {1, 3} + # & /@ rl, {2, 6} + # & /@ 
      rl, {{3, 8}}}, 1], ll, 
   Flatten[{{{3, -1}, {3, 0}}, {1, 3} + # & /@ ll}, 1], 
   Flatten[{{{4, -1}, {4, 4}}, {2, 6} + # & /@ ll}, 1]};
 liquid = {{{0, -1}, {0, -.5}}, {{2, -1}, {2, -.5}}, 
{{3, -1}, {3,-.5}}, {{4, -1}, {4, -.5}}};
 Graphics[{AbsoluteThickness[th], BSplineCurve /@ pts, White, 
   AbsoluteThickness[th - 1], 
   BSplineCurve /@ Evaluate[pts /. 8 -> 8.02], Black,
   AbsoluteThickness[th], BSplineCurve /@ liquid, Lighter[Red, .75], 
   AbsoluteThickness[th - 1], 
   BSplineCurve /@ Evaluate[liquid /. -.5 -> -.48], Black, 
   AbsoluteThickness[1], Opacity[.25],
   Arrowheads[.075], Dashed, 
   Arrow[BSplineCurve[#]] & /@ {{1, 3} + # & /@ 
      Reverse@Rest@rl, {1, 3} + # & /@ Reverse@Rest@ll, {2, 6} + # & /@
       Reverse@Rest@rl, {2, 6} + # & /@ Reverse@Rest@ll, 
     Reverse@Rest@rl, Reverse@Rest@ll},
   Opacity[1], Dashing[None], Line[{{-.5, -1.21}, {4.5, -1.21}}]
   }
  ]]

This was just built from basic building block:

Module[{pts = {{0, 0}, {0, 2/3}, {1/2, 1}, {1, 4/3}, {1, 2}}}, 
 Graphics[{BSplineCurve[pts], Green, Line[pts], Red, Point[pts]}]]

Answer 2

Outline

• Gallery

• Method 1 : TreePlot with EdgeShapeFunction

straightfoward to use

• Method 2: Stack parametric plots

Interactive, can be tedious or like a game

• Method 3: Nested shifts and line rewiring

easy to use black box function with customization

• Appendix

---

Gallery

• Method 1 : TreePlot with EdgeShapeFunction

Note : There are small imperfections from edge corners near the vertices.

• Method 2: Stack parametric plots

• Method 3: Nested shifts and line rewiring

---

Method 1 : TreePlot with EdgeShapeFunction

Drawback : The edges can not be extracted without involving image processing and so the inner part of the pipes have to be colored. An explanation of how to obtain the edges via image processing is given in the appendix.

In the first subsection of the Applications section in the documentation for BezierCurves there is the following edge shape function:

bezieredge = 
  Function[{pts}, 
   BezierCurve[{pts[[
      1]], {pts[[1, 1]], (pts[[1, 2]] + 2 pts[[2, 2]])/3}, {pts[[2, 
       1]], (2 pts[[1, 2]] + pts[[2, 2]])/3}, pts[[2]]}]];

Thickening the lines, increasing the opacity, adding DropShadowing (new in version 13.1) for some "edge" and including the previous edge shape function (the w labels are arbitrary):

TreePlot[
 Tree[w, {Tree[w, {Tree[w, {Tree[w, {w}]}], Tree[w, {Tree[w, {w}]}]}],
     Tree[w, {w}], Tree[w, {w}]}] // TreeGraph, 
 EdgeShapeFunction -> bezieredge, 
 EdgeStyle -> 
  Directive[Thickness[0.05], Opacity[1], Black, 
   DropShadowing[{-3, 3}, 5, RGBColor[0.300725, 0.680491, 0.901701]]],
  VertexLabels -> None, VertexShape -> None]

---

Method 2: Stack parametric plots

Drawback : Interactive not algorithmic

The following is an incomplete answer. It is a tedious task of lego packing Tanh curves. It could be kind of soothing or amusing to play with but it's not a quick algorithm. Although I did not use Manipulate to find the parameters below, a code to use Manipulate is provided in the appendix.

plot1 = ParametricPlot[{{Tanh[x], x}, {-Tanh[x], x}}, {x, -10, 0}, 
   Axes -> False, PlotStyle -> Orange];

plot2 = ParametricPlot[{{Tanh[x] - 4, x}, {4 - Tanh[x], x}}, {x, -10, 
    3}, Axes -> False, PlotStyle -> Orange];

plot3 = ParametricPlot[{Tanh[x] - 2, x + 13}, {x, -10, 3}, 
   Axes -> False, PlotStyle -> Orange];

  plot4 = ParametricPlot[{2*Tanh[x] + 5, x + 13}, {x, -10, 0}, 
   Axes -> False, PlotStyle -> Orange];

plot5 = ParametricPlot[{5 - 2*Tanh[x], x + 13}, {x, -23, 0}, 
   Axes -> False, PlotStyle -> Orange];

plot6 = ParametricPlot[{10 - Tanh[x], x + 13}, {x, -23, 3}, 
   Axes -> False, PlotStyle -> Orange];

Show[{plot3, plot2, plot1, plot4, plot5, plot6}, PlotRange -> All]

---

Method 3: Nested shifts and line rewiring

Drawback: the code can only generate nested iterations of the tree structure given in the question.

The plots in the gallery above can be made easily with the code below. As examples:

The straight lines can be obtained with (code definitions below)

node // nestAddnode[2] //Graphics

where n=2 represents the number of recursions performed by nestAddnode. Increasing the number of recursions increases the number of nodes in the graph. Curved lines can be obtained with:

node // nestAddnode[2]// ReplaceAll[Line -> BSplineCurve] //Graphics

node above is a list of lines with the following graphical representation:

Other types of nodes made of three lines with three openings of equal width might also work if the lines are given as {Line[{pts1}],Line[{pts2}],Line[{pts3}]} with pts a list of points (not segments of points such as {{ptsa,ptsb},{ptsc,ptsd}). The points in the lines also have to be ordered according to the image below:

label[label_, point_] := 
  Sequence @@ ({Text[Style[label, Medium], # + 0.2], Point@#} &@
     point);

{node, Red, PointSize@Large, label["start", node[[1, 1, 1]]], 
  label["end", node[[1, 1, -1]]], label["start", node[[2, 1, 1]]], 
  label["end", node[[2, 1, -1]]], label["start", node[[3, 1, 1]]], 
  label["end", node[[3, 1, -1]]]} // Graphics

The method of constructing the tree consists of recursively shifting the node in the image above to the lower left of the tree, rewiring lines to make extended lines rather than line segments and extending vertical lines. The reason for rewiring the lines rather than keeping segments of lines is that it allows transforming straight lines to curves using a replacement rule like Line->BSplineCurve for example.

Other than BSplineCurve, the image in the gallery used the following resource functions as options to make curves:

• ResourceFunction["CurveToBSplineFunction"]

• ResourceFunction["RoundedLine"]

• ResourceFunction["AkimaSpline"]

code

code to make node :

Note: …=[Ellipsis]

path1 = AnglePath[{Pi/4, -Pi/4, -Pi/4}];
Clear[pt1, pt2];
{pt1, pt2} = {path1[[1]] - {1/2, 0}, path1[[-1]] + {1/2, 0}};
tsol = Min@
   SolveValues[
    Norm[pt1 + \[FormalT]*{Cos[Pi/4], 
         Sin[Pi/4]} - (pt2 + \[FormalT]*{-Cos[Pi/4], Sin[Pi/4]})] == 
     1/2, \[FormalT], Reals];
vertical…edge…height = {0, 1};
node = {Line[{pt1 - vertical…edge…height, pt1, 
     pt1 + tsol*{Cos[Pi/4], Sin[Pi/4]}, 
     pt1 + tsol*{Cos[Pi/4], Sin[Pi/4]} + 
      vertical…edge…height}], 
   Line@Join[{path1[[1]] - vertical…edge…height}, 
     path1, {path1[[-1]] - vertical…edge…height}],
    Line[{pt2 + tsol*{-Cos[Pi/4], Sin[Pi/4]} + 
      vertical…edge…height, 
     pt2 + tsol*{-Cos[Pi/4], Sin[Pi/4]}, pt2, 
     pt2 - vertical…edge…height}]};

Code that adds node to a tree of nodes:

Clear[addLeft];

addLeft[tree_,node_]:=
Module[{shifted…node},
shifted…node=
Map[#-First@Extract[tree,{{1,1,-1},{-1,1,1}}]+First@Extract[tree,{{1,1,1},{2,1,1}}]&,
    node,
    {3}]
;

{
Join[shifted…node[[1]],
    tree[[1]],
    2]
,

shifted…node[[2]]
,

Join[Reverse/@shifted…node[[3]],
    tree[[2]],
    Line[{tree[[2,1,-1]],
        tree[[2,1,-1]]+{0,-tree[[2,1,-1,-1]]+shifted…node[[1,1,1,2]]}}
    ]
    ,2]
,

(* extend other columns *)
Sequence@@Table[    
        Join[
        Line[{
            tree[[m,1,1]]+{0,-tree[[m,1,1,-1]]+shifted…node[[1,1,1,-1]]}
            ,
            tree[[m,1,1]]}
        ]
        ,
        tree[[m]]
        ,
        Line[{tree[[m,1,-1]],
            tree[[m,1,-1]]+{0,-tree[[m,1,-1,-1]]+shifted…node[[1,1,1,-1]]}}
        ],
        2],
        {m,3,Length@tree-1}]
,
Join[       
    tree[[-1]]
    ,
    Line[{tree[[-1,1,-1]],
        tree[[-1,1,-1]]+{0,-tree[[-1,1,-1,-1]]+shifted…node[[1,1,1,-1]]}
        }
    ]
,
2]
}
]

Nested application of addLeft :

nestAddnode[n_][node_] := Nest[addLeft[#, node] &, node, n];

code to use optional random coloring as in the plots above:

Clear[colorize];
colorize := 
  Riffle[Thread@Hue[RandomReal[] + Subdivide[Length@#]], #] &; 

code to use optional resource function customizations:

spline[pts_] := 
 ParametricPlot[ResourceFunction["AkimaSpline"][pts][t], {t, 0, 1}, 
  Axes -> False]


spline2[pts_, d__] := 
 ParametricPlot[
  ResourceFunction["CurveToBSplineFunction"][pts, d][t], {t, 0, 1}, 
  Axes -> False]

showSpline[node_] := 
  node /. Line[s_] :> spline[N@DeleteDuplicates@Simplify@s] // 
   Show[#, PlotRange -> All] &;

showSpline2[node_, d__] := 
  node /. Line[s_] :> spline2[N@DeleteDuplicates@Simplify@s, d] // 
   Show[#, PlotRange -> All] &;

    showSpline3[node_, d__] := 
  node /. Line[s_] :> 
    ResourceFunction["RoundedLine"][N@DeleteDuplicates@Simplify@s, d];

The image in the gallery was produced with :

Note : Uses resource function ResourceFunction["NearEqualPartition"] in code below.

node // nestAddnode[2] // {Graphics, 
     ReplaceAll[Line -> BSplineCurve]/*colorize/*Graphics, 
     showSpline, (showSpline3[#, 0.7] &)/*colorize/*Graphics, 
     showSpline2[#, 2, 0.5] &} // Through // 
  ResourceFunction["NearEqualPartition"][#, 2] & // GraphicsGrid

Appendix

The edges from the treeplot can be obtained via image processing. To increase quality of the final image, the image is also remade into a graphics objects. That last step can lead to errors but it the errors seem minor in the image below:

The plot given above with different parameters :

plot=TreePlot[
  Tree[w, {Tree[
      w, {Tree[w, {Tree[w, {w}]}], Tree[w, {Tree[w, {w}]}]}], 
     Tree[w, {w}], Tree[w, {w}]}] // TreeGraph, 
  EdgeShapeFunction -> bezieredge, 
  EdgeStyle -> Directive[Thickness[0.1], Opacity[1], Black], 
  VertexLabels -> None, VertexShape -> None];

Image from plot:

im = Image@plot;

obtaining the edge from the branches:

im2 = im // ImageData // Part[#, All, All, 4] & // Image // 
MorphologicalPerimeter // Dilation[#, 2] & // ColorNegate

Turn the image back to a graphics object:

im2 // ImageGraphics;

• Method 2: Stack parametric plots

Code to use Manipulate

I did not use Manipulate to obtain the parameters above I just guessed based on what I expected from scaling and shifting step by step. If you would like a more interactive approach I left a code to use Manipulate below

With the parameter choices below initially the curves are super imposed. I would recommend starting small with just 1 or 2 curves and using some of the parameter choices above.

The curve function. To produce quicker plots I reduced the number of points. You can take default options for the plot once your find the parameter choice.

    Clear[plot]; 
plot[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ, 
  f_?NumericQ] := 
 ParametricPlot[{a + b*Tanh[x], c*x + d}, {x, e, f}, Axes -> False, 
  PlotStyle -> Orange, PerformanceGoal -> "Speed", PlotPoints -> 30, 
  MaxRecursion -> 0]

Ranges for parameters a,b,c,d,e. splice should be undefined and will be used in a replacement rule later. The syntax is splice[min,max] where min and max represent the minimal and maximal value of the parameter:

arange = splice[0, 10]; brange = splice[-5, 5]; crange = 
 splice[-2, 2]; drange = splice[0, 15]; erange = splice[-30, 0];
frange = splice[0, 5];

The manipulate function (Note that you might need to enlarge the image):

• n below is the number of curves

• the comment below is to keep track of the meaning of the variables on the controllers by giving the plot command for the first curve. The syntax is v[1,1]=a in the expression for plot, v[1,2]=b,v[1,3]=c,v[1,4]=d,v[1,5]=e,v[1,6]=f,v[2,1]=a,v[2,2]=b,etc

• click the plus sign next to each controller to enter values

the code:

n = 2;
Manipulate[
 Evaluate@
  Quiet@Show[plot @@@ Array[v, {n, 6}], ImageSize -> Small, 
    PlotRange -> All], 
 Transpose[{#, {arange, brange, crange, drange, erange, frange}}] & /@
       Array[v, {n, 6}] /. splice -> Sequence // Catenate // 
   Apply[Sequence] // Evaluate, DefaultLabelStyle -> Orange, 
 Paneled -> False, ControlPlacement -> Left]

(* {v[1,1]+v[1,2]*Tanh[x],v[1,3]*x+v[1,4]},{x,v[1,5],v[1,6]} *)

Answer 3

A couple of years ago, I wrote a (somewhat general) function to make Sankey diagrams. The top-level function (parseSankeyAssociation) doesn't seem to work out of the box for this use-case, but we can achieve a fairly decent result using the sankeyRibbonGraphics function defined at the bottom of the answer.

With[{length=10,col=Black,width=2.5},
{
sankeyRibbonGraphics[{{{0,-3},{0,-2}},{{length,-1},{length,0}}},col,width],
sankeyRibbonGraphics[{{{length,-1},{length,0}},{{2length,-1},{2length,0}}},col,width],
sankeyRibbonGraphics[{{{2length,-1},{2length,0}},{{3length,-1},{3length,0}}},col,width],
sankeyRibbonGraphics[{{{0,-3},{0,-2}},{{length,-5},{length,-4}}},col,width],
sankeyRibbonGraphics[{{{length,-5},{length,-4}},{{2length,-3},{2length,-2}}},col,width],
sankeyRibbonGraphics[{{{length,-5},{length,-4}},{{2length,-7},{2length,-6}}},col,width],
sankeyRibbonGraphics[{{{2length,-3},{2length,-2}},{{3length,-3},{3length,-2}}},col,width],
sankeyRibbonGraphics[{{{2length,-7},{2length,-6}},{{3length,-5},{3length,-4}}},col,width],
sankeyRibbonGraphics[{{{2length,-7},{2length,-6}},{{3length,-9},{3length,-8}}},col,width]
}//Graphics
]

Note, this uses the excellent answer here on using ParametricPlot to make constant-thickness (or in-fact varying-thickness) ribbons.

Edit:

For self-completeness here's the necessary minified code (Note I swapped the colDirective option to affect BoundaryStyle instead of PlotStyle to get the outlines. See edit history if you prefer the filled output)

thickness[f_,th_]:=Block[{x},{x,f}+Normalize[{-D[f,x],1}] th]
sankeyRibbonFunction[{{sourceMin_,sourceMax_},{targetMin_,targetMax_}},width_:10]:=With[{sourceCentroid=Last@Mean[{sourceMin,sourceMax}],targetCentroid=Last@Mean[{targetMin,targetMax}],midpoint=First@Mean[{sourceMin,targetMin}]},(targetCentroid-sourceCentroid)/(1+E^(-width (-midpoint+x)))+sourceCentroid]
sankeyRibbonGraphics[{{sourceMin_,sourceMax_},{targetMin_,targetMax_}},colDirective_,width_:10]:=With[{heightSource=Last[sourceMax-sourceMin]/2,heightTarget=Last[targetMax-targetMin]/2},First[ParametricPlot[Evaluate@thickness[sankeyRibbonFunction[{{sourceMin,sourceMax},{targetMin,targetMax}},width],If[heightSource==heightTarget,heightSource t,heightSource t+(heightTarget-heightSource) t LogisticSigmoid[width (x-(First[sourceMin]+First[targetMin])/2)]]],{x,First[sourceMin],First[targetMin]},{t,-1,1},PlotPoints->{25,3},MaxRecursion->4,Mesh->None,BoundaryStyle->colDirective,PlotStyle->None]]]

Answer 4

Use Translate with multiples of 3 along x-axis and multiples of 4 along y-axis to move objects o1 and o2.

o1 = {Line[{{0, 0}, {0, 1}}], Line[{{1, 0}, {1, 1}}], 
   Circle[{2, 0}, 2, {π + ArcTan[Sqrt[7]/3], π + π/2}], 
   Circle[{2, 0}, 1, {π, π + π/2}], 
   Circle[{2, -3}, 2, {0, 0 + π/2}], 
   Circle[{2, -3}, 1, {0, 0 + π/2}], 
   Circle[{2 - 3, 0}, 
    2, {3/2 π, 3/2 π + π/2 - ArcTan[Sqrt[7]/3]}], 
   Circle[{2 - 3, 0}, 1, {3/2 π, 3/2 π + π/2}], 
   Circle[{2 - 3, -3}, 2, {π/2, π/2 + π/2}], 
   Circle[{2 - 3, -3}, 1, {π/2, π/2 + π/2}]};

o2 = {Line[{{0, 1}, {0, 5}}], Line[{{1, 1}, {1, 5}}]};

Graphics[{o1, Translate[o1, {-3, -4}], Translate[o1, {-6, -8}], 
  Translate[o2, {3, -8}], Translate[o2, {3, -12}], 
  Translate[o2, {0, -12}], Translate[o2, {-9, -16}], 
  Translate[o2, {-3, -16}], Translate[o2, {0, -16}], 
  Translate[o2, {3, -16}]}]