/* ------------------------------------------------------------------ */
/* SARAG - Linear Algebra                                             */
/* by Fabrizio Caruso   modified by Alexandre Le Meur and Marie-Françoise Roy                           */


/* It counts the sign change of a determinant after */
/* i consecutive row changes */
revRowsCount(i) := (-1)^(i*(i-1)/2);

exchange(m,i,j) :=
  block([aux,size],
 
  size : length(m),
 
  aux : m[i],
  m[i] : m[j],
  m[j] : aux,
 
  return(m)
  ); /* end proc */

exchangeCol(m,i,j) :=
   block([aux,size,k],
   size : first(third(arrayinfo(m)))+1,
   for k : 0 thru size-1 do
      (
      aux : m[k,i],
      m[k,i] : m[k,j],
      m[k,j] : aux
      ), /* end for */
   return(m)
   ); /* end proc */



/* Fix columns exchanges */
fixColumns(m,colEx) :=
  block([i],
   colEx : reverse(colEx),
   for i : 1 thru colEx do
     exchangeCols(m,colEx[i][1],colEx[i][2]),
   return(m)
   );  /* end proc */


removeElements(lst,blackList) :=
  removeElementsAux(lst,blackList,[],1);

removeElementsAux(lst,blackList,res,indx) :=
   if blackList=[] then
     append(res,lst)
   else
     if first(blackList)=indx then
       removeElementsAux(rest(lst,1),rest(blackList,1),res,indx+1)
     else
       if indx<first(blackList) then
          removeElementsAux(rest(lst,1),blackList,
                            endcons(first(lst),res),indx+1)
       else
          removeElementsAux(rest(lst,1),rest(blackList),
                            endcons(first(lst),res),indx+1);



gaussTriangularize(m) :=
  lambda([lst],
         [removeElements(array2list(first(lst)),
                         third(lst)),
          second(lst)])(gaussElimArray(m));

gaussElim(m) := 
  lambda([lst],
         [array2list(first(lst)),second(lst),third(lst)])(gaussElimArray(m));

/* It performs Gaussian elimiation on a matrix */
/* by columns exchange */
gaussElimArray(m) :=
  block([
         nRows : length(m),
         nCols : length(m[1]),
         g : make_array('any),
         k,i,j,r,flag,colExList,
         zeroRows,offset],

  offset : 0, /* it compensates for zero rows */

  zeroRows : [],

  g : make_array('any,nRows,nCols),     

  colExList : [],  

  /* Initialization */
  for i : 0 thru nRows-1 do
     for j : 0 thru nCols-1 do
        g[i,j] : m[i+1][j+1],


 
  /* Main loop */    
  k : 0, /* index of the row of the pivot */
  r : 0, /* index of the column of the pivot */

  while r<= nCols-1 and k <= nRows-1 do
    (

    /* Test for zero row */    
    flag : true,
    j : r+1,
    while flag and j <= nCols do
      if not(g[k+1-1,j-1]=0) then
         flag : false
      else  
         j : j+1,
    if flag then 
      (
      zeroRows : endcons(k,zeroRows),
      offset : offset + 1
      ), /* end if */
   
    if not(j=r+1) and not(flag) then
      (
      colExList : endcons([r+1-1,j-1],colExList),
      exchangeCol(g,r+1-1,j-1)
      ),  /* end if */  
    if not(flag) then
      (
      for i : k+2 thru nRows do
        (
        for j : r+2 thru nCols do
          (
          g[i-1,j-1] : 
                g[i-1,j-1] - g[i-1,r+1-1]*
                             g[k+1-1,j-1]/g[k+1-1,r+1-1]
          ), /* end for */
     
        g[i-1,r+1-1] : 0

        ), /* end for */
      r : r + 1
      ), /* end if */
    k : k +1
    ), /* end main while loop */

/* add zero rows below the upper square part to zeroRows*/

  if k<=nRows-1 then
     zeroRows : append(zeroRows, makelist(i,i,k,nRows-1)),

  return([g,colExList,zeroRows])
  ); /* end proc */


gaussElimMod(m,gmod) := 
  gaussElimWithDivisionMod(m,gmod);

/*
  lambda([lst],
         [array2list(first(lst)),second(lst),third(lst)])(gaussElimModArray(m,gmod));
*/

gaussElimWithDivisionMod(m,gmod) :=
  lambda([lst],
         [array2list(first(lst)),second(lst),third(lst)])(gaussElimWithDivisionModArray(m,gmod));

/* It performs Gaussian elimiation on a matrix */
/* by columns exchange */
gaussElimWithDivisionModArray(m,gmod) :=
  block([
         nRows : length(m),
         nCols : length(m[1]),
         g : make_array('any),
         k,i,j,r,flag,colExList,
         zeroRows,offset,modInv],

  offset : 0, /* it compensates for zero rows */

  modulus : gmod, /* it sets the modular computation */

  zeroRows : [],

  g : make_array('any,nRows,nCols),     

  colExList : [],  

  /* Initialization */
  for i : 0 thru nRows-1 do
     for j : 0 thru nCols-1 do
        g[i,j] : m[i+1][j+1],

 
  /* Main loop */    
  k : 0, /* index of the row of the pivot */
  r : 0, /* index of the column of the pivot */

  while r<= nCols-1 and k <= nRows-1 do
    (

    /* Test for zero row */    
    flag : true,
    j : r+1,
    while flag and j <= nCols do
      if not(g[k+1-1,j-1]=0) then
         flag : false
      else  
         j : j+1,
    if flag then 
      (
      zeroRows : endcons(k,zeroRows),
      offset : offset + 1
      ), /* end if */
   
    if not(j=r+1) and not(flag) then
      (
      colExList : endcons([r+1-1,j-1],colExList),
      exchangeCol(g,r+1-1,j-1)
      ),    /* end if */
    if not(flag) then
      (
      for i : k+2 thru nRows do
        (
        /* it computes the inverse for the column */
        modInv : rat(1/g[k+1-1,r+1-1]),

        for j : r+2 thru nCols do          
          (
                    
          g[i-1,j-1] : 
                ratexpand(g[i-1,j-1] - g[i-1,r+1-1]*g[k+1-1,j-1]*modInv)

          ), /* end for */
     
        g[i-1,r+1-1] : 0

        ), /* end for */
      r : r + 1
      ), /* end if */
    k : k +1
    ), /* end main while loop */

/* add zero rows below the upper square part to zeroRows*/

  if k<=nRows-1 then
     zeroRows : append(zeroRows, makelist(i,i,k,nRows-1)),

  modulus : false, /* it resets the computation over the rationals */
  return([g,colExList,zeroRows])
  ); /* end proc */


gaussElimWithoutDivisionMod(m,gmod) :=
  lambda([lst],
         [array2list(first(lst)),
          second(lst),third(lst)])(gaussElimWithoutDivisionModArray(m,gmod));

gaussElimWithoutDivisionModArray(m,gmod) :=
  block([
         nRows : length(m),
         nCols : length(m[1]),
         g : make_array('any),
         k,i,j,r,flag,colExList,
         zeroRows,offset],

  offset : 0, /* it compensates for zero rows */

  modulus : gmod, /* it sets the modular computation */

  zeroRows : [],

  g : make_array('any,nRows,nCols),     

  colExList : [],  

  /* Initialization */
  for i : 0 thru nRows-1 do
     for j : 0 thru nCols-1 do
        g[i,j] : m[i+1][j+1],

 
  /* Main loop */    
  k : 0, /* index of the row of the pivot */
  r : 0, /* index of the column of the pivot */

  while r<= nCols-1 and k <= nRows-1 do
    (

    /* Test for zero row */    
    flag : true,
    j : r+1,
    while flag and j <= nCols do
      if not(g[k+1-1,j-1]=0) then
         flag : false
      else  
         j : j+1,
    if flag then 
      (
      zeroRows : endcons(k,zeroRows),
      offset : offset + 1
      ), /* end if */
   
    if not(j=r+1) and not(flag) then
      (
      colExList : endcons([r+1-1,j-1],colExList),
      exchangeCol(g,r+1-1,j-1)
      ),    /* end if */
    if not(flag) then
      (
      for i : k+2 thru nRows do
        (
        /* it computes the inverse for the column */
/*
        modInv : rat(1/g[k+1-1,r+1-1]),
*/
        for j : r+2 thru nCols do          
          (
                    
          g[i-1,j-1] : 
                ratexpand(g[k+1-1,r+1-1]*g[i-1,j-1] - g[i-1,r+1-1]*g[k+1-1,j-1])

          ), /* end for */
     
        g[i-1,r+1-1] : 0

        ), /* end for */
      r : r + 1
      ), /* end if */
    k : k +1
    ), /* end main while loop */

/* add zero rows below the upper square part to zeroRows*/

  if k<=nRows-1 then
     zeroRows : append(zeroRows, makelist(i,i,k,nRows-1)),

  modulus : false, /* it resets the computation over the rationals */
  return([g,colExList,zeroRows])
  ); /* end proc */

echelonMod(m,gmod) := 
  echelonWithDivisionMod(m,gmod);


echelonWithDivisionMod(m,gmod) :=
  lambda([lst],
         [array2list(first(lst)),second(lst),third(lst)])(echelonWithDivisionModArray(m,gmod));

/* It performs Gaussian elimiation on a matrix */
/* by columns exchange */
echelonWithDivisionModArray(m,gmod) :=
  block([
         nRows : length(m),
         nCols : length(m[1]),
         g : make_array('any),
         k,i,j,r,flag,colExList,
         zeroRows,offset,modInv],

  offset : 0, /* it compensates for zero rows */

  modulus : gmod, /* it sets the modular computation */

  zeroRows : [],

  g : make_array('any,nRows,nCols),     

  colExList : [],  
  /* Initialization */
  for i : 0 thru nRows-1 do
     for j : 0 thru nCols-1 do
        g[i,j] : m[i+1][j+1],

 
  /* Main loop */    
  k : 0, /* index of the row of the pivot */
  r : 0, /* index of the column of the pivot */

  while r<= nCols-1 and k <= nRows-1 do
    (

    /* Test for zero row */    
    flag : true,
    j : r+1,
    while flag and j <= nCols do
      (
      if not(g[k+1-1,j-1]=0) then
         flag : false
      else  
         j : j+1
      ), /* end while */

    if flag then 
      (
      zeroRows : endcons(k,zeroRows),
      offset : offset + 1
      ), /* end if */
   
    if not(j=r+1) and not(flag) then
      (
      colExList : endcons([r+1-1,j-1],colExList),
      exchangeCol(g,r+1-1,j-1)
      ),  /* end if */  
    if not(flag) then
      (

      for i : 1 thru k do
        (
        /* it computes the inverse for the column */
        modInv : rat(1/g[k+1-1,r+1-1]),

           
        for j : r+2 thru nCols do          
          (
                    
          g[i-1,j-1] : 
                ratexpand(g[i-1,j-1] - g[i-1,r+1-1]*g[k+1-1,j-1]*modInv)

          ), /* end for */
     
        g[i-1,r+1-1] : 0

        ), /* end for */


      for i : k+2 thru nRows do
        (
        /* it computes the inverse for the column */
        modInv : rat(1/g[k+1-1,r+1-1]),

           
        for j : r+2 thru nCols do          
          (
                    
          g[i-1,j-1] : 
                ratexpand(g[i-1,j-1] - g[i-1,r+1-1]*g[k+1-1,j-1]*modInv)

          ), /* end for */
     
        g[i-1,r+1-1] : 0

        ), /* end for */
      r : r + 1
      ), /* end if */
    k : k +1
    ), /* end main while loop */

/* add zero rows below the upper square part to zeroRows*/

  if k<=nRows-1 then
     zeroRows : append(zeroRows, makelist(i,i,k,nRows-1)),

  modulus : false, /* it resets the computation over the rationals */
  return([g,colExList,zeroRows])
  ); /* end proc */


/* It computes the determinant by Gauss elimination */
/* Algorithm 8.26                                   */
gaussDet(m) :=
  block([
         g : make_array('any),
         k,i,j,flag,colEx,size],
 
  size : length(m), 
  g : list2array(m),      
  colEx : 0,  

  /* Initialization */
  for i : 0 thru size-1 do
     for j : 0 thru size-1 do
        g[i,j] : m[i+1][j+1],
 
  /* Main loop */    
  for k : 0 thru size-2 do
    (  
    /* Test for zero row */    
    flag : true,
    j : k+1,
    while flag and j <= size do
      if not(g[k+1-1,j-1]=0) then
         flag : false
      else  
         j : j+1,
    if flag then 
      return(0),
    
    /* column exchange check */
    if not(j=k+1) then
      (
      /* column exchange required */
      colEx : colEx+1,
      exchangeCol(g,k+1-1,j-1)
      ), /* end if */
    /* elimination */
    for i : k+2 thru size do
      (
      for j : k+2 thru size do
        g[i-1,j-1] : g[i-1,j-1] - g[i-1,k+1-1]*g[k+1-1,j-1]/g[k+1-1,k+1-1],
      g[i-1,k+1-1] : 0
      ) /* end for */
    ), /* end for */
  return(expand((-1)^colEx * product(g[i,i],i,0,size-1)))
  ); /* end proc */



/* It computes the determinant by Dogdson-Jordan-Bareiss method */
/* Algorithm 8.30                                               */
bareissDet(m) :=
  block([
         g : make_array('any),
         k,i,j,flag,colEx,oldPivot, size], 
  size : length(m),
  g : list2array(m),     
  colEx : 0,  
  /* Initialization */
  for i : 0 thru size-1 do
     for j : 0 thru size-1 do
        g[i,j] : m[i+1][j+1],
  oldPivot : 1,
  /* Main loop */    
  for k : 0 thru size-2 do
    (
    /* Test for zero row */    
    flag : true,
    j : k+1,
    while flag and j <= size do
      if not(g[k+1-1,j-1]=0) then
         flag : false
      else  
         j : j+1,
    if flag then 
      return(0),
    /* column exchange check */
    if not(j=k+1) then
      (
      /* column exchange required */
      colEx : colEx+1,
      exchangeCol(g,k+1-1,j-1)
      ), /* end if */
    /* elimination */
    for i : k+2 thru size do /* column loop */
      (
      for j : k+2 thru size do /* row loop */
        (
        if k= 0 then 
          oldPivot : 1
        else
          oldPivot : g[k-1,k-1],
        g[i-1,j-1] : (g[k+1-1,k+1-1]*g[i-1,j-1]-g[i-1,k+1-1]*g[k+1-1,j-1])/oldPivot
        ), /* end for */
     
      g[i-1,k+1-1] : 0      
      ) /* end for */
    ), /* end if */
  return(expand((-1)^colEx * g[size-1,size-1]))
  ); /* end proc */


princSubMat(m,ord) := 
  block([res:make_array('any,ord,ord),i,j],
    
  for i : 0 thru ord-1 do
    for j : 0 thru ord-1 do
      res[i,j] : m[i,j],
  return(res)
  ); /* end proc */

extractCol(m,j,size) :=
  block([res:make_array('any,size),k],
  
  for k : 0 thru size-1 do
    res[k] : m[k,j],

  return(res)
  ); /* end proc */

extractRow(m,i,size) :=
  block([res:make_array('any,size),k],
 
  for k : 0 thru size-1 do
    res[k] : m[i,k],

  return(res)
  ); /* end proc */


/* Linear algebra support routines */
solveSys(mat,vec,solver) :=
  block([sol,unk,i,j,sys,nRows,nCols,newEq],
  sys : [],
  nRows : length(mat),
  nCols : length(mat[1]),

  for i : 1 thru nRows do
    (
    newEq : sum(mat[i][j]*unk[j],j,1,nCols)-vec[i]=0,
    sys : endcons(newEq,sys)
    ), /* end for */
  sol : solver(sys,makelist(unk[i],i,1,nCols)),

  if sol = [] then
    return([])
  else
    return(map(second,sol))
  ); /* end proc */



newtonFromPoly(pol,var,len) :=
  array2singleList(newtonArrFromPoly(pol,var,len));

newtonArrFromPoly(pol,var,len) :=
  block([newtonRes,degPol,i,j],
    degPol : degree(pol,var),
    newtonRes : make_array('any,len+1),

    newtonRes[0] : degPol,

    for i : 1 thru len do
      (

      newtonRes[i] : (degPol-i)*ratcoeff(pol,var,degPol-i)-
                     sum(ratcoeff(pol,var,degPol-j)*
                     newtonRes[i-j],j,1,
                     min(i,degPol))
      ), /* end for */
    return(newtonRes)
    ); /* end proc */


polyFromNewton(ns,var) :=
  list2poly(getCoeffFromNewton(ns),var);

getCoeffFromNewton(ns) :=
  array2singleList(getCoeffFromNewtonArray(singleList2array(ns)));

getCoeffFromNewtonArray(ns) :=
  block([i,j,degRes : arrayLength(ns)-1,resCoeff:make_array('any)],

   resCoeff : make_array('any,degRes+1),

   resCoeff[degRes]:1,

   for i : 1 thru degRes do
     resCoeff[degRes-i] : -1/i*sum(ns[j+1-1]*resCoeff[degRes+j-i],j,1,i),


   return(resCoeff)
   ); /* end proc */


getCoeffFromNewtonList(ns) :=
  array2singleList(getCoeffFromNewton(ns));

matrixProd(a,b) :=
  array2list(matrixProdArray(list2array(a),list2array(b)));
     
matrixProdArray(a,b) :=
  block([i,j,k,n,m,l,res:mame_array('any)],

  n : first(third(arrayinfo(a)))+1,

  m : second(third(arrayinfo(a)))+1,

 if not(first(third(arrayinfo(b)))+1=m) then
    (
    print("matrixProd) incompatible matrices"),
    print("matrixProd) a : ", a),
    print("matrixProd) b : ", b),
    return(false)
    ) /* end if */
  else
    (
  l : second(third(arrayinfo(b)))+1,

  res : make_array('any,n,l), 

  for i : 1 thru n do
    for k : 1 thru l do
    
       res[i-1,k-1] : sum(a[i-1,j-1]*b[j-1,k-1],j,1,m), 


  return(res)
    ) /* end else */
  ); /* end proc */

matrixTrace(A) :=
  block([ALen,i,res],
    ALen : numOfCols(A),

    res : 0,
    for i : 1 thru ALen do
      res : res + A[i-1,i-1],
    return(res)
    ); /* end proc */

discreteSquareRoot(n) :=
 block([i,res],
 res : 1,
 /* after 5.9.2 */
 /*
 for i : 1 thru ceiling(bfloat(n/2)) do
   if i*i >= n then
     return(i)
 */
 /* before 5.9.2 but also forwards-compatible*/
 for i : 1 thru comp_ceiling(bfloat(n/2)) do
   if i*i >= n then
     return(i)
 ); /* end proc */


babyGiantCharPol(A,var) :=
  babyGiantCharPolAux(list2array(A),var);

babyGiantCharPolAux(A,var) :=
  list2poly(array2singleList(getCoeffFromNewtonArray(
         getNewtonFromMatrix(A))),
        var);  


matrixMinus(A,B) :=
  makelist(
    makelist(A[i][j]-B[i][j],j,1,length(A[1])),
    i,1,length(A));

diagonal(elem,len) :=
  makelist(
    makelist(if(i=j) then elem else 0,j,1,len),
    i,1,len);

gaussCharPol(A,var) :=
  expandIf(gaussDet(matrixMinus(A,diagonal(var,length(A)))));

bareissCharPol(A,var) :=
  expandIf(bareissDet(matrixMinus(A,diagonal(var,length(A)))));

/* Input : a bidimensional array */
/* Output : the Newton sums of the corresponding characteristic polynomial */
getNewtonFromMatrix(A) :=
   block([i,j,k,r,n,dsr,
          B:make_array('any),G:make_array('any),ss:make_array('any)],

   n : numOfRows(A),
   ss : make_array('any,n +1 /* +1 */),
   
   dsr : discreteSquareRoot(n),
   if dsr*dsr = n then 
     r : dsr+1
   else
     r : dsr,
   B : make_array('any,r-1),
   for i : 1 thru r-1 do
     B[i-1] : make_array('any,n,r),
   /* baby step */
   B[1-1] : A,
   ss[0] : n,
   ss[1] : matrixTrace(A),
   /* baby loop */
   for i : 1 thru r-2 do
     (
     B[i+1 -1] : matrixProdArray(A,B[i -1]),
     ss[i+1] : matrixTrace(B[i+1 -1])

     ),  /* end for */
   G : make_array('any,r-1),
   for j : 1 thru r-1 do
     G[j-1] : make_array('any,n,r),
   /* giant step */
   G[1 -1] : matrixProdArray(A,B[r-1 -1]),
   ss[r] : matrixTrace(G[1 -1]),

   for j : 1 thru r-2 do
     (
     if (j+1)*r <= n then
       (
       G[j+1 -1] : matrixProdArray(G[1-1],G[j -1]),
       ss[(j+1)*r] : matrixTrace(G[j+1 -1])
       ) /* end if */
     ),   /* end for */
   /* Newton's sums */
   for i : 1 thru r-1 do
      for j : 1 thru r-1 do
         (
         if j*r+i <= n then 
           ss[j*r+i] : matrixTrace(matrixProdArray(B[i -1],G[j -1]))
         ), /* end for */

return(ss)
); /* end proc */

companion(pol,var) :=
  array2list(companion(pol,var));

companionArray(pol,var) :=
  block(
    [m : make_array('any),n, i,j],

    n : degree(pol,var),
    m: make_array('any,n,n),

    for j : 0 thru n - 2 do
      m[0,j] : 0,
    m[0,n-1] : -coeff(pol,var,0),

 
    for i : 1 thru n-1 do
      (
      for j : 0 thru i-2 do
        m[i,j] : 0,
      m[i,i-1] : 1,
      for j : i thru n-2 do
        m[i,j] : 0,
      m[i,n-1] : -coeff(pol,var,i)
      ), /* end for */
    return(m)
    ); /* end proc */


/* This should be changed with the algorithm shown in Proposition 4.7 */
companionPoly2Newton(pol,var) :=
  array2singleList(getNewtonFromMatrix(companionArray(pol,var)));

newton2Poly(newtonLst) :=
  array2singleList(newtonArr2Poly(singleList2array(newtonLst)));

newtonArr2Poly(newtonArr) :=
   block([res,i,j,degP],
   degP : arrayLength(newtonArr)-1,
   
   res : make_array('any,degP+1),
   res[degP] : 1, 
   for i : 1 thru degP do
     (
     
     for j : 1 thru i do
       res[degP-i] : sum(res[degP-i+j]*newtonArr[j],j,1,i)*(-1/i)
       
     ), /* end for */
   return(res)
   ); /* end proc */

/* Descartes Signature */
descartesSignature(mtx) :=
  block([charP,x,revCoeffList,charPDeg,i],
    charP : babyGiantCharPol(mtx,x), /* DEBUGGING */
    charPDeg : length(mtx),
    revCoeffList :  reverse(poly2list(charP,x)),

    return(signChanges(revCoeffList)-
           signChanges(
             makelist((-1)^(charPDeg-i)*revCoeffList[i+1],i,0,
                                                        charPDeg)))

    ); /* end proc */
    
