source: git/kernel/linearAlgebra.cc @ c6474a

spielwiese
Last change on this file since c6474a was 1d9b39, checked in by Hans Schoenemann <hannes@…>, 13 years ago
removed defines already in libpolys
  • Property mode set to 100644
File size: 52.7 KB
Line 
1/*****************************************************************************\
2 * Computer Algebra System SINGULAR
3\*****************************************************************************/
4/** @file lineareAlgebra.cc
5 *
6 * This file implements basic linear algebra functionality.
7 *
8 * For more general information, see the documentation in
9 * lineareAlgebra.h.
10 *
11 * @author Frank Seelisch
12 *
13 * @internal @version \$Id$
14 *
15 **/
16/*****************************************************************************/
17
18// include header files
19#include <kernel/mod2.h>
20#include <kernel/structs.h>
21#include <polys/polys.h>
22#include <kernel/ideals.h>
23#include <coeffs/numbers.h>
24#include <polys/matpol.h>
25#include <coeffs/mpr_complex.h>
26#include <kernel/linearAlgebra.h>
27
28/**
29 * The returned score is based on the implementation of 'nSize' for
30 * numbers (, see numbers.h): nSize(n) provides a measure for the
31 * complexity of n. Thus, less complex pivot elements will be
32 * prefered, and get therefore a smaller pivot score. Consequently,
33 * we simply return the value of nSize.
34 * An exception to this rule are the ground fields R, long R, and
35 * long C: In these, the result of nSize relates to |n|. And since
36 * a larger modulus of the pivot element ensures a numerically more
37 * stable Gauss elimination, we would like to have a smaller score
38 * for larger values of |n|. Therefore, in R, long R, and long C,
39 * the negative of nSize will be returned.
40 **/
41int pivotScore(number n)
42{
43  int s = nSize(n);
44  if (rField_is_long_C(currRing) ||
45      rField_is_long_R(currRing) ||
46      rField_is_R(currRing))
47    return -s;
48  else
49    return s;
50}
51
52/**
53 * This code computes a score for each non-zero matrix entry in
54 * aMat[r1..r2, c1..c2]. If all entries are zero, false is returned,
55 * otherwise true. In the latter case, the minimum of all scores
56 * is sought, and the row and column indices of the corresponding
57 * matrix entry are stored in bestR and bestC.
58 **/
59bool pivot(const matrix aMat, const int r1, const int r2, const int c1,
60           const int c2, int* bestR, int* bestC)
61{
62  int bestScore; int score; bool foundBestScore = false; poly matEntry;
63
64  for (int c = c1; c <= c2; c++)
65  {
66    for (int r = r1; r <= r2; r++)
67    {
68      matEntry = MATELEM(aMat, r, c);
69      if (matEntry != NULL)
70      {
71        score = pivotScore(pGetCoeff(matEntry));
72        if ((!foundBestScore) || (score < bestScore))
73        {
74          bestScore = score;
75          *bestR = r;
76          *bestC = c;
77        }
78        foundBestScore = true;
79      }
80    }
81  }
82
83  return foundBestScore;
84}
85
86bool unitMatrix(const int n, matrix &unitMat)
87{
88  if (n < 1) return false;
89  unitMat = mpNew(n, n);
90  for (int r = 1; r <= n; r++) MATELEM(unitMat, r, r) = pOne();
91  return true;
92}
93
94void luDecomp(const matrix aMat, matrix &pMat, matrix &lMat, matrix &uMat)
95{
96  int rr = aMat->rows();
97  int cc = aMat->cols();
98  pMat = mpNew(rr, rr);
99  uMat = mpNew(rr, cc);
100  /* copy aMat into uMat: */
101  for (int r = 1; r <= rr; r++)
102    for (int c = 1; c <= cc; c++)
103      MATELEM(uMat, r, c) = pCopy(aMat->m[c - 1 + (r - 1) * cc]);
104
105  /* we use an int array to store all row permutations;
106     note that we only make use of the entries [1..rr] */
107  int* permut = new int[rr + 1];
108  for (int i = 1; i <= rr; i++) permut[i] = i;
109
110  /* fill lMat with the (rr x rr) unit matrix */
111  unitMatrix(rr, lMat);
112
113  int bestR; int bestC; int intSwap; poly pSwap; int cOffset = 0;
114  for (int r = 1; r < rr; r++)
115  {
116    if (r > cc) break;
117    while ((r + cOffset <= cc) &&
118           (!pivot(uMat, r, rr, r + cOffset, r + cOffset, &bestR, &bestC)))
119      cOffset++;
120    if (r + cOffset <= cc)
121    {
122      /* swap rows with indices r and bestR in permut */
123      intSwap = permut[r];
124      permut[r] = permut[bestR];
125      permut[bestR] = intSwap;
126
127      /* swap rows with indices r and bestR in uMat;
128         it is sufficient to do this for columns >= r + cOffset*/
129      for (int c = r + cOffset; c <= cc; c++)
130      {
131        pSwap = MATELEM(uMat, r, c);
132        MATELEM(uMat, r, c) = MATELEM(uMat, bestR, c);
133        MATELEM(uMat, bestR, c) = pSwap;
134      }
135
136      /* swap rows with indices r and bestR in lMat;
137         we must do this only for columns < r */
138      for (int c = 1; c < r; c++)
139      {
140        pSwap = MATELEM(lMat, r, c);
141        MATELEM(lMat, r, c) = MATELEM(lMat, bestR, c);
142        MATELEM(lMat, bestR, c) = pSwap;
143      }
144
145      /* perform next Gauss elimination step, i.e., below the
146         row with index r;
147         we need to adjust lMat and uMat;
148         we are certain that the matrix entry at [r, r + cOffset]
149         is non-zero: */
150      number pivotElement = pGetCoeff(MATELEM(uMat, r, r + cOffset));
151      poly p; number n;
152      for (int rGauss = r + 1; rGauss <= rr; rGauss++)
153      {
154        p = MATELEM(uMat, rGauss, r + cOffset);
155        if (p != NULL)
156        {
157          n = nDiv(pGetCoeff(p), pivotElement);
158          nNormalize(n);
159
160          /* filling lMat;
161             old entry was zero, so no need to call pDelete(.) */
162          MATELEM(lMat, rGauss, r) = pNSet(nCopy(n));
163
164          /* adjusting uMat: */
165          MATELEM(uMat, rGauss, r + cOffset) = NULL; pDelete(&p);
166          n = nNeg(n);
167          for (int cGauss = r + cOffset + 1; cGauss <= cc; cGauss++)
168          {
169            MATELEM(uMat, rGauss, cGauss)
170              = pAdd(MATELEM(uMat, rGauss, cGauss),
171                     ppMult_nn(MATELEM(uMat, r, cGauss), n));
172            pNormalize(MATELEM(uMat, rGauss, cGauss));
173          }
174
175          nDelete(&n); /* clean up n */
176        }
177      }
178    }
179  }
180
181  /* building the permutation matrix from 'permut' */
182  for (int r = 1; r <= rr; r++)
183    MATELEM(pMat, r, permut[r]) = pOne();
184  delete[] permut;
185
186  return;
187}
188
189/**
190 * This code first computes the LU-decomposition of aMat,
191 * and then calls the method for inverting a matrix which
192 * is given by its LU-decomposition.
193 **/
194bool luInverse(const matrix aMat, matrix &iMat)
195{ /* aMat is guaranteed to be an (n x n)-matrix */
196  matrix pMat;
197  matrix lMat;
198  matrix uMat;
199  luDecomp(aMat, pMat, lMat, uMat);
200  bool result = luInverseFromLUDecomp(pMat, lMat, uMat, iMat);
201
202  /* clean-up */
203  idDelete((ideal*)&pMat);
204  idDelete((ideal*)&lMat);
205  idDelete((ideal*)&uMat);
206
207  return result;
208}
209
210/* Assumes that aMat is already in row echelon form */
211int rankFromRowEchelonForm(const matrix aMat)
212{
213  int rank = 0;
214  int rr = aMat->rows(); int cc = aMat->cols();
215  int r = 1; int c = 1;
216  while ((r <= rr) && (c <= cc))
217  {
218    if (MATELEM(aMat, r, c) == NULL) c++;
219    else { rank++; r++; }
220  }
221  return rank;
222}
223
224int luRank(const matrix aMat, const bool isRowEchelon)
225{
226  if (isRowEchelon) return rankFromRowEchelonForm(aMat);
227  else
228  { /* compute the LU-decomposition and read off the rank from
229       the upper triangular matrix of that decomposition */
230    matrix pMat;
231    matrix lMat;
232    matrix uMat;
233    luDecomp(aMat, pMat, lMat, uMat);
234    int result = rankFromRowEchelonForm(uMat);
235
236    /* clean-up */
237    idDelete((ideal*)&pMat);
238    idDelete((ideal*)&lMat);
239    idDelete((ideal*)&uMat);
240
241    return result;
242  }
243}
244
245bool upperRightTriangleInverse(const matrix uMat, matrix &iMat,
246                               bool diagonalIsOne)
247{
248  int d = uMat->rows();
249  poly p; poly q;
250
251  /* check whether uMat is invertible */
252  bool invertible = diagonalIsOne;
253  if (!invertible)
254  {
255    invertible = true;
256    for (int r = 1; r <= d; r++)
257    {
258      if (MATELEM(uMat, r, r) == NULL)
259      {
260        invertible = false;
261        break;
262      }
263    }
264  }
265
266  if (invertible)
267  {
268    iMat = mpNew(d, d);
269    for (int r = d; r >= 1; r--)
270    {
271      if (diagonalIsOne)
272        MATELEM(iMat, r, r) = pOne();
273      else
274        MATELEM(iMat, r, r) = pNSet(nInvers(pGetCoeff(MATELEM(uMat, r, r))));
275      for (int c = r + 1; c <= d; c++)
276      {
277        p = NULL;
278        for (int k = r + 1; k <= c; k++)
279        {
280          q = ppMult_qq(MATELEM(uMat, r, k), MATELEM(iMat, k, c));
281          p = pAdd(p, q);
282        }
283        p = pNeg(p);
284        p = pMult(p, pCopy(MATELEM(iMat, r, r)));
285        pNormalize(p);
286        MATELEM(iMat, r, c) = p;
287      }
288    }
289  }
290
291  return invertible;
292}
293
294bool lowerLeftTriangleInverse(const matrix lMat, matrix &iMat,
295                              bool diagonalIsOne)
296{
297  int d = lMat->rows(); poly p; poly q;
298
299  /* check whether lMat is invertible */
300  bool invertible = diagonalIsOne;
301  if (!invertible)
302  {
303    invertible = true;
304    for (int r = 1; r <= d; r++)
305    {
306      if (MATELEM(lMat, r, r) == NULL)
307      {
308        invertible = false;
309        break;
310      }
311    }
312  }
313
314  if (invertible)
315  {
316    iMat = mpNew(d, d);
317    for (int c = d; c >= 1; c--)
318    {
319      if (diagonalIsOne)
320        MATELEM(iMat, c, c) = pOne();
321      else
322        MATELEM(iMat, c, c) = pNSet(nInvers(pGetCoeff(MATELEM(lMat, c, c))));
323      for (int r = c + 1; r <= d; r++)
324      {
325        p = NULL;
326        for (int k = c; k <= r - 1; k++)
327        {
328          q = ppMult_qq(MATELEM(lMat, r, k), MATELEM(iMat, k, c));
329          p = pAdd(p, q);
330        }
331        p = pNeg(p);
332        p = pMult(p, pCopy(MATELEM(iMat, c, c)));
333        pNormalize(p);
334        MATELEM(iMat, r, c) = p;
335      }
336    }
337  }
338
339  return invertible;
340}
341
342/**
343 * This code computes the inverse by inverting lMat and uMat, and
344 * then performing two matrix multiplications.
345 **/
346bool luInverseFromLUDecomp(const matrix pMat, const matrix lMat,
347                           const matrix uMat, matrix &iMat)
348{ /* uMat is guaranteed to be quadratic */
349  //int d = uMat->rows();
350
351  matrix lMatInverse; /* for storing the inverse of lMat;
352                         this inversion will always work                */
353  matrix uMatInverse; /* for storing the inverse of uMat, if invertible */
354
355  bool result = upperRightTriangleInverse(uMat, uMatInverse, false);
356  if (result)
357  {
358    /* next will always work, since lMat is known to have all diagonal
359       entries equal to 1 */
360    lowerLeftTriangleInverse(lMat, lMatInverse, true);
361    iMat = mpMult(mpMult(uMatInverse, lMatInverse), pMat);
362
363    /* clean-up */
364    idDelete((ideal*)&lMatInverse);
365    idDelete((ideal*)&uMatInverse);
366  }
367
368  return result;
369}
370
371bool luSolveViaLUDecomp(const matrix pMat, const matrix lMat,
372                        const matrix uMat, const matrix bVec,
373                        matrix &xVec, matrix &H)
374{
375  int m = uMat->rows(); int n = uMat->cols();
376  matrix cVec = mpNew(m, 1);  /* for storing pMat * bVec */
377  matrix yVec = mpNew(m, 1);  /* for storing the unique solution of
378                                 lMat * yVec = cVec */
379
380  /* compute cVec = pMat * bVec but without actual multiplications */
381  for (int r = 1; r <= m; r++)
382  {
383    for (int c = 1; c <= m; c++)
384    {
385      if (MATELEM(pMat, r, c) != NULL)
386        { MATELEM(cVec, r, 1) = pCopy(MATELEM(bVec, c, 1)); break; }
387    }
388  }
389
390  /* solve lMat * yVec = cVec; this will always work as lMat is invertible;
391     moreover, no divisions are needed, since lMat[i, i] = 1, for all i */
392  for (int r = 1; r <= m; r++)
393  {
394    poly p = pNeg(pCopy(MATELEM(cVec, r, 1)));
395    for (int c = 1; c < r; c++)
396      p = pAdd(p, ppMult_qq(MATELEM(lMat, r, c), MATELEM(yVec, c, 1) ));
397    MATELEM(yVec, r, 1) = pNeg(p);
398    pNormalize(MATELEM(yVec, r, 1));
399  }
400
401  /* determine whether uMat * xVec = yVec is solvable */
402  bool isSolvable = true;
403  bool isZeroRow; int nonZeroRowIndex;
404  for (int r = m; r >= 1; r--)
405  {
406    isZeroRow = true;
407    for (int c = 1; c <= n; c++)
408      if (MATELEM(uMat, r, c) != NULL) { isZeroRow = false; break; }
409    if (isZeroRow)
410    {
411      if (MATELEM(yVec, r, 1) != NULL) { isSolvable = false; break; }
412    }
413    else { nonZeroRowIndex = r; break; }
414  }
415
416  if (isSolvable)
417  {
418    xVec = mpNew(n, 1);
419    matrix N = mpNew(n, n); int dim = 0;
420    poly p; poly q;
421    /* solve uMat * xVec = yVec and determine a basis of the solution
422       space of the homogeneous system uMat * xVec = 0;
423       We do not know in advance what the dimension (dim) of the latter
424       solution space will be. Thus, we start with the possibly too wide
425       matrix N and later copy the relevant columns of N into H. */
426    int nonZeroC; int lastNonZeroC = n + 1;
427    for (int r = nonZeroRowIndex; r >= 1; r--)
428    {
429      for (nonZeroC = 1; nonZeroC <= n; nonZeroC++)
430        if (MATELEM(uMat, r, nonZeroC) != NULL) break;
431      for (int w = lastNonZeroC - 1; w >= nonZeroC + 1; w--)
432      {
433        /* this loop will only be done when the given linear system has
434           more than one, i.e., infinitely many solutions */
435        dim++;
436        /* now we fill two entries of the dim-th column of N */
437        MATELEM(N, w, dim) = pNeg(pCopy(MATELEM(uMat, r, nonZeroC)));
438        MATELEM(N, nonZeroC, dim) = pCopy(MATELEM(uMat, r, w));
439      }
440      for (int d = 1; d <= dim; d++)
441      {
442        /* here we fill the entry of N at [r, d], for each valid vector
443           that we already have in N;
444           again, this will only be done when the given linear system has
445           more than one, i.e., infinitely many solutions */
446        p = NULL;
447        for (int c = nonZeroC + 1; c <= n; c++)
448          if (MATELEM(N, c, d) != NULL)
449            p = pAdd(p, ppMult_qq(MATELEM(uMat, r, c), MATELEM(N, c, d)));
450        q = pNSet(nInvers(pGetCoeff(MATELEM(uMat, r, nonZeroC))));
451        MATELEM(N, nonZeroC, d) = pMult(pNeg(p), q);
452        pNormalize(MATELEM(N, nonZeroC, d));
453      }
454      p = pNeg(pCopy(MATELEM(yVec, r, 1)));
455      for (int c = nonZeroC + 1; c <= n; c++)
456        if (MATELEM(xVec, c, 1) != NULL)
457          p = pAdd(p, ppMult_qq(MATELEM(uMat, r, c), MATELEM(xVec, c, 1)));
458      q = pNSet(nInvers(pGetCoeff(MATELEM(uMat, r, nonZeroC))));
459      MATELEM(xVec, nonZeroC, 1) = pMult(pNeg(p), q);
460      pNormalize(MATELEM(xVec, nonZeroC, 1));
461      lastNonZeroC = nonZeroC;
462    }
463    if (dim == 0)
464    {
465      /* that means the given linear system has exactly one solution;
466         we return as H the 1x1 matrix with entry zero */
467      H = mpNew(1, 1);
468    }
469    else
470    {
471      /* copy the first 'dim' columns of N into H */
472      H = mpNew(n, dim);
473      for (int r = 1; r <= n; r++)
474        for (int c = 1; c <= dim; c++)
475          MATELEM(H, r, c) = pCopy(MATELEM(N, r, c));
476    }
477    /* clean up N */
478    idDelete((ideal*)&N);
479  }
480
481  idDelete((ideal*)&cVec);
482  idDelete((ideal*)&yVec);
483
484  return isSolvable;
485}
486
487/* for debugging:
488   for printing numbers to the console
489   DELETE LATER */
490void printNumber(const number z)
491{
492  if (nIsZero(z)) printf("number = 0\n");
493  else
494  {
495    poly p = pOne();
496    pSetCoeff(p, nCopy(z));
497    pSetm(p);
498    printf("number = %s\n", pString(p));
499    pDelete(&p);
500  }
501}
502
503/* for debugging:
504   for printing matrices to the console
505   DELETE LATER */
506void printMatrix(const matrix m)
507{
508  int rr = MATROWS(m); int cc = MATCOLS(m);
509  printf("\n-------------\n");
510  for (int r = 1; r <= rr; r++)
511  {
512    for (int c = 1; c <= cc; c++)
513      printf("%s  ", pString(MATELEM(m, r, c)));
514    printf("\n");
515  }
516  printf("-------------\n");
517}
518
519/**
520 * Creates a new complex number from real and imaginary parts given
521 * by doubles.
522 *
523 * @return the new complex number
524 **/
525number complexNumber(const double r, const double i)
526{
527  gmp_complex* n= new gmp_complex(r, i);
528  return (number)n;
529}
530
531/**
532 * Returns one over the exponent-th power of ten.
533 *
534 * The method assumes that the base ring is the complex numbers.
535 *
536 * return one over the exponent-th power of 10
537 **/
538number tenToTheMinus(
539       const int exponent  /**< [in]  the exponent for 1/10 */
540                    )
541{
542  number ten = complexNumber(10.0, 0.0);
543  number result = complexNumber(1.0, 0.0);
544  number tmp;
545  /* compute 10^{-exponent} inside result by subsequent divisions by 10 */
546  for (int i = 1; i <= exponent; i++)
547  {
548    tmp = nDiv(result, ten);
549    nDelete(&result);
550    result = tmp;
551  }
552  nDelete(&ten);
553  return result;
554}
555
556/* for debugging:
557   for printing numbers to the console
558   DELETE LATER */
559void printSolutions(const int a, const int b, const int c)
560{
561  printf("\n------\n");
562  /* build the polynomial a*x^2 + b*x + c: */
563  poly p = NULL; poly q = NULL; poly r = NULL;
564  if (a != 0)
565  { p = pOne(); pSetExp(p, 1, 2); pSetm(p); pSetCoeff(p, nInit(a)); }
566  if (b != 0)
567  { q = pOne(); pSetExp(q, 1, 1); pSetm(q); pSetCoeff(q, nInit(b)); }
568  if (c != 0)
569  { r = pOne(); pSetCoeff(r, nInit(c)); }
570  p = pAdd(p, q); p = pAdd(p, r);
571  printf("poly = %s\n", pString(p));
572  number tol = tenToTheMinus(20);
573  number s1; number s2; int nSol = quadraticSolve(p, s1, s2, tol);
574  nDelete(&tol);
575  printf("solution code = %d\n", nSol);
576  if ((1 <= nSol) && (nSol <= 3))
577  {
578    if (nSol != 3) { printNumber(s1); nDelete(&s1); }
579    else { printNumber(s1); nDelete(&s1); printNumber(s2); nDelete(&s2); }
580  }
581  printf("------\n");
582  pDelete(&p);
583}
584
585bool realSqrt(const number n, const number tolerance, number &root)
586{
587  if (!nGreaterZero(n)) return false;
588  if (nIsZero(n)) return nInit(0);
589
590  number oneHalf = complexNumber(0.5, 0.0);
591  number nHalf   = nMult(n, oneHalf);
592  root           = nCopy(n);
593  number nOld    = complexNumber(10.0, 0.0);
594  number nDiff   = nCopy(nOld);
595
596  while (nGreater(nDiff, tolerance))
597  {
598    nDelete(&nOld);
599    nOld = root;
600    root = nAdd(nMult(oneHalf, nOld), nDiv(nHalf, nOld));
601    nDelete(&nDiff);
602    nDiff = nSub(nOld, root);
603    if (!nGreaterZero(nDiff)) nDiff = nNeg(nDiff);
604  }
605
606  nDelete(&nOld); nDelete(&nDiff); nDelete(&oneHalf); nDelete(&nHalf);
607  return true;
608}
609
610int quadraticSolve(const poly p, number &s1, number &s2,
611                   const number tolerance)
612{
613  poly q = pCopy(p);
614  int result;
615
616  if (q == NULL) result = -1;
617  else
618  {
619    int degree = pGetExp(q, 1);
620    if (degree == 0) result = 0;   /* constant polynomial <> 0 */
621    else
622    {
623      number c2 = nInit(0);   /* coefficient of var(1)^2 */
624      number c1 = nInit(0);   /* coefficient of var(1)^1 */
625      number c0 = nInit(0);   /* coefficient of var(1)^0 */
626      if (pGetExp(q, 1) == 2)
627      { nDelete(&c2); c2 = nCopy(pGetCoeff(q)); q = q->next; }
628      if ((q != NULL) && (pGetExp(q, 1) == 1))
629      { nDelete(&c1); c1 = nCopy(pGetCoeff(q)); q = q->next; }
630      if ((q != NULL) && (pGetExp(q, 1) == 0))
631      { nDelete(&c0); c0 = nCopy(pGetCoeff(q)); q = q->next; }
632
633      if (degree == 1)
634      {
635        c0 = nNeg(c0);
636        s1 = nDiv(c0, c1);
637        result = 1;
638      }
639      else
640      {
641        number tmp = nMult(c0, c2);
642        number tmp2 = nAdd(tmp, tmp); nDelete(&tmp);
643        number tmp4 = nAdd(tmp2, tmp2); nDelete(&tmp2);
644        number discr = nSub(nMult(c1, c1), tmp4); nDelete(&tmp4);
645        if (nIsZero(discr))
646        {
647          tmp = nAdd(c2, c2);
648          s1 = nDiv(c1, tmp); nDelete(&tmp);
649          s1 = nNeg(s1);
650          result = 2;
651        }
652        else if (nGreaterZero(discr))
653        {
654          realSqrt(discr, tolerance, tmp);   /* sqrt of the discriminant */
655          tmp2 = nSub(tmp, c1);
656          tmp4 = nAdd(c2, c2);
657          s1 = nDiv(tmp2, tmp4); nDelete(&tmp2);
658          tmp = nNeg(tmp);
659          tmp2 = nSub(tmp, c1); nDelete(&tmp);
660          s2 = nDiv(tmp2, tmp4); nDelete(&tmp2); nDelete(&tmp4);
661          result = 3;
662        }
663        else
664        {
665          discr = nNeg(discr);
666          realSqrt(discr, tolerance, tmp);   /* sqrt of |discriminant| */
667          tmp2 = nAdd(c2, c2);
668          tmp4 = nDiv(tmp, tmp2); nDelete(&tmp);
669          tmp = nDiv(c1, tmp2); nDelete(&tmp2);
670          tmp = nNeg(tmp);
671          s1 = (number)new gmp_complex(((gmp_complex*)tmp)->real(),
672                                       ((gmp_complex*)tmp4)->real());
673          tmp4 = nNeg(tmp4);
674          s2 = (number)new gmp_complex(((gmp_complex*)tmp)->real(),
675                                       ((gmp_complex*)tmp4)->real());
676          nDelete(&tmp); nDelete(&tmp4);
677          result = 3;
678        }
679        nDelete(&discr);
680      }
681      nDelete(&c0); nDelete(&c1); nDelete(&c2);
682    }
683  }
684  pDelete(&q);
685
686  return result;
687}
688
689number euclideanNormSquared(const matrix aMat)
690{
691  int rr = MATROWS(aMat);
692  number result = nInit(0);
693  number tmp1; number tmp2;
694  for (int r = 1; r <= rr; r++)
695    if (MATELEM(aMat, r, 1) != NULL)
696    {
697      tmp1 = nMult(pGetCoeff(MATELEM(aMat, r, 1)),
698                   pGetCoeff(MATELEM(aMat, r, 1)));
699      tmp2 = nAdd(result, tmp1); nDelete(&result); nDelete(&tmp1);
700      result = tmp2;
701    }
702  return result;
703}
704
705/* Returns a new number which is the absolute value of the coefficient
706   of the given polynomial.
707 *
708 * The method assumes that the coefficient has imaginary part zero. */
709number absValue(poly p)
710{
711  if (p == NULL) return nInit(0);
712  number result = nCopy(pGetCoeff(p));
713  if (!nGreaterZero(result)) result = nNeg(result);
714  return result;
715}
716
717bool subMatrix(const matrix aMat, const int rowIndex1, const int rowIndex2,
718               const int colIndex1, const int colIndex2, matrix &subMat)
719{
720  if (rowIndex1 > rowIndex2) return false;
721  if (colIndex1 > colIndex2) return false;
722  int rr = rowIndex2 - rowIndex1 + 1;
723  int cc = colIndex2 - colIndex1 + 1;
724  subMat = mpNew(rr, cc);
725  for (int r = 1; r <= rr; r++)
726    for (int c = 1; c <= cc; c++)
727      MATELEM(subMat, r, c) =
728        pCopy(MATELEM(aMat, rowIndex1 + r - 1, colIndex1 + c - 1));
729  return true;
730}
731
732bool charPoly(const matrix aMat, poly &charPoly)
733{
734  if (MATROWS(aMat) != 2) return false;
735  if (MATCOLS(aMat) != 2) return false;
736  number b = nInit(0); number t;
737  if (MATELEM(aMat, 1, 1) != NULL)
738  { t = nAdd(b, pGetCoeff(MATELEM(aMat, 1, 1))); nDelete(&b); b = t;}
739  if (MATELEM(aMat, 2, 2) != NULL)
740  { t = nAdd(b, pGetCoeff(MATELEM(aMat, 2, 2))); nDelete(&b); b = t;}
741  b = nNeg(b);
742  number t1;
743  if ((MATELEM(aMat, 1, 1) != NULL) && (MATELEM(aMat, 2, 2) != NULL))
744    t1 = nMult(pGetCoeff(MATELEM(aMat, 1, 1)),
745               pGetCoeff(MATELEM(aMat, 2, 2)));
746  else t1 = nInit(0);
747  number t2;
748  if ((MATELEM(aMat, 1, 2) != NULL) && (MATELEM(aMat, 2, 1) != NULL))
749    t2 = nMult(pGetCoeff(MATELEM(aMat, 1, 2)),
750               pGetCoeff(MATELEM(aMat, 2, 1)));
751  else t2 = nInit(0);
752  number c = nSub(t1, t2); nDelete(&t1); nDelete(&t2);
753  poly p = pOne(); pSetExp(p, 1, 2); pSetm(p);
754  poly q = NULL;
755  if (!nIsZero(b))
756  { q = pOne(); pSetExp(q, 1, 1); pSetm(q); pSetCoeff(q, b); }
757  poly r = NULL;
758  if (!nIsZero(c))
759  { r = pOne(); pSetCoeff(r, c); }
760  p = pAdd(p, q); p = pAdd(p, r);
761  charPoly = p;
762  return true;
763}
764
765void swapRows(int row1, int row2, matrix& aMat)
766{
767  poly p;
768  int cc = MATCOLS(aMat);
769  for (int c = 1; c <= cc; c++)
770  {
771    p = MATELEM(aMat, row1, c);
772    MATELEM(aMat, row1, c) = MATELEM(aMat, row2, c);
773    MATELEM(aMat, row2, c) = p;
774  }
775}
776
777void swapColumns(int column1, int column2,  matrix& aMat)
778{
779  poly p;
780  int rr = MATROWS(aMat);
781  for (int r = 1; r <= rr; r++)
782  {
783    p = MATELEM(aMat, r, column1);
784    MATELEM(aMat, r, column1) = MATELEM(aMat, r, column2);
785    MATELEM(aMat, r, column2) = p;
786  }
787}
788
789void matrixBlock(const matrix aMat, const matrix bMat, matrix &block)
790{
791  int rowsA = MATROWS(aMat);
792  int rowsB = MATROWS(bMat);
793  int n = rowsA + rowsB;
794  block = mpNew(n, n);
795  for (int i = 1; i <= rowsA; i++)
796    for (int j = 1; j <= rowsA; j++)
797      MATELEM(block, i, j) = pCopy(MATELEM(aMat, i, j));
798  for (int i = 1; i <= rowsB; i++)
799    for (int j = 1; j <= rowsB; j++)
800      MATELEM(block, i + rowsA, j + rowsA) = pCopy(MATELEM(bMat, i, j));
801}
802
803/**
804 * Computes information related to one householder transformation step for
805 * constructing the Hessenberg form of a given non-derogative matrix.
806 *
807 * The method assumes that all matrix entries are numbers coming from some
808 * subfield of the reals. And that v has a non-zero first entry v_1 and a
809 * second non-zero entry somewhere else.
810 * Given such a vector v, it computes a number r (which will be the return
811 * value of the method), a vector u and a matrix P such that:
812 * 1) P * v = r * e_1,
813 * 2) P = E - u * u^T,
814 * 3) P = P^{-1}.
815 * Note that enforcing norm(u) = sqrt(2), which is done in the algorithm,
816 * guarantees property 3). This can be checked by expanding P^2 using
817 * property 2).
818 *
819 * @return the number r
820 **/
821number hessenbergStep(
822      const matrix vVec,     /**< [in]  the input vector v */
823      matrix &uVec,          /**< [out] the output vector u */
824      matrix &pMat,          /**< [out] the output matrix P */
825      const number tolerance /**< [in]  accuracy for square roots */
826                      )
827{
828  int rr = MATROWS(vVec);
829  number vNormSquared = euclideanNormSquared(vVec);
830  number vNorm; realSqrt(vNormSquared, tolerance, vNorm);
831  /* v1 is guaranteed to be non-zero: */
832  number v1 = pGetCoeff(MATELEM(vVec, 1, 1));
833  bool v1Sign = true; if (nGreaterZero(v1)) v1Sign = false;
834
835  number v1Abs = nCopy(v1); if (v1Sign) v1Abs = nNeg(v1Abs);
836  number t1 = nDiv(v1Abs, vNorm);
837  number one = nInit(1);
838  number t2 = nAdd(t1, one); nDelete(&t1);
839  number denominator; realSqrt(t2, tolerance, denominator); nDelete(&t2);
840  uVec = mpNew(rr, 1);
841  t1 = nDiv(v1Abs, vNorm);
842  t2 = nAdd(t1, one); nDelete(&t1);
843  t1 = nDiv(t2, denominator); nDelete(&t2);
844  MATELEM(uVec, 1, 1) = pOne();
845  pSetCoeff(MATELEM(uVec, 1, 1), t1);   /* we know that t1 != 0 */
846  for (int r = 2; r <= rr; r++)
847  {
848    if (MATELEM(vVec, r, 1) != NULL)
849      t1 = nCopy(pGetCoeff(MATELEM(vVec, r, 1)));
850    else t1 = nInit(0);
851    if (v1Sign) t1 = nNeg(t1);
852    t2 = nDiv(t1, vNorm); nDelete(&t1);
853    t1 = nDiv(t2, denominator); nDelete(&t2);
854    if (!nIsZero(t1))
855    {
856      MATELEM(uVec, r, 1) = pOne();
857      pSetCoeff(MATELEM(uVec, r, 1), t1);
858    }
859    else nDelete(&t1);
860  }
861  nDelete(&denominator);
862
863  /* finished building vector u; now turn to pMat */
864  pMat = mpNew(rr, rr);
865  /* we set P := E - u * u^T, as desired */
866  for (int r = 1; r <= rr; r++)
867    for (int c = 1; c <= rr; c++)
868    {
869      if ((MATELEM(uVec, r, 1) != NULL) && (MATELEM(uVec, c, 1) != NULL))
870        t1 = nMult(pGetCoeff(MATELEM(uVec, r, 1)),
871                   pGetCoeff(MATELEM(uVec, c, 1)));
872      else t1 = nInit(0);
873      if (r == c) { t2 = nSub(one, t1); nDelete(&t1); }
874      else          t2 = nNeg(t1);
875      if (!nIsZero(t2))
876      {
877        MATELEM(pMat, r, c) = pOne();
878        pSetCoeff(MATELEM(pMat, r, c), t2);
879      }
880      else nDelete(&t2);
881    }
882  nDelete(&one);
883  /* finished building pMat; now compute the return value */
884  t1 = vNormSquared; if (v1Sign) t1 = nNeg(t1);
885  t2 = nMult(v1, vNorm);
886  number t3 = nAdd(t1, t2); nDelete(&t1); nDelete(&t2);
887  t1 = nAdd(v1Abs, vNorm); nDelete(&v1Abs); nDelete(&vNorm);
888  t2 = nDiv(t3, t1); nDelete(&t1); nDelete(&t3);
889  t2 = nNeg(t2);
890  return t2;
891}
892
893void hessenberg(const matrix aMat, matrix &pMat, matrix &hessenbergMat,
894                const number tolerance)
895{
896  int n = MATROWS(aMat);
897  unitMatrix(n, pMat);
898  subMatrix(aMat, 1, n, 1, n, hessenbergMat);
899  for (int c = 1; c <= n; c++)
900  {
901    /* find one or two non-zero entries in the current column */
902    int r1 = 0; int r2 = 0;
903    for (int r = c + 1; r <= n; r++)
904      if (MATELEM(hessenbergMat, r, c) != NULL)
905      {
906        if      (r1 == 0)   r1 = r;
907        else if (r2 == 0) { r2 = r; break; }
908      }
909    if (r1 != 0)
910    { /* At least one entry in the current column is non-zero. */
911      if (r1 != c + 1)
912      { /* swap rows to bring non-zero element to row with index c + 1 */
913        swapRows(r1, c + 1, hessenbergMat);
914        /* now also swap columns to reflect action of permutation
915           from the right-hand side */
916        swapColumns(r1, c + 1, hessenbergMat);
917        /* include action of permutation also in pMat */
918        swapRows(r1, c + 1, pMat);
919      }
920      if (r2 != 0)
921      { /* There is at least one more non-zero element in the current
922           column. So let us perform a hessenberg step in order to make
923           all additional non-zero elements zero. */
924        matrix v; subMatrix(hessenbergMat, c + 1, n, c, c, v);
925        matrix u; matrix pTmp;
926        number r = hessenbergStep(v, u, pTmp, tolerance);
927        idDelete((ideal*)&v); idDelete((ideal*)&u); nDelete(&r);
928        /* pTmp just acts on the lower right block of hessenbergMat;
929           i.e., it needs to be extended by a unit matrix block at the top
930           left in order to define a whole transformation matrix;
931           this code may be optimized */
932        unitMatrix(c, u);
933        matrix pTmpFull; matrixBlock(u, pTmp, pTmpFull);
934        idDelete((ideal*)&u); idDelete((ideal*)&pTmp);
935        /* now include pTmpFull in pMat (by letting it act from the left) */
936        pTmp = mpMult(pTmpFull, pMat); idDelete((ideal*)&pMat);
937        pMat = pTmp;
938        /* now let pTmpFull act on hessenbergMat from the left and from the
939           right (note that pTmpFull is self-inverse) */
940        pTmp = mpMult(pTmpFull, hessenbergMat);
941        idDelete((ideal*)&hessenbergMat);
942        hessenbergMat = mpMult(pTmp, pTmpFull);
943        idDelete((ideal*)&pTmp); idDelete((ideal*)&pTmpFull);
944        /* as there may be inaccuracy, we erase those entries of hessenbergMat
945           which must have become zero by the last transformation */
946        for (int r = c + 2; r <= n; r++)
947          pDelete(&MATELEM(hessenbergMat, r, c));
948      }
949    }
950  }
951}
952
953/**
954 * Performs one transformation step on the given matrix H as part of
955 * the gouverning QR double shift algorith.
956 * The method will change the given matrix H side-effect-wise. The resulting
957 * matrix H' will be in Hessenberg form.
958 * The iteration index is needed, since for the 11th and 21st iteration,
959 * the transformation step is different from the usual step, to avoid
960 * convergence problems of the gouverning QR double shift process (who is
961 * also the only caller of this method).
962 **/
963void mpTrafo(
964      matrix &H,             /**< [in/out]  the matrix to be transformed */
965      int it,                /**< [in]      iteration index */
966      const number tolerance /**< [in]      accuracy for square roots */
967            )
968{
969  int n = MATROWS(H);
970  number trace; number det; number tmp1; number tmp2; number tmp3;
971
972  if ((it != 11) && (it != 21)) /* the standard case */
973  {
974    /* in this case 'trace' will really be the trace of the lowermost
975       (2x2) block of hMat */
976    trace = nInit(0);
977    det = nInit(0);
978    if (MATELEM(H, n - 1, n - 1) != NULL)
979    {
980      tmp1 = nAdd(trace, pGetCoeff(MATELEM(H, n - 1, n - 1)));
981      nDelete(&trace);
982      trace = tmp1;
983    }
984    if (MATELEM(H, n, n) != NULL)
985    {
986      tmp1 = nAdd(trace, pGetCoeff(MATELEM(H, n, n)));
987      nDelete(&trace);
988      trace = tmp1;
989    }
990    /* likewise 'det' will really be the determinante of the lowermost
991       (2x2) block of hMat */
992    if ((MATELEM(H, n - 1, n - 1 ) != NULL) && (MATELEM(H, n, n) != NULL))
993    {
994      tmp1 = nMult(pGetCoeff(MATELEM(H, n - 1, n - 1)),
995                   pGetCoeff(MATELEM(H, n, n)));
996      tmp2 = nAdd(tmp1, det); nDelete(&tmp1); nDelete(&det);
997      det = tmp2;
998    }
999    if ((MATELEM(H, n - 1, n) != NULL) && (MATELEM(H, n, n - 1) != NULL))
1000    {
1001      tmp1 = nMult(pGetCoeff(MATELEM(H, n - 1, n)),
1002                   pGetCoeff(MATELEM(H, n, n - 1)));
1003      tmp2 = nSub(det, tmp1); nDelete(&tmp1); nDelete(&det);
1004      det = tmp2;
1005    }
1006  }
1007  else
1008  {
1009    /* for it = 11 or it = 21, we use special formulae to avoid convergence
1010       problems of the gouverning QR double shift algorithm (who is the only
1011       caller of this method) */
1012    /* trace = 3/2 * (|hMat[n, n-1]| + |hMat[n-1, n-2]|) */
1013    tmp1 = nInit(0);
1014    if (MATELEM(H, n, n - 1) != NULL)
1015    { nDelete(&tmp1); tmp1 = nCopy(pGetCoeff(MATELEM(H, n, n - 1))); }
1016    if (!nGreaterZero(tmp1)) tmp1 = nNeg(tmp1);
1017    tmp2 = nInit(0);
1018    if (MATELEM(H, n - 1, n - 2) != NULL)
1019    { nDelete(&tmp2); tmp2 = nCopy(pGetCoeff(MATELEM(H, n - 1, n - 2))); }
1020    if (!nGreaterZero(tmp2)) tmp2 = nNeg(tmp2);
1021    tmp3 = nAdd(tmp1, tmp2); nDelete(&tmp1); nDelete(&tmp2);
1022    tmp1 = nInit(3); tmp2 = nInit(2);
1023    trace = nDiv(tmp1, tmp2); nDelete(&tmp1); nDelete(&tmp2);
1024    tmp1 = nMult(tmp3, trace); nDelete(&trace);
1025    trace = tmp1;
1026    /* det = (|hMat[n, n-1]| + |hMat[n-1, n-2]|)^2 */
1027    det = nMult(tmp3, tmp3); nDelete(&tmp3);
1028  }
1029  matrix c = mpNew(n, 1);
1030  trace = nNeg(trace);
1031  MATELEM(c,1,1) = pAdd(pAdd(pAdd(ppMult_qq(MATELEM(H,1,1), MATELEM(H,1,1)),
1032                                  ppMult_qq(MATELEM(H,1,2), MATELEM(H,2,1))),
1033                             ppMult_nn(MATELEM(H,1,1), trace)),
1034                        pMult_nn(pOne(), det));
1035  MATELEM(c,2,1) = pAdd(pMult(pCopy(MATELEM(H,2,1)),
1036                              pAdd(pCopy(MATELEM(H,1,1)),
1037                                   pCopy(MATELEM(H,2,2)))),
1038                        ppMult_nn(MATELEM(H,2,1), trace));
1039  MATELEM(c,3,1) = ppMult_qq(MATELEM(H,2,1), MATELEM(H,3,2));
1040  nDelete(&trace); nDelete(&det);
1041
1042  /* for applying hessenbergStep, we need to make sure that c[1, 1] is
1043     not zero */
1044  if ((MATELEM(c,1,1) != NULL) &&
1045      ((MATELEM(c,2,1) != NULL) || (MATELEM(c,3,1) != NULL)))
1046  {
1047    matrix uVec; matrix hMat;
1048    tmp1 = hessenbergStep(c, uVec, hMat, tolerance); nDelete(&tmp1);
1049    /* now replace H by hMat * H * hMat: */
1050    matrix wMat = mpMult(hMat, H); idDelete((ideal*)&H);
1051    matrix H1 = mpMult(wMat, hMat);
1052    idDelete((ideal*)&wMat); idDelete((ideal*)&hMat);
1053    /* now need to re-establish Hessenberg form of H1 and put it in H */
1054    hessenberg(H1, wMat, H, tolerance);
1055    idDelete((ideal*)&wMat); idDelete((ideal*)&H1);
1056  }
1057  else if ((MATELEM(c,1,1) == NULL) && (MATELEM(c,2,1) != NULL))
1058  {
1059    swapRows(1, 2, H);
1060    swapColumns(1, 2, H);
1061  }
1062  else if ((MATELEM(c,1,1) == NULL) && (MATELEM(c,3,1) != NULL))
1063  {
1064    swapRows(1, 3, H);
1065    swapColumns(1, 3, H);
1066  }
1067  else
1068  { /* c is the zero vector or a multiple of e_1;
1069       no hessenbergStep needed */ }
1070}
1071
1072/* helper for qrDoubleShift */
1073bool qrDS(
1074       const int n,
1075       matrix* queue,
1076       int& queueL,
1077       number* eigenValues,
1078       int& eigenValuesL,
1079       const number tol1,
1080       const number tol2
1081         )
1082{
1083  bool deflationFound = true;
1084  /* we loop until the working queue is empty,
1085     provided we always find deflation */
1086  while (deflationFound && (queueL > 0))
1087  {
1088    /* take out last queue entry */
1089    matrix currentMat = queue[queueL - 1]; queueL--;
1090    int m = MATROWS(currentMat);
1091    if (m == 1)
1092    {
1093      number newEigenvalue;
1094      /* the entry at [1, 1] is the eigenvalue */
1095      if (MATELEM(currentMat, 1, 1) == NULL) newEigenvalue = nInit(0);
1096      else newEigenvalue = nCopy(pGetCoeff(MATELEM(currentMat, 1, 1)));
1097      eigenValues[eigenValuesL++] = newEigenvalue;
1098    }
1099    else if (m == 2)
1100    {
1101      /* there are two eigenvalues which come as zeros of the characteristic
1102         polynomial */
1103      poly p; charPoly(currentMat, p);
1104      number s1; number s2;
1105      int nSol = quadraticSolve(p, s1, s2, tol2); pDelete(&p);
1106      assume(nSol >= 2);
1107      eigenValues[eigenValuesL++] = s1;
1108      /* if nSol = 2, then s1 is a double zero, and s2 is invalid: */
1109      if (nSol == 2) s2 = nCopy(s1);
1110      eigenValues[eigenValuesL++] = s2;
1111    }
1112    else /* m > 2 */
1113    {
1114      /* bring currentMat into Hessenberg form to fasten computations: */
1115      matrix mm1; matrix mm2;
1116      hessenberg(currentMat, mm1, mm2, tol2);
1117      idDelete((ideal*)&currentMat); idDelete((ideal*)&mm1);
1118      currentMat = mm2;
1119      int it = 1; bool doLoop = true;
1120      while (doLoop && (it <= 30 * m))
1121      {
1122        /* search for deflation */
1123        number w1; number w2;
1124        number test1; number test2; bool stopCriterion = false; int k;
1125        for (k = 1; k < m; k++)
1126        {
1127          test1 = absValue(MATELEM(currentMat, k + 1, k));
1128          w1 = absValue(MATELEM(currentMat, k, k));
1129          w2 = absValue(MATELEM(currentMat, k + 1, k + 1));
1130          test2 = nMult(tol1, nAdd(w1, w2));
1131          nDelete(&w1); nDelete(&w2);
1132          if (!nGreater(test1, test2)) stopCriterion = true;
1133          nDelete(&test1); nDelete(&test2);
1134          if (stopCriterion) break;
1135        }
1136        if (k < m)   /* found deflation at position (k + 1, k) */
1137        {
1138          pDelete(&MATELEM(currentMat, k + 1, k)); /* make this entry zero */
1139          subMatrix(currentMat, 1, k, 1, k, queue[queueL++]);
1140          subMatrix(currentMat, k + 1, m, k + 1, m, queue[queueL++]);
1141          doLoop = false;
1142        }
1143        else   /* no deflation found yet */
1144        {
1145          mpTrafo(currentMat, it, tol2);
1146          it++;   /* try again */
1147        }
1148      }
1149      if (doLoop)   /* could not find deflation for currentMat */
1150      {
1151        deflationFound = false;
1152      }
1153      idDelete((ideal*)&currentMat);
1154    }
1155  }
1156  return deflationFound;
1157}
1158
1159/**
1160 * Tries to find the number n in the array nn[0..nnLength-1].
1161 *
1162 * The method assumes that the ground field is the complex numbers.
1163 * n and an entry of nn will be regarded equal when the absolute
1164 * value of their difference is not larger than the given tolerance.
1165 * In this case, the index of the respective entry of nn is returned,
1166 * otherwise -1.
1167 *
1168 * @return the index of n in nn (up to tolerance) or -1
1169 **/
1170int similar(
1171       const number* nn,       /**< [in] array of numbers to look-up */
1172       const int nnLength,     /**< [in] length of nn                */
1173       const number n,         /**< [in] number to loop-up in nn     */
1174       const number tolerance  /**< [in] tolerance for comparison    */
1175           )
1176{
1177  int result = -1;
1178  number tt = nMult(tolerance, tolerance);
1179  number nr = (number)new gmp_complex(((gmp_complex*)n)->real());
1180  number ni = (number)new gmp_complex(((gmp_complex*)n)->imag());
1181  number rr; number ii;
1182  number w1; number w2; number w3; number w4; number w5;
1183  for (int i = 0; i < nnLength; i++)
1184  {
1185    rr = (number)new gmp_complex(((gmp_complex*)nn[i])->real());
1186    ii = (number)new gmp_complex(((gmp_complex*)nn[i])->imag());
1187    w1 = nSub(nr, rr); w2 = nMult(w1, w1);
1188    w3 = nSub(ni, ii); w4 = nMult(w3, w3);
1189    w5 = nAdd(w2, w4);
1190    if (!nGreater(w5, tt)) result = i;
1191    nDelete(&w1); nDelete(&w2); nDelete(&w3); nDelete(&w4);
1192                nDelete(&w5); nDelete(&rr); nDelete(&ii);
1193    if (result != -1) break;
1194  }
1195  nDelete(&tt); nDelete(&nr); nDelete(&ni);
1196  return result;
1197}
1198
1199lists qrDoubleShift(const matrix A, const number tol1, const number tol2,
1200                    const number tol3)
1201{
1202  int n = MATROWS(A);
1203  matrix* queue = new matrix[n];
1204  queue[0] = mpCopy(A); int queueL = 1;
1205  number* eigenVs = new number[n]; int eigenL = 0;
1206  /* here comes the main call: */
1207  bool worked = qrDS(n, queue, queueL, eigenVs, eigenL, tol1, tol2);
1208  lists result = (lists)omAlloc(sizeof(slists));
1209  if (!worked)
1210  {
1211    for (int i = 0; i < eigenL; i++)
1212      nDelete(&eigenVs[i]);
1213    delete [] eigenVs;
1214    for (int i = 0; i < queueL; i++)
1215      idDelete((ideal*)&queue[i]);
1216    delete [] queue;
1217    result->Init(1);
1218    result->m[0].rtyp = INT_CMD;
1219    result->m[0].data = (void*)0;   /* a list with a single entry
1220                                             which is the int zero */
1221  }
1222  else
1223  {
1224    /* now eigenVs[0..eigenL-1] contain all eigenvalues; among them, there
1225       may be equal entries */
1226    number* distinctEVs = new number[n]; int distinctC = 0;
1227    int* mults = new int[n];
1228    for (int i = 0; i < eigenL; i++)
1229    {
1230      int index = similar(distinctEVs, distinctC, eigenVs[i], tol3);
1231      if (index == -1) /* a new eigenvalue */
1232      {
1233        distinctEVs[distinctC] = nCopy(eigenVs[i]);
1234        mults[distinctC++] = 1;
1235      }
1236      else mults[index]++;
1237      nDelete(&eigenVs[i]);
1238    }
1239    delete [] eigenVs;
1240
1241    lists eigenvalues = (lists)omAlloc(sizeof(slists));
1242    eigenvalues->Init(distinctC);
1243    lists multiplicities = (lists)omAlloc(sizeof(slists));
1244    multiplicities->Init(distinctC);
1245    for (int i = 0; i < distinctC; i++)
1246    {
1247      eigenvalues->m[i].rtyp = NUMBER_CMD;
1248      eigenvalues->m[i].data = (void*)nCopy(distinctEVs[i]);
1249      multiplicities->m[i].rtyp = INT_CMD;
1250      multiplicities->m[i].data = (void*)mults[i];
1251      nDelete(&distinctEVs[i]);
1252    }
1253    delete [] distinctEVs; delete [] mults;
1254
1255    result->Init(2);
1256    result->m[0].rtyp = LIST_CMD;
1257    result->m[0].data = (char*)eigenvalues;
1258    result->m[1].rtyp = LIST_CMD;
1259    result->m[1].data = (char*)multiplicities;
1260  }
1261  return result;
1262}
1263
1264/* This codes assumes that there are at least two variables in the current
1265   base ring. No assumption is made regarding the monomial ordering. */
1266void henselFactors(const int xIndex, const int yIndex, const poly h,
1267                   const poly f0, const poly g0, const int d, poly &f, poly &g)
1268{
1269  int n = (int)pDeg(f0);
1270  int m = (int)pDeg(g0);
1271  matrix aMat = mpNew(n + m, n + m);     /* matrix A for linear system */
1272  matrix pMat; matrix lMat; matrix uMat; /* for the decomposition of A */
1273  f = pCopy(f0); g = pCopy(g0);          /* initially: h = f*g mod <x^1> */
1274
1275  /* initial step: read off coefficients of f0, and g0 */
1276  poly p = f0; poly matEntry; number c;
1277  while (p != NULL)
1278  {
1279    c = nCopy(pGetCoeff(p));
1280    matEntry = pOne(); pSetCoeff(matEntry, c);
1281    MATELEM(aMat, pGetExp(p, yIndex) + 1, 1) = matEntry;
1282    p = pNext(p);
1283  }
1284  p = g0;
1285  while (p != NULL)
1286  {
1287    c = nCopy(pGetCoeff(p));
1288    matEntry = pOne(); pSetCoeff(matEntry, c);
1289    MATELEM(aMat, pGetExp(p, yIndex) + 1, m + 1) = matEntry;
1290    p = pNext(p);
1291  }
1292  /* fill the rest of A */
1293  for (int row = 2; row <= n + 1; row++)
1294    for (int col = 2; col <= m; col++)
1295    {
1296      if (col > row) break;
1297      MATELEM(aMat, row, col) = pCopy(MATELEM(aMat, row - 1, col - 1));
1298    }
1299  for (int row = n + 2; row <= n + m; row++)
1300    for (int col = row - n; col <= m; col++)
1301      MATELEM(aMat, row, col) = pCopy(MATELEM(aMat, row - 1, col - 1));
1302  for (int row = 2; row <= m + 1; row++)
1303    for (int col = m + 2; col <= m + n; col++)
1304    {
1305      if (col - m > row) break;
1306      MATELEM(aMat, row, col) = pCopy(MATELEM(aMat, row - 1, col - 1));
1307    }
1308  for (int row = m + 2; row <= n + m; row++)
1309    for (int col = row; col <= m + n; col++)
1310      MATELEM(aMat, row, col) = pCopy(MATELEM(aMat, row - 1, col - 1));
1311
1312  /* constructing the LU-decomposition of A */
1313  luDecomp(aMat, pMat, lMat, uMat);
1314
1315  /* Before the xExp-th loop, we know that h = f*g mod <x^xExp>.
1316     Afterwards the algorithm ensures      h = f*g mod <x^(xExp + 1)>.
1317     Hence in the end we obtain f and g as required, i.e.,
1318                                           h = f*g mod <x^(d+1)>.
1319     The algorithm works by solving a (m+n)x(m+n) linear equation system
1320     A*x = b with constant matrix A (as decomposed above). By theory, the
1321     system is guaranteed to have a unique solution. */
1322  poly fg = ppMult_qq(f, g);   /* for storing the product of f and g */
1323  for (int xExp = 1; xExp <= d; xExp++)
1324  {
1325    matrix bVec = mpNew(n + m, 1);     /* b */
1326    matrix xVec = mpNew(n + m, 1);     /* x */
1327
1328    p = pCopy(fg);
1329    p = pAdd(pCopy(h), pNeg(p));       /* p = h - f*g */
1330    /* we collect all terms in p with x-exponent = xExp and use their
1331       coefficients to build the vector b */
1332    int bIsZeroVector = true;
1333    while (p != NULL)
1334    {
1335      if (pGetExp(p, xIndex) == xExp)
1336      {
1337        number c = nCopy(pGetCoeff(p));
1338        poly matEntry = pOne(); pSetCoeff(matEntry, c);
1339        MATELEM(bVec, pGetExp(p, yIndex) + 1, 1) = matEntry;
1340        if (matEntry != NULL) bIsZeroVector = false;
1341      }
1342      pLmDelete(&p); /* destruct leading term of p and move to next term */
1343    }
1344    /* solve the linear equation system */
1345    if (!bIsZeroVector) /* otherwise x = 0 and f, g do not change */
1346    {
1347      matrix notUsedMat;
1348      luSolveViaLUDecomp(pMat, lMat, uMat, bVec, xVec, notUsedMat);
1349      idDelete((ideal*)&notUsedMat);
1350      /* update f and g by newly computed terms, and update f*g */
1351      poly fNew = NULL; poly gNew = NULL;
1352      for (int row = 1; row <= m; row++)
1353      {
1354        if (MATELEM(xVec, row, 1) != NULL)
1355        {
1356          p = pCopy(MATELEM(xVec, row, 1));   /* p = c                  */
1357          pSetExp(p, xIndex, xExp);           /* p = c * x^xExp         */
1358          pSetExp(p, yIndex, row - 1);        /* p = c * x^xExp * y^i   */
1359          pSetm(p);
1360          gNew = pAdd(gNew, p);
1361        }
1362      }
1363      for (int row = m + 1; row <= m + n; row++)
1364      {
1365        if (MATELEM(xVec, row, 1) != NULL)
1366        {
1367          p = pCopy(MATELEM(xVec, row, 1));   /* p = c                  */
1368          pSetExp(p, xIndex, xExp);           /* p = c * x^xExp         */
1369          pSetExp(p, yIndex, row - m - 1);    /* p = c * x^xExp * y^i   */
1370          pSetm(p);
1371          fNew = pAdd(fNew, p);
1372        }
1373      }
1374      fg = pAdd(fg, ppMult_qq(f, gNew));
1375      fg = pAdd(fg, ppMult_qq(g, fNew));
1376      fg = pAdd(fg, ppMult_qq(fNew, gNew));
1377      f = pAdd(f, fNew);
1378      g = pAdd(g, gNew);
1379    }
1380    /* clean-up loop-dependent vectors */
1381    idDelete((ideal*)&bVec); idDelete((ideal*)&xVec);
1382  }
1383
1384  /* clean-up matrices A, P, L and U, and polynomial fg */
1385  idDelete((ideal*)&aMat); idDelete((ideal*)&pMat);
1386  idDelete((ideal*)&lMat); idDelete((ideal*)&uMat);
1387  pDelete(&fg);
1388}
1389
1390void lduDecomp(const matrix aMat, matrix &pMat, matrix &lMat, matrix &dMat,
1391               matrix &uMat, poly &l, poly &u, poly &lTimesU)
1392{
1393  int rr = aMat->rows();
1394  int cc = aMat->cols();
1395  /* we use an int array to store all row permutations;
1396     note that we only make use of the entries [1..rr] */
1397  int* permut = new int[rr + 1];
1398  for (int i = 1; i <= rr; i++) permut[i] = i;
1399  /* fill lMat and dMat with the (rr x rr) unit matrix */
1400  unitMatrix(rr, lMat);
1401  unitMatrix(rr, dMat);
1402  uMat = mpNew(rr, cc);
1403  /* copy aMat into uMat: */
1404  for (int r = 1; r <= rr; r++)
1405    for (int c = 1; c <= cc; c++)
1406      MATELEM(uMat, r, c) = pCopy(MATELEM(aMat, r, c));
1407  u = pOne(); l = pOne();
1408
1409  int col = 1; int row = 1;
1410  while ((col <= cc) & (row < rr))
1411  {
1412    int pivotR; int pivotC; bool pivotValid = false;
1413    while (col <= cc)
1414    {
1415      pivotValid = pivot(uMat, row, rr, col, col, &pivotR, &pivotC);
1416      if (pivotValid)  break;
1417      col++;
1418    }
1419    if (pivotValid)
1420    {
1421      if (pivotR != row)
1422      {
1423        swapRows(row, pivotR, uMat);
1424        poly p = MATELEM(dMat, row, row);
1425        MATELEM(dMat, row, row) = MATELEM(dMat, pivotR, pivotR);
1426        MATELEM(dMat, pivotR, pivotR) = p;
1427        swapColumns(row, pivotR, lMat);
1428        swapRows(row, pivotR, lMat);
1429        int temp = permut[row];
1430        permut[row] = permut[pivotR]; permut[pivotR] = temp;
1431      }
1432      /* in gg, we compute the gcd of all non-zero elements in
1433         uMat[row..rr, col];
1434         the next number is the pivot and thus guaranteed to be different
1435         from zero: */
1436      number gg = nCopy(pGetCoeff(MATELEM(uMat, row, col))); number t;
1437      for (int r = row + 1; r <= rr; r++)
1438      {
1439        if (MATELEM(uMat, r, col) != NULL)
1440        {
1441          t = gg;
1442          gg = nGcd(t, pGetCoeff(MATELEM(uMat, r, col)), currRing);
1443          nDelete(&t);
1444        }
1445      }
1446      t = nDiv(pGetCoeff(MATELEM(uMat, row, col)), gg);
1447      nNormalize(t);   /* this division works without remainder */
1448      if (!nIsOne(t))
1449      {
1450        for (int r = row; r <= rr; r++)
1451          pMult_nn(MATELEM(dMat, r, r), t);
1452        pMult_nn(MATELEM(lMat, row, row), t);
1453      }
1454      l = pMult(l, pCopy(MATELEM(lMat, row, row)));
1455      u = pMult(u, pCopy(MATELEM(uMat, row, col)));
1456
1457      for (int r = row + 1; r <= rr; r++)
1458      {
1459        if (MATELEM(uMat, r, col) != NULL)
1460        {
1461          number g = nGcd(pGetCoeff(MATELEM(uMat, row, col)),
1462                          pGetCoeff(MATELEM(uMat, r, col)), currRing);
1463          number f1 = nDiv(pGetCoeff(MATELEM(uMat, r, col)), g);
1464          nNormalize(f1);   /* this division works without remainder */
1465          number f2 = nDiv(pGetCoeff(MATELEM(uMat, row, col)), g);
1466          nNormalize(f2);   /* this division works without remainder */
1467          pDelete(&MATELEM(uMat, r, col)); MATELEM(uMat, r, col) = NULL;
1468          for (int c = col + 1; c <= cc; c++)
1469          {
1470            poly p = MATELEM(uMat, r, c);
1471            pMult_nn(p, f2);
1472            poly q = pCopy(MATELEM(uMat, row, c));
1473            pMult_nn(q, f1); q = pNeg(q);
1474            MATELEM(uMat, r, c) = pAdd(p, q);
1475          }
1476          number tt = nDiv(g, gg);
1477          nNormalize(tt);   /* this division works without remainder */
1478          pMult_nn(MATELEM(lMat, r, r), tt); nDelete(&tt);
1479          MATELEM(lMat, r, row) = pCopy(MATELEM(lMat, r, r));
1480          pMult_nn(MATELEM(lMat, r, row), f1);
1481          nDelete(&f1); nDelete(&f2); nDelete(&g);
1482        }
1483        else pMult_nn(MATELEM(lMat, r, r), t);
1484      }
1485      nDelete(&t); nDelete(&gg);
1486      col++; row++;
1487    }
1488  }
1489  /* one factor in the product u might be missing: */
1490  if (row == rr)
1491  {
1492    while ((col <= cc) && (MATELEM(uMat, row, col) == NULL)) col++;
1493    if (col <= cc) u = pMult(u, pCopy(MATELEM(uMat, row, col)));
1494  }
1495
1496  /* building the permutation matrix from 'permut' and computing l */
1497  pMat = mpNew(rr, rr);
1498  for (int r = 1; r <= rr; r++)
1499    MATELEM(pMat, r, permut[r]) = pOne();
1500  delete[] permut;
1501
1502  lTimesU = ppMult_qq(l, u);
1503}
1504
1505bool luSolveViaLDUDecomp(const matrix pMat, const matrix lMat,
1506                         const matrix dMat, const matrix uMat,
1507                         const poly l, const poly u, const poly lTimesU,
1508                         const matrix bVec, matrix &xVec, matrix &H)
1509{
1510  int m = uMat->rows(); int n = uMat->cols();
1511  matrix cVec = mpNew(m, 1);  /* for storing l * pMat * bVec */
1512  matrix yVec = mpNew(m, 1);  /* for storing the unique solution of
1513                                 lMat * yVec = cVec */
1514
1515  /* compute cVec = l * pMat * bVec but without actual matrix mult. */
1516  for (int r = 1; r <= m; r++)
1517  {
1518    for (int c = 1; c <= m; c++)
1519    {
1520      if (MATELEM(pMat, r, c) != NULL)
1521        { MATELEM(cVec, r, 1) = ppMult_qq(l, MATELEM(bVec, c, 1)); break; }
1522    }
1523  }
1524
1525  /* solve lMat * yVec = cVec; this will always work as lMat is invertible;
1526     moreover, all divisions are guaranteed to be without remainder */
1527  poly p; poly q;
1528  for (int r = 1; r <= m; r++)
1529  {
1530    p = pNeg(pCopy(MATELEM(cVec, r, 1)));
1531    for (int c = 1; c < r; c++)
1532      p = pAdd(p, ppMult_qq(MATELEM(lMat, r, c), MATELEM(yVec, c, 1) ));
1533    /* The following division is without remainder. */
1534    q = pNSet(nInvers(pGetCoeff(MATELEM(lMat, r, r))));
1535    MATELEM(yVec, r, 1) = pMult(pNeg(p), q);
1536    pNormalize(MATELEM(yVec, r, 1));
1537  }
1538
1539  /* compute u * dMat * yVec and put result into yVec */
1540  for (int r = 1; r <= m; r++)
1541  {
1542    p = ppMult_qq(u, MATELEM(dMat, r, r));
1543    MATELEM(yVec, r, 1) = pMult(p, MATELEM(yVec, r, 1));
1544  }
1545
1546  /* determine whether uMat * xVec = yVec is solvable */
1547  bool isSolvable = true;
1548  bool isZeroRow; int nonZeroRowIndex;
1549  for (int r = m; r >= 1; r--)
1550  {
1551    isZeroRow = true;
1552    for (int c = 1; c <= n; c++)
1553      if (MATELEM(uMat, r, c) != NULL) { isZeroRow = false; break; }
1554    if (isZeroRow)
1555    {
1556      if (MATELEM(yVec, r, 1) != NULL) { isSolvable = false; break; }
1557    }
1558    else { nonZeroRowIndex = r; break; }
1559  }
1560
1561  if (isSolvable)
1562  {
1563    xVec = mpNew(n, 1);
1564    matrix N = mpNew(n, n); int dim = 0;
1565    /* solve uMat * xVec = yVec and determine a basis of the solution
1566       space of the homogeneous system uMat * xVec = 0;
1567       We do not know in advance what the dimension (dim) of the latter
1568       solution space will be. Thus, we start with the possibly too wide
1569       matrix N and later copy the relevant columns of N into H. */
1570    int nonZeroC; int lastNonZeroC = n + 1;
1571    for (int r = nonZeroRowIndex; r >= 1; r--)
1572    {
1573      for (nonZeroC = 1; nonZeroC <= n; nonZeroC++)
1574        if (MATELEM(uMat, r, nonZeroC) != NULL) break;
1575      for (int w = lastNonZeroC - 1; w >= nonZeroC + 1; w--)
1576      {
1577        /* this loop will only be done when the given linear system has
1578           more than one, i.e., infinitely many solutions */
1579        dim++;
1580        /* now we fill two entries of the dim-th column of N */
1581        MATELEM(N, w, dim) = pNeg(pCopy(MATELEM(uMat, r, nonZeroC)));
1582        MATELEM(N, nonZeroC, dim) = pCopy(MATELEM(uMat, r, w));
1583      }
1584      for (int d = 1; d <= dim; d++)
1585      {
1586        /* here we fill the entry of N at [r, d], for each valid vector
1587           that we already have in N;
1588           again, this will only be done when the given linear system has
1589           more than one, i.e., infinitely many solutions */
1590        p = NULL;
1591        for (int c = nonZeroC + 1; c <= n; c++)
1592          if (MATELEM(N, c, d) != NULL)
1593            p = pAdd(p, ppMult_qq(MATELEM(uMat, r, c), MATELEM(N, c, d)));
1594        /* The following division may be with remainder but only takes place
1595           when dim > 0. */
1596        q = pNSet(nInvers(pGetCoeff(MATELEM(uMat, r, nonZeroC))));
1597        MATELEM(N, nonZeroC, d) = pMult(pNeg(p), q);
1598        pNormalize(MATELEM(N, nonZeroC, d));
1599      }
1600      p = pNeg(pCopy(MATELEM(yVec, r, 1)));
1601      for (int c = nonZeroC + 1; c <= n; c++)
1602        if (MATELEM(xVec, c, 1) != NULL)
1603          p = pAdd(p, ppMult_qq(MATELEM(uMat, r, c), MATELEM(xVec, c, 1)));
1604      /* The following division is without remainder. */
1605      q = pNSet(nInvers(pGetCoeff(MATELEM(uMat, r, nonZeroC))));
1606      MATELEM(xVec, nonZeroC, 1) = pMult(pNeg(p), q);
1607      pNormalize(MATELEM(xVec, nonZeroC, 1));
1608      lastNonZeroC = nonZeroC;
1609    }
1610
1611    /* divide xVec by l*u = lTimesU and put result in xVec */
1612    number z = nInvers(pGetCoeff(lTimesU));
1613    for (int c = 1; c <= n; c++)
1614    {
1615      pMult_nn(MATELEM(xVec, c, 1), z);
1616      pNormalize(MATELEM(xVec, c, 1));
1617    }
1618    nDelete(&z);
1619
1620    if (dim == 0)
1621    {
1622      /* that means the given linear system has exactly one solution;
1623         we return as H the 1x1 matrix with entry zero */
1624      H = mpNew(1, 1);
1625    }
1626    else
1627    {
1628      /* copy the first 'dim' columns of N into H */
1629      H = mpNew(n, dim);
1630      for (int r = 1; r <= n; r++)
1631        for (int c = 1; c <= dim; c++)
1632          MATELEM(H, r, c) = pCopy(MATELEM(N, r, c));
1633    }
1634    /* clean up N */
1635    idDelete((ideal*)&N);
1636  }
1637
1638  idDelete((ideal*)&cVec);
1639  idDelete((ideal*)&yVec);
1640
1641  return isSolvable;
1642}
1643
Note: See TracBrowser for help on using the repository browser.