Looking for q-analog of derangement anagrams for a word

Question

I have already known QPermutationDerangement:

It describes the distribution

$$ d_n(q)=\sum_{\sigma \in D_n} q^{\operatorname{maj}(\sigma)} $$

Where we sum over all derangements of an $n$ element set.

I'd like to use the formula:

$$ d_n(q)=[n]!\sum_{k=0}^n \frac{(-1)^k}{[k]!} q^{\left(\frac{k}{2}\right)} $$

Clear["Global`*"];

DescentSet[p_] := Table[
  If[p[[i]] > p[[i + 1]], i, Sequence @@ {}], 
  {i, Length[p] - 1}
];

MajorIndex[p_] := Total@DescentSet[p];

(* Generalization of the number of derangements *)
QPermutationDerangement[n_, q_] := 
  QFactorial[n, q] * 
  Sum[(-1)^k * q^Binomial[k, 2] / QFactorial[k, q], {k, 0, n}]

n = 6;

(* q-analog of permutation derangements *)
QPermutationDerangement[n, q] // FullSimplify // FunctionExpand // 
   CoefficientList[#, q] & // Sort // Print

Map[MajorIndex, Derangements[Range[n]]] // Tally // 
  Map[#[[All, 2]] &, #] & // Sort

---

I have already known the number of derangement anagrams for a word with character counts $\{ n_1,n_2, \cdots, n_k \}$ is

$$ \int_0^{\infty } \exp (-x) \prod\limits_{i} \left[(-1)^{n_i} L_{n_i}(x)\right] \, \mathrm{d} x $$

DerangementsCount[nvec_List] := 
  Integrate[
    Exp[-x] Apply[Times, (-1)^nvec LaguerreL[nvec, x]], 
    {x, 0, Infinity}
  ]

chars = Characters["Mathematica"] // ToLowerCase

DerangementsCount[Tally[chars][[All, 2]]]

Count[Permutations[chars],  x_ /; Inner[UnsameQ, x, chars, And]]

---

Reference request: Looking for q-analog of derangement anagrams for a word.

Answer 1

---

Use $\textbf{Theorem 1.1}$ from ^[1],

The linearization coefficients of q-Laguerre polynomials are given by

$$ \mathcal{L}\left(L_{n_1}(x ; q, y) \cdots L_{n_k}(x ; q, y)\right)=\sum_{\sigma \in \mathcal{D}\left(n_1, \ldots, n_k\right)} y^{\operatorname{wex}(\sigma)} q^{\operatorname{cross}(\sigma)} $$

The below code is correct.

for case $(n_1,\cdots,n_k)=(1,2,3) \scriptstyle{\quad\text{or permutations of (1,2,3)}}$

$$ \text{LHS}=y^3 q^6+4 y^3 q^5+8 y^3 q^4+10 y^3 q^3+8 y^3 q^2+4 y^3 q+y^3=\text{RHS} $$

for case $(n_1,\cdots,n_k)=(2,3,4) \scriptstyle{\quad\text{or permutations of (2,3,4)}}$

$$ \text{LHS}=y^5 q^{16}+8 y^5 q^{15}+y^4 q^{15}+33 y^5 q^{14}+8 y^4 q^{14}+93 y^5 q^{13}+33 y^4 q^{13}+199 y^5 q^{12}+93 y^4 q^{12}+341 y^5 q^{11}+199 y^4 q^{11}+482 y^5 q^{10}+341 y^4 q^{10}+571 y^5 q^9+482 y^4 q^9+571 y^5 q^8+571 y^4 q^8+482 y^5 q^7+571 y^4 q^7+341 y^5 q^6+482 y^4 q^6+199 y^5 q^5+341 y^4 q^5+93 y^5 q^4+199 y^4 q^4+33 y^5 q^3+93 y^4 q^3+8 y^5 q^2+33 y^4 q^2+y^5 q+8 y^4 q+y^4 =\text{RHS} $$

Clear["Global`*"];
nkVec = {1, 2, 3};
n = Total[nkVec];
k = Length[nkVec];
chars = Permutations[Range[n]];

judgeFunc[perm_] := 
  Module[{nSums, i, j}, nSums = Prepend[Accumulate[nkVec], 0];(*n_0=0,
   cumulative sums*)
   For[i = 1, i <= n, i++, 
    For[j = 1, j <= k, j++, 
      If[nSums[[j]] + 1 <= i <= nSums[[j + 1]] && 
         nSums[[j]] + 1 <= perm[[i]] <= nSums[[j + 1]], 
        Return[False]];];];
   True];

derangements = Select[chars, judgeFunc];
wex[p_] := With[{n = Length@p}, Sum[Boole[p[[i]] >= i], {i, 1, n}]];
ov[p_] := 
  With[{n = Length@p}, 
   Sum[Boole@
     Or[i < j <= p[[i]] < p[[j]], p[[j]] < p[[i]] < j < i], {i, 1, 
     n}, {j, 1, n}]];
cross[p_] := ov[p];
rhs = Sum[y^wex[\[Sigma]]*q^cross[\[Sigma]], {\[Sigma], derangements}];
Print["rhs=", rhs];

QInteger[n_Integer, q_ : 1] := QBinomial[n, 1, q];
OrderedForm[x_] := 
  HoldForm[+##] & @@ (x^#1[[1]] #2 & @@@ CoefficientRules[#, x]) &;

QYLaguerreLExplicitFormula[n_, x_, {q_, y_}] := 
  Sum[(-1)^(n - k)*QFactorial[n, q]/QFactorial[k, q]*
    QBinomial[n, k, q]*q^(k*(k - n))*y^(n - k)*
    Product[(x - (1 - y*q^(-j))*QInteger[j, q]), {j, 0, k - 1}], {k, 
    0, n}];

QYLaguerreL[0, x, {q_, y_}] := 1;
QYLaguerreL[1, x, {q_, y_}] := x - y;
QYLaguerreL[2, x, {q_, y_}] := x^2 - (y*q + 2 y + 1) x + y^2 + y^2*q;
QYLaguerreL[n_, 
   x_, {q_, y_}] := (x - y*QInteger[n, q] - QInteger[n - 1, q])*
    QYLaguerreL[n - 1, x, {q, y}] - 
   y*QInteger[n - 1, q]^2*QYLaguerreL[n - 2, x, {q, y}];

Print["QYLaguerreL[3,x,{q,y}]=", 
  QYLaguerreL[3, x, {q, y}] // FunctionExpand // FullSimplify // 
    Expand // OrderedForm[x]];

Print["QYLaguerreLExplicitFormula[3,x,{q,y}]=", 
  QYLaguerreLExplicitFormula[3, x, {q, y}] // FunctionExpand // 
     FullSimplify // Expand // OrderedForm[x]];


productOfQYLaguerreL = 
  Product[QYLaguerreL[nk, x, {q, y}], {nk, nkVec}] // FunctionExpand //
     FullSimplify // Expand;

Print["productOfQYLaguerreL=", productOfQYLaguerreL // OrderedForm[x]];


mathcalL[n_] := 
  mathcalL[n] = Sum[y^wex[p]*q^cross[p], {p, Permutations[Range[n]]}];
Print["test mathcalL for n=0..=6 at {y->1,q->1}  ", 
  mathcalL /@ Range[0, 6] /. {y -> 1, q -> 1}];
lhs = Module[{coeffs = CoefficientList[productOfQYLaguerreL, x]}, 
   Sum[coeffs[[i]]*mathcalL[i - 1], {i, 1, Length@coeffs}] // 
       FullSimplify // Expand // FullSimplify // Expand];
Print["lhs=", lhs];
Print["lhs==rhs  ", lhs == rhs];

chars = Apply[Join, 
   Table[ConstantArray[i, nkVec[[i]]], {i, Length@nkVec}]];
Print["chars=", chars];
Print["Derangements of word, then do permutation for each type of \
element in every derangment. Count=", 
  Count[Permutations[chars], x_ /; Inner[UnsameQ, x, chars, And]]*
   Product[nk!, {nk, nkVec}]];
Print["Permutations of [n], then select valid permutations as \
derangments. Count=", derangements // Length];
Print["rhs/.{q->1,y->1} = ", rhs /. {q -> 1, y -> 1}];
Print["lhs/.{q->1,y->1} = ", lhs /. {q -> 1, y -> 1}];

[1] ON LINEARIZATION COEFFICIENTS OF q-LAGUERRE POLYNOMIALS