Simplify the huge determinant product

1

I try to get the following determinant product result,

 nn = 5;
 Unprotect[Times];
 s1[k1_, x1_] s2[k2_, x1_] := 
 If[k1 == k2 || Abs[k1 - k2] == 4, g[k1, k2, x1], 0];
 res = 
  Det[Table[s1[i1, i2], {i1, 1, nn}, {i2, 1, nn}]]*
   Det[Table[s2[i1, i2], {i1, 1, nn}, {i2, 1, nn}]] // ExpandAll;
 res 

If $nn\leq 6$, it is easy to get the result. Now, I want to know, is it possible to find a way to increase nn to $12$ or larger ? The final expression should be ExpandAll.

Update:

Now I realized that $nn=12$ is really too large. It is very difficult if we cannot use some effective arithmetic. So, is it possible for $nn=8$ ?

Orders

Posted 2015-09-30T11:53:42.900

Reputation: 1 127

Can you explain what you think you are doing when you Unprotect[Times];? – bill s – 2015-09-30T12:38:33.000

@bill s just to define the product s1[k1_, x1_] s2[k2_, x1_] . Times is Protected. Of course, this is not a safe method. – Orders – 2015-09-30T12:48:01.530

6You can use TagSetDelayed instead and that is vastly preferable to changing Times. s1 /: s1[k1_, x1_] s2[k2_, x1_] := If[k1 == k2 || Abs[k1 - k2] == 4, g[k1, k2, x1], 0]; – Daniel Lichtblau – 2015-09-30T14:27:00.527

1Also, to handle dimension of 12 you will need to figure out a way that avoids the intermediate determinant computations. The intermediate swell from those will be quite large (that might be an understatement). – Daniel Lichtblau – 2015-09-30T14:29:04.083

@Daniel Lichtblau Yes, nn=12 is really too difficult. Can I ask you to have a try for nn=8 for this problem ? – Orders – 2015-10-05T13:44:24.770

@DanielLichtblau might be an understatement?!? I've crushed computers trying to calculate a determinate that large. – rcollyer – 2015-10-05T14:52:02.587

Answers

1

At the moment, this is just some random thoughts and observations. I will try to morph it into a coherent answer, soon.

First, a determinant can be reasonably calculated using LUDecomposition, e.g.

Clear[ludet];
ludet[nn_] := ludet[nn] = 
 Block[{u, s1},
  u = First@LUDecomposition@Table[s1[i1, i2], {i1, 1, nn}, {i2, 1, nn}];
  Times @@ Diagonal[u SparseArray[{i_, j_} /; j >= i -> 1, Dimensions@u]]
 ]

On my computer, nn == 11 took 40 s, so nn == 12 might be in reach.

Examining the results from the lower orders, you quickly note that the determinant is recursive, e.g.

ludet[n] = ludet[n - 1] nterm

So, you can build up to n == 8 or n == 12 by examining the determinants for the lower n values. My thought is to convert those lower order terms into patterns for use on the higher order terms, i.e. pre-generating the conversion rules to speed things along. This is roughly

origconversion = s1[k1_, x1_] s2[k2_, x1_] :> If[
   k1 == k2 || Abs[k1 - k2] == 4, g[k1, k2, x1], 0];
newconversions = {};

Block[{term = #, eterm, res},
  eterm = # (# /. s1 -> s2)& @ term;
  res = eterm /. newconversions;
  If[ !FreeQ[res, s1|s2],
    res = res /. origconversion;
    newconversions = {makePattern[eterm, res]}~Join~newconversions
  ];
  res
]& /@ ludet[n] (* run for each n *)

with makePattern the missing piece.

rcollyer

Posted 2015-09-30T11:53:42.900

Reputation: 32 561

Seems promising! Thanks for your try for this problem. Looking forward to your final answer. – Orders – 2015-10-06T21:14:42.523

@Orders it will be at least another day until I can get back to this. – rcollyer – 2015-10-07T22:26:07.580