10
$\begingroup$
  1. 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)

enter image description here

  1. 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.
Improve this question
$\endgroup$
5
  • 1
    $\begingroup$ For 2. take a look at CloudDeploy, FormFunction, APIFunction etc. $\endgroup$
    – Kuba
    Commented Mar 19 at 8:02
  • 2
    $\begingroup$ What kind of output do you want? An image? Mathematica code? $\TeX$ code? $\TeX$-formatted expression? $\endgroup$
    – Domen
    Commented Mar 19 at 10:47
  • $\begingroup$ I'm looking for something resembling expression in the question, most formats work since I know how to convert between formats $\endgroup$
    – Yaroslav Bulatov
    Commented Mar 19 at 13:10
  • 2
    $\begingroup$ What have you done yourself? Do you have code for generating all pairings? $\endgroup$
    – azerbajdzan
    Commented Mar 19 at 21:49
  • $\begingroup$ 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 $\endgroup$
    – JimB
    Commented Mar 19 at 23:38

4 Answers 4

Reset to default
5
$\begingroup$

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]

enter image description here enter image description here enter image description here enter image description here

Improve this answer
$\endgroup$
1
  • 2
    $\begingroup$ ooh, I like the aesthetics, this visualization style seems better than brackets $\endgroup$
    – Yaroslav Bulatov
    Commented Mar 20 at 16:11
9
$\begingroup$

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]]}]

enter image description here

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]

enter image description here

Plus @@ wicksG[6]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ Amazing, I was searching for the options, but could not find anything suitable. $\endgroup$
    – yarchik
    Commented Mar 19 at 22:02
7
$\begingroup$

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
]

enter image description here

Improve this answer
$\endgroup$
6
$\begingroup$

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]

enter image description here

Improve this answer
$\endgroup$
4
  • $\begingroup$ Thanks although the brackets don't look as nice as the original $\endgroup$
    – Yaroslav Bulatov
    Commented Mar 19 at 15:23
  • $\begingroup$ @YaroslavBulatov Indeed. You could use latex and the simpler-wick package and insert the png of a formula in MA notebook. $\endgroup$
    – yarchik
    Commented Mar 19 at 15:30
  • $\begingroup$ that's the easy part, the slightly harder part is enumerating all the partitions $\endgroup$
    – Yaroslav Bulatov
    Commented Mar 19 at 21:33
  • 1
    $\begingroup$ @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). $\endgroup$
    – yarchik
    Commented Mar 19 at 22:01

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.