Visualizing Wicks' contractions using brackets

Question

Given a string like MMMM, what is the easiest way to draw all Wicks contractions similar to the diagram below (from Ch. 2 of Eynard paper)? Example below is for (MMMM), but I need it to work for other cases like (MMMMMM), where the sum is over all the pairings of $\{1,\ldots,n\}$, i.e. all distinct ways of partitioning $\{1,\ldots,n\}$ into pairs $\{i,j\}$ (source)

What is the easiest way to make this into deployable web app (ie, textfield where I can enter "MMMM" and get a diagram like below?). Link to tutorial is fine. I ran into WRI employee at JMM 2024 and was surprised that he had some Mathematica web apps accessible through his phone.

For 2. take a look at CloudDeploy, FormFunction, APIFunction etc. — Kuba, Mar 19 '24 at 08:02
What kind of output do you want? An image? Mathematica code? $\TeX$ code? $\TeX$-formatted expression? — Domen, Mar 19 '24 at 10:47
I'm looking for something resembling expression in the question, most formats work since I know how to convert between formats — Yaroslav Bulatov, Mar 19 '24 at 13:10
What have you done yourself? Do you have code for generating all pairings? — azerbajdzan, Mar 19 '24 at 21:49
Here's a brute force approach to generate all pairs for $n=6$: (({{#[[1]], #[[2]]} // Sort, {#[[3]], #[[4]]} // Sort, {#[[5]], #[[6]]} // Sort} // Sort) & /@ Permutations[Range[6]]) // DeleteDuplicates — JimB, Mar 19 '24 at 23:38

kglr · Answer 1 · 2024-03-19T22:43:43.757

Using @yarchik's approach with a custom EdgeShapeFunction:

g0 = Graph[Range[4], {1 \[UndirectedEdge] 3, 2 \[UndirectedEdge] 4}, 
   VertexCoordinates -> Thread[{Range@4, 0}], 
   GraphLayout -> "LinearEmbedding", 
   VertexShapeFunction -> (Text[Style["M", Black,  32], #] &), 
   VertexSize -> Large];
ClearAll[bracket]
bracket[i_ : 1, d_ : .4] := Module[{o = (-1)^i  d}, 
 Line[{#[[1]] + {0, o/3}, #[[1]] + {0,o}, #[[2]] + {0, o}, #[[2]] + {0, o/3}}]]&
Graph[g0, EdgeShapeFunction -> {e_ :> bracket[1 + EdgeIndex[g0, e]]}]

Update: Using twopartitions from this answer:

ClearAll[twoPartitions, wicksG]
twoPartitions[n_] := Select[Union @@ # == Range[n] &]@
   Fold[Subsets, Range@n, {{2}, {n/2}}];
wicksG[n_] := Module[{vl = Range@n, 
   el = Map[MapApply[UndirectedEdge]]@twoPartitions[n], gl}, 
  gl = Graph[vl, #] & /@ el;
  Graph[#, 
     VertexCoordinates -> 
      Thread[{CurrentValue["FontMWidth"] vl /20/n, 0}], 
     GraphLayout -> "LinearEmbedding", 
     VertexShapeFunction -> (Text[Style["M", Black, 20], #] &), 
     EdgeShapeFunction -> {e_ :> 
        bracket[1 + EdgeIndex[#, e], 
         CurrentValue["FontXHeight"]/20/2]}] & /@ gl]
Plus @@ wicksG[4]

Plus @@ wicksG[6]

Amazing, I was searching for the options, but could not find anything suitable. — yarchik, Mar 19 '24 at 22:02

score 7 · Answer 2 · answered Mar 19 '24 at 22:56

I don't know the best way to generate these pairs or how to avoid collisions in general and put brackets either top or bottom, but making brackets a bit smaller if there is an intersection seems to work:

drawBracketTop[{i_, j_}, size_ : .5] := Line[{{i, .5}, {i, .5 + size}, {j, .5 + size}, {j, .5}}]
drawBracketBot[{i_, j_}, size_ : .5] := Line[{{i, - .5}, {i, -.5 - size}, {j, - .5 - size}, {j, - .5}}]
intersectQ[pair1_, pair2_] := IntervalIntersection[Interval[pair1], Interval[pair2]] =!= Interval[]
topBotSeparate[pairs_] := Block[{top = {}, bot = {}},
    Scan[pair |-> If[
        AnyTrue[top, intersectQ[pair, #] &],
        AppendTo[bot, pair],
        AppendTo[top, pair]
    ], pairs];
    {top, bot}
]
drawBrackets[f_][pairs_]:= FoldPairList[
    {state, pair} |-> With[{newSize = If[AnyTrue[state[[2]], intersectQ[pair, #] &], 0.8, 1] state[[1]]}, {f[pair, newSize], {newSize, Append[state[[2]], pair]}}],
    {.5, {}},
    pairs
]
WickContractions[n_Integer] /; n > 0 && EvenQ[n] := Block[{pairs},
    pairs = Select[Select[DuplicateFreeQ] /@ ResourceFunction["ParityPairings"][Range[n]], Length[#] == n / 2 &];
    Graphics[{
        Table[Text[Style["M", 32, Italic, FontFamily -> "Source Serif Pro"], {i, 0}], {i, n}],
        MapAt[drawBrackets[drawBracketBot], {2}] @ MapAt[drawBrackets[drawBracketTop], {1}] @ topBotSeparate[#]
    }, PlotRange -> {-1.25, 1.25}] & /@ pairs
]

score 6 · Answer 3 · answered Mar 19 '24 at 14:49

6

You can use Graph objects for this purpose, e.g.

Graph[{1 \[UndirectedEdge] 3, 2 \[UndirectedEdge] 4}, 
 VertexCoordinates -> Table[i -> {i, 0}, {i, 4}], 
 GraphLayout -> "LinearEmbedding", 
 VertexLabels -> Placed["M", Center], 
 VertexShapeFunction -> "Square",
 VertexSize -> Large]

answered Mar 19 '24 at 14:49

yarchik

18,202
2
28
66

Thanks although the brackets don't look as nice as the original – Yaroslav Bulatov Mar 19 '24 at 15:23
@YaroslavBulatov Indeed. You could use latex and the simpler-wick package and insert the png of a formula in MA notebook. – yarchik Mar 19 '24 at 15:30
that's the easy part, the slightly harder part is enumerating all the partitions – Yaroslav Bulatov Mar 19 '24 at 21:33
1

@YaroslavBulatov For enumeration, it is useful to map the Wick contractions onto the so-called chord diagrams. See for instance DOI: 10.1016/S0012-365X(99)00347-7. If I am not mistaken, the number of contractions is $(2n-1)!!$, where $n$ is the number of pairings (2 in your example). – yarchik Mar 19 '24 at 22:01

score 5 · Accepted Answer · answered Mar 20 '24 at 13:00

Something much more efficient with a brain teasing code.

Clear[pairs]
pairs[0] = {{}};
pairs[n_] := 
 Flatten[(d |-> 
     Prepend[Partition[Complement[Range[n], d][[Flatten@#]], 2], 
        d] & /@ pairs[n - 2]) /@ ({1, #} & /@ Rest@Range[n]), 1]

Here are pairs partitions for n=8:

n = 8;
Graph[#, VertexCoordinates -> Table[{i, 0}, {i, n}], 
    GraphLayout -> "LinearEmbedding", VertexLabels -> Automatic, 
    VertexSize -> Medium, PlotRange -> {{0.5, n + 0.5}, {-1, 2}}] & /@
   pairs[n];
Grid[Partition[%, 3], Frame -> All]

ooh, I like the aesthetics, this visualization style seems better than brackets — Yaroslav Bulatov, Mar 20 '24 at 16:11

Visualizing Wicks' contractions using brackets

4 Answers4

Linked