Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I am doing some research on some combinatorial object called GT-patterns. They are generated from three parts of data.

Two integer, partitions (sequences of weakly decreasing numbers), $\lambda = \lambda_1 \geq \lambda_2,\dotsc, \lambda_n \geq 0$ and $\mu = \mu_1 \geq \dotsc, \mu_n \geq 0$ such that $\lambda_i \geq \mu_i$, and vector of non-negative integers, $w = (w_1,\dotsc,w_k)$ such that $w_1+w_2+\dots + w_k = (\lambda_1+\dots + \lambda_n)-(\mu_1+\dots + \mu_n)$, generate all arrays where certain equalities and inequalities are satisfied, as in the example below:

Here, $\lambda = (4, 3, 3, 2, 1, 1, 0, 0)$, $\mu = (2, 2, 1)$, and $w = (3, 3, 2, 1)$. Note that we pad $\mu$ with zeros so that it has the same length as $\lambda$.

The arrays are constructed as follows: It consists of $k+1$ rows, the first row is $\lambda$ and the last row is $\mu$. The difference of the sum of the entries in row $i$ and $i+1$ must be equal to $w_{k-i+1}$. Thus, thus, in the example, going to 5th row to 4th row, the row sum increases by 3. 4th to 3rd is also an increase by 3, followed by 2 and 1.

That are all equalities that are needed to be satisfied. Now, the inequalities we require to be fulfilled are that each down-right diagonal is weakly decreasing, and each down-left diagonal is weakly increasing. All entries should be non-negative integers. All solutions for the example is given below:

GT-patterns

The output consists of the rows, (as a matrix).

I am also interested in the case where instead of specifying the row sums, we only specify the number of rows. The number of patterns that fit the requirement is still a finite number.

Thus, the method could be specified as follows:

FindGTPatterns[lambda_List, mu_List, w_List]
FindGTPatterns[lambda_List, mu_List, rows_Integer]

and the output is a list of matrices. The method I currently use is the one below. It is very straigthforward, it encodes the equalities and inequalities, and just use Reduce. This works ok, but when the number of solutions is large (>30000), Reduce cannot take it. Also, I strongly suspect that there is a more efficient solution that does not rely on Reduce.

(* ToTableauShape is a method that pads the partitions so that they have the same lenghts, and wars if total of lambda minus total of mu is not the total of w *)

GTPatterns[lambda_List, mu_List:{},weight_List:{}]:=GTPatterns[ToTableauShape[lambda,mu,weight]];
GTPatterns[lambda_List, mu_List:{},maxBox_Integer]:=GTPatterns[ToTableauShape[lambda,mu,{}],maxBox];
GTPatterns[lambda_List, maxBox_Integer]:=GTPatterns[ToTableauShape[lambda,{},{}],maxBox];

GTPatterns[TableauShape[lambda_, mu_, weight_],maxBoxIn_Integer:0]:=Module[
    {w, h, x, gtp, bddconds, wconds=True, ineqs, sol,maxBox=maxBoxIn},

    (* Calculate width, height, of GT-pattern. *)
    w = Length[lambda];

    (* If no weight or maxBox specified, then maxBox is the number of parts of lambda. *)
    h = 1 + Which[
        Length[weight] >0 , Length[weight],
        maxBox > 0, maxBox,
        True, w];

    gtp = Table[x[r][c], {r, h, 1, -1}, {c, w}]; (* The GT-pattern *)

    (* Boundary conditions. *)
    bddconds = And @@ Table[x[h][c] == lambda[[c]] && x[1][c] == mu[[c]], {c, w}];

    If[Length[weight]>0,
        wconds = And @@ Table[ Sum[x[r + 1][c] - x[r][c], {c, w}] == weight[[r]], {r, h - 1}];
    ];

    (* Inequalities that must hold. *)
    ineqs = And @@ Flatten[Table[
        If[r < h, x[r + 1][c] >= x[r][c], True] &&
        If[r < h && c < w, x[r][c] >= x[r + 1][c + 1], True] , {r, h}, {c, w}]];

    sol = Reduce[bddconds && ineqs && wconds, Flatten@gtp, Integers];

    If[sol===False, Return[{}]];

    sol = gtp /. List[ToRules[sol]];
    Return[GTPattern/@sol];
];

On a side note, these patterns are called Gelfand-Tsetlin patterns, and are related to representation theory in mathematics. I asked another question related to these earlier here, and got some really nice algorithms related to doing computations on these types of patterns.

Side note: In what I am doing, I am trying things for $m=1,2,3,...$ and examine all $\lambda$ where the total is $m$, and for each such $\lambda$, examine all $\mu$ and $w$ that fits the requirements, I examine all patterns. Currently, up to $m=8$ is ok, but after that, it takes too much time.

Of course, for some parameters $\lambda,\mu,w$ the set of patterns can be empty. If you have a nice description on WHEN this happens, you can write an article (but I think this is proven to be NP-hard in $m$).

share|improve this question
    
Any reason you're not using Sage to do this? It has such generation built in... –  rasher Feb 25 at 5:37
    
I have some other functionality that I have coded that does not exist in Sage. Besides, I am not sure, but I don't think Sage supports skew patterns, only "regular" ones. –  Per Alexandersson Feb 25 at 7:10

1 Answer 1

Not optimized and surely a memory hog, but it easily breaks the 30K results barrier you mentioned. The tuples generation should be replaced by some clever code so that we don't create tuples that are going to be discarded in the following step for not satisfying the required inequalities.

I used István's nice findPaths[] function out of the box(Copied here for completeness)

findGTPatternsN[l_, mu_, w_] := Module[{w1, ip, cf, g},
  w1 = Accumulate@Reverse@w; 
  ip = Join[{{l}},  IntegerPartitions[Tr@l - #, {Length@l}, Range[0, Max@l]] & /@ 
                                                                Most@w1, {{mu}}];
  cf = Flatten[Tuples[{ip[[#]], ip[[# + 1]]}] & /@ (Range[Length[ip] - 1]), 1];
  g = Graph[ DirectedEdge @@@ (If[ Min [#[[1]] - #[[2]]] >= 0 && 
                                  Min[#[[2, ;; -2]] - #[[1, 2 ;;]]] >= 0, 
                                  ##, 
                                  Sequence @@ {}] & /@ cf)];
  findPaths[g, l, mu]
  ]

  (* István's code follows*)

findPaths[a_?MatrixQ, s_Integer, t_Integer] := Module[{child, find},
   child[v_] := Flatten@Position[a[[v]], Except@0, 1, Heads -> False];
   find[v_, list_] := Scan[If[# === t, Sow[Append[list, #]], 
            If[FreeQ[list, #], find[#, Append[list, #]]]] &, child@v];
   If[# =!= {}, First@#, {}]&@Last@Reap@find[s, {s}]
   ];
findPaths[g_Graph, s_, t_] := Module[{nodes = VertexList@g, convert},
   If[nodes === {} || FreeQ[nodes, s] || FreeQ[nodes, t], {},
     convert = Thread[nodes -> Range@Length@nodes];
     findPaths[Normal@AdjacencyMatrix@g, s /. convert, t /. convert] /. Reverse/@convert
   ]];

Your test case:

l =   {4, 3, 3, 2, 1, 1, 0, 0};
mu = {2, 2, 1, 0, 0, 0, 0, 0};
w = {3, 3, 2, 1};
Column /@ findGTPatternsN[l, mu, w]

Mathematica graphics

A much larger one:

l = {7, 5, 3, 2, 1, 1, 0, 0};
mu = {2, 2, 1, 0, 0, 0, 0, 0};
w = {3, 2, 2, 1, 1, 1, 1, 1, 1, 1};
findGTPatternsN[l, mu, w] // Length
(*
 130245 ...after a while
*)
share|improve this answer
    
Wow, this is very efficient! How does the algorithm work? I took the liberty of adding an extra check in findPaths; looks like some corner cases mess up your code otherwise. –  Per Alexandersson Mar 5 at 10:39
    
@Paxinum I've rejected your edit: try to handle corner cases by do not forwarding those at all to findPaths. And please don't use Return. –  István Zachar Mar 5 at 11:08
    
@IstvánZachar Oh, ok, is there a particular reason why one wish to avoid return? I am probalby just used to Java, so it feels easier to read in this manner. –  Per Alexandersson Mar 5 at 11:12
    
@Paxinum Well, it's ugly, and you don't need it, see my update. –  István Zachar Mar 5 at 11:18
2  
@Paxinum See some discussion on Return here and here. The most important caveat is that if no specific second argument is given to Return, system uses own heuristics to find out which control structure to return from. –  István Zachar Mar 5 at 12:04

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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