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

SARAG_LINE_COLOR : 1;
SARAG_POINT_SIZE : 3;
SARAG_POINT_STYLE_GENERIC : 3;
SARAG_POINT_STYLE_CRITICAL : 2;
SARAG_POINT_STYLE_NONCRITICAL : 1;

signAtRoot(pol,x,polyInX,rootInX) :=
  signsAtRoots([rootInX],polyInX,pol,x)[1][2];

bivariateSignChanges(seq,x,polyInX,rootInX) :=
  signChanges(map(lambda([arg],signAtRoot(arg,x,polyInX,rootInX)),seq));



upperBoundWithSignAt(polyInX,interval,x,sgnAtRoot) :=
  block([signFound,bound,lhsBound,rhsBound],
   signFound : false,
   while(not(signFound)) do
     (
     bound : upperBoundAt(polyInX,interval,x),
     lhsBound : bound[1],
     rhsBound : bound[2],
     if sgn(lhsBound)=sgnAtRoot and sgn(rhsBound)=sgnAtRoot then
       signFound : true
     else
       interval : refineRoot(interval,polyInX,x)
     ), /* end while */
   return([interval,[lhsBound,rhsBound]])
   ); /* end proc */



bivariateSSubResSignChanges(seq,x,polyInX,rootInX) :=
  genPermMVar(map(lambda([arg],signAtRoot(arg,x,polyInX,rootInX)),seq));

bivariateSSubResTarskiQuery(q,p,var,x,polyInX,rootInX) :=
  block([degQ, degP, sSRRes, sSR, seq, coeffSeq, j, b1, b0, Rbar],
  
  p : expandIf(p),
  q : expandIf(q),
  degQ : degree(q,var),
  degP : degree(p,var),

  if degQ = 0 then
    (
    coeffSeq : sSubResCoeff(p,diff(p,var),var),
    return(signAtRoot(leadCoeff(q,var),x,polyInX,rootInX)*
           bivariateSSubResSignChanges(coeffSeq,x,polyInX,rootInX)) 
    ) /* end if */
  else
    if degQ = 1 then
      (
      b0 : coeff(q,var,0),
      b1 : coeff(q,var,1),

      Rbar : expand(diff(p,var)*q-degP*b1*p),

      coeffSeq : sSubResCoeff(p,Rbar,var), /* SR(p b1 P - P' Q) */

      return(bivariateSSubResSignChanges(coeffSeq,x,polyInX,rootInX))
      ) /* end if */
    else
      (

      coeffSeq : sSubResCoeff(expand(-diff(p,var)*q,p,var)), /* SR(-P'Q,P) */
      if oddp(degQ-1) then
         return(bivariateSSubResSignChanges(coeffSeq,x,polyInX,rootInX) + signAtRoot(leadCoeff(q,var),x,polyInX,rootInX))
      else
         return(bivariateSSubResSignChanges(coeffSeq,x,polyInX,rootInX))
      ) /* end else */
  ); /* end proc */


multiplicity(sol,pol,var) :=
  block([count],
  count : 0,
  while(expand(factor(subst(sol,var,pol)))=0) do
    (
    pol : diff(pol,var),
    count : count + 1
    ), /* end while */
  return(count)
  ); /* end proc */

bivariateMultiplicity(sol,pol,var,x,polyInX,rootInX) :=
  block([count],
  count : 0,
  while(signAtRoot(expand(factor(subst(sol,var,pol))),x,polyInX,rootInX)=0) do
    (
    pol : diff(pol,var),
    count : count + 1
    ), /* end while */
  return(count)
  ); /* end proc */
  


archimedeanTopology(pol,isolAlg,x,y) :=
  block([sRes,sSR,sSRCoeff,discr,isolDiscr,i,j,jList,epsList,flag,rootSign,degP,
         numOfRoots,rootsAtDiscr,numAbove,rootsAtDiscrAboveCr,taQ,
         numBetween,rootsBetween,res,
         coSys,generic,critY,multi,aboveCr],

  pol : expand(pol), 

  if constantp(pol) then
    return([]),
  

  coSys : 0,
  while(not(degree(leadCoeff(pol,y),x)=0)) do
    (
    coSys : coSys + 1, 
    if WARNINGS then
      (
      print("topology) WARNING: the function is not quasi-monomial in ", y),
      print("topology) WARNING: new curve is : ", expand(subst(x+y,x,pol)))
      ), /* end if */
    pol : expand(subst(x+y,x,pol))
    ), /* end while */
  generic : false,

  

  while (not(generic)) do
    (

    sSR : sSubResPol(pol,diff(pol,y),y),
    sSRCoeff : sSubResCoeff(pol,diff(pol,y),y),
    discr : last(sSRCoeff),
  

    isolDiscr : isListSort(isolAlg(discr,x)),

    jList : [],
    epsList : [],
    rootsAtDiscr : [],
    rootsAtDiscrAboveCr : [],
    aboveCr : [],
    rootsBetween : [],
    degP : degree(expand(pol),y),
    

    generic : true, /* It "hopes" the curve is in generic position but it will check during computation */
    for i : 1 thru length(isolDiscr) do /* should insert check on generic position */
      (
      if generic then 
        (
      
        if length(isolDiscr[i]) = 1 then
          (
          j : 0,
          flag : false,
          while(not(flag)) do
            (
            rootSign : sgn(subst(isolDiscr[i][1],x,sSRCoeff[degP+1-j])),

            if not(rootSign=0) then
              flag : true
            else
              j : j + 1
            ), /* end while */
       
          jList : endcons(j,jList),
          epsList : endcons(rootSign,epsList),

          if not(ASSUME_GENERIC_POSITION) then 
            (
            critY : -1/j * coeff(subst(isolDiscr[i][1],x,sSR[degP+1-j]),y,j-1)/
                           subst(isolDiscr[i][1],x,sSRCoeff[degP+1-j]),
      

            multi : multiplicity(critY,subst(isolDiscr[i][1],x,sSR[degP+1-j]),y),
            if multi<j then
               (
               generic:false,
            
               if WARNINGS then
                 (
                 print("topology) WARNING : Non-generic position --- multiplicity : ", 
                        multi),
                 print("topology) WARNING: new curve is : ", expand(subst(x+y,x,pol)))
                 ), /* end if */
               pol : expand(subst(x+y,x,pol)),
               coSys : coSys + 1,
               while(not(degree(leadCoeff(pol,y),x)=0)) do
                 (
                 coSys : coSys + 1,
                 if WARNINGS then
                   (
                   print("topology) WARNING: the function is not quasi-monomial in ", y),
                   print("topology) WARNING: new curve is : ", expand(subst(x+y,x,pol)))
                   ), /* end if */
                 pol : expand(subst(x+y,x,pol))
                 ) /* end while */
              
               ) /* end if */
            ), /* end if */
          
          if generic then 
            (
            numOfRoots : genPermMVar(subst(isolDiscr[i][1],x,sSRCoeff)),
     
            rootsAtDiscr : endcons(numOfRoots,rootsAtDiscr),
            taQ : sSubResTarskiQuery(
                               expand(subst(isolDiscr[i][1],x,
                                 rootSign*(j*sSRCoeff[degP+1-j]*y+coeff(sSR[degP+1-j],y,j-1)))),
                               expand(subst(isolDiscr[i][1],x,pol)),y),

            numAbove : (numOfRoots+taQ-1)/2,
   
            rootsAtDiscrAboveCr : endcons(numAbove,rootsAtDiscrAboveCr)
            ) /* end if */

          ) /* end if */
        else /* case when the root of the dicriminant is described by an open interval */
          (
        
          j : 0,
          flag : false,
          while(not(flag)and j <= degP+1) do
            (

            rootSign : signAtRoot(sSRCoeff[degP+1-j],
                                         x,discr,isolDiscr[i]), 

            if not(rootSign=0) then
              flag:true
            else
              j : j + 1
            ), /* end while */
        
          jList : endcons(j,jList),
          epsList : endcons(rootSign,epsList),

          if not(ASSUME_GENERIC_POSITION) then
            (
            critY : -1/j * coeff(sSR[degP+1-j],y,j-1)/sSRCoeff[degP+1-j], 

    

            multi : bivariateMultiplicity(critY,sSR[degP+1-j],y,x,discr,isolDiscr[i]),
            
            if multi<j then
               (
               generic:false,
           
               if WARNINGS then
                 (
                 print("topology) WARNING : Non-generic position --- multiplicity : ", 
                        multi),
                 
                 print("topology) WARNING: new curve is : ", expand(subst(x+y,x,pol)))
                 ), /* end if */
               pol : expand(subst(x+y,x,pol)),
               coSys : coSys + 1,
               while(not(degree(leadCoeff(pol,y),x)=0)) do
                 (
                 coSys : coSys + 1,
                 if WARNINGS then
                   (
                   print("topology) WARNING: the function is not quasi-monomial in ", y),
                   print("topology) WARNING: new curve is : ", expand(subst(x+y,x,pol)))
                   ), /* end if */
                 pol : expand(subst(x+y,x,pol))
                 ) /* end while */
               ) /* end if */
            ), /* end if */

          if generic then
            (
            numOfRoots : bivariateSSubResSignChanges(sSRCoeff,x,discr,isolDiscr[i]),
            rootsAtDiscr : endcons(numOfRoots,rootsAtDiscr),

            taQ : bivariateSSubResTarskiQuery(
                                      rootSign*(j*sSRCoeff[degP+1-j]*y+coeff(sSR[degP+1-j],y,j-1)),
                                      pol,y,x,expand(squareFree(discr,x)),isolDiscr[i]),
          
            numAbove : (numOfRoots+taQ-1)/2,
    
            rootsAtDiscrAboveCr : endcons(numAbove,rootsAtDiscrAboveCr)
            ) /* end if */
          ) /* end else */
        ) /* end if */
      ) /* end for */ 
  ), /* end while */

if length(isolDiscr)>0 then
  (

  rootsBetween : [genPermMVar(subst(isolDiscr[1][1]-1,x,sSRCoeff))],

  for i : 1 thru length(isolDiscr)-1 do
    (


    rootsBetween : endcons(genPermMVar(
                              subst(intermidiatePoint(isolDiscr[i],isolDiscr[i+1],discr,x),
                                    x,sSRCoeff)),
                          rootsBetween)

    ), /* end for */

  rootsBetween : endcons(genPermMVar(subst(last(last(isolDiscr))+1,x,sSRCoeff)),rootsBetween),
  i : 1,
  res : [rootsBetween[1] ],
  while i<=length(isolDiscr) do
    (
    res : append(res,[[rootsAtDiscr[i],rootsAtDiscr[i]-rootsAtDiscrAboveCr[i]],rootsBetween[i+1]]),
    i : i + 1
    ), /* end while */
  if DRAW_TOPOLOGY then
     drawTopology(res),
  return([coSys,res])
  ) /* end if */
else
  (
  res : [sSubResTarskiQuery(1,subst(0,x,pol),y)],
  if DRAW_TOPOLOGY then
     drawTopology(res),
  return([coSys,res])
  )
); /* end proc */



/* ----------------------------------------------------------- */
/* Plotting of the topological graph of a planar curve */
/* Very preliminary */


getPointsOnProj(num,projX,height):=makelist([projX,i*height/(num+1)],i,1,num);


drawPoints(ptList) :=
  plot2d([discrete,float(ptList)],
['style,[points, SARAG_POINT_STYLE_GENERIC]],
[gnuplot_preamble, "set grid; set xrange[-25:25]; set yrange[-10:10]; unset key"]);




drawPointsOnProj(num,projX,height) :=
  drawPoints(getPointsOnProj(num,projX,height));



getPointsOnCrit(num,pos,projX,height):=
  block([i,crit,nonCritBelow,nonCritAbove],
  nonCritBelow : [],
  nonCritAbove : [],
  for i : 1 thru num do
    if i=pos then
      crit : [projX,i*height/(num+1)]
    else
      if i<pos then
        nonCritBelow : append(nonCritBelow,[[projX,i*height/(num+1)]])
      else
        nonCritAbove : append(nonCritAbove,[[projX,i*height/(num+1)]]),
  return([crit,nonCritBelow,nonCritAbove])
  ); /* end proc */
      

getTopologyPoints(tpg) :=
  block([i,j,nonCritPts,critPts,ptsOnCritProj,previous,jump,newNonCritPts,lastCritPts,lastNonCritPts,
         correct,newPtsAtInd,ptsAtInf,lineSegsAtInf, lineSegs, newPtsAtInf],
   nonCritPts : [],
   lastCritPts : [0,[],[]],
   lastNonCritPts : [],
   critPts : [],
   ptsOnCritProj : [0,[],[]],
   lineSegs : [],


/* It checks the form of the input */
   i : 1,
   correct : true,
   while correct and i<= length(tpg) do
     (
     
     if evenp(i) then       
       (
       if not(listp(tpg[i])) then
          (
          correct : false
          ) /* end if */
       else
         if not(length(tpg[i])=2) or
            not(numberp(first(tpg[i]))) or
            not(numberp(second(tpg[i]))) then
           (
           
           correct : false
           ) /* end if */
       ) /* end if */
     else
       (
       if not(numberp(tpg[i])) then         
         correct : false
         
       ), /* end else */
     i : i + 1
     ), /* end of check of the input format */

   if not(correct) then
     (
     return(false)
     ) /* end if */
   else
   (
   ptsAtInf : [],
   lineSegsAtInf : [],
   if PLOT_AT_INFINITY then
    (
    newPtsAtInf : getPointsOnProj(tpg[1],0,PLOT_HEIGHT),
    ptsAtInf : append(ptsAtInf,newPtsAtInf),
    newNonCritPts : getPointsOnProj(tpg[1],1*PLOT_SPACING,PLOT_HEIGHT),
    for j : 1 thru tpg[1] do
      lineSegsAtInf : append(lineSegsAtInf,[[discrete,
                                   float([newPtsAtInf[j],
                                          newNonCritPts[j]    ])]])
      
    
    ), /* end if */
   for i : 1 thru length(tpg) do
    (
    if oddp(i) then /* non critical points */
      (

      newNonCritPts : getPointsOnProj(tpg[i],i*PLOT_SPACING,PLOT_HEIGHT),
      nonCritPts : append(nonCritPts,newNonCritPts),

      if not(ptsOnCritProj = [0,[],[]]) then
        (

        jump : length(newNonCritPts)-length(ptsOnCritProj[2])-length(ptsOnCritProj[3]),
        
      
        for j : 1 thru length(ptsOnCritProj[2]) do
          lineSegs : append(lineSegs,[[discrete,
                                       float([ptsOnCritProj[2][j],
                                              newNonCritPts[j]])]]),

        for j : 1 thru length(ptsOnCritProj[3]) do
          lineSegs : append(lineSegs,[[discrete,
                                       float([ptsOnCritProj[3][j],
                                              newNonCritPts[j+jump+length(ptsOnCritProj[2])]])]]),

        for j : 1 thru jump do
          lineSegs : append(lineSegs,[[discrete,
                                       float([ptsOnCritProj[1],newNonCritPts[j+length(ptsOnCritProj[2])]])]])

        ) /* end if */


      ) /* end if */
    else /* critical points */
      (
     

      ptsOnCritProj : getPointsOnCrit(tpg[i][1],tpg[i][2],i*PLOT_SPACING,PLOT_HEIGHT),
      jump : length(newNonCritPts)-(tpg[i][1]-1),


      
      for j : 1 thru length(ptsOnCritProj[3]) do
          (        
          lineSegs : append(lineSegs,[[discrete,
                                       float([newNonCritPts[j+jump+length(ptsOnCritProj[2])],
                                              ptsOnCritProj[3][j]])]])
        
          ), /* end for */
      
      for j : 1 thru length(ptsOnCritProj[2]) do
          lineSegs : append(lineSegs, [[discrete,
                                       float([newNonCritPts[j],ptsOnCritProj[2][j]])]]),

      for j : 1 thru jump do
          lineSegs : append(lineSegs,[[discrete,
                                      float([newNonCritPts[j+length(ptsOnCritProj[2])],
                                             ptsOnCritProj[1]])]]),
            

      critPts : append(critPts,[ptsOnCritProj[1]]),
      nonCritPts : append(nonCritPts,ptsOnCritProj[2],ptsOnCritProj[3])
      ) /* end else */
    ), /* end for */
    if PLOT_AT_INFINITY then
    (
    newPtsAtInf : getPointsOnProj(tpg[length(tpg)],(length(tpg)+1)*PLOT_SPACING,PLOT_HEIGHT),
    ptsAtInf : append(ptsAtInf,newPtsAtInf),

    newNonCritPts : getPointsOnProj(tpg[length(tpg)],length(tpg)*PLOT_SPACING,PLOT_HEIGHT),
    for j : 1 thru tpg[length(tpg)] do
      lineSegsAtInf : append(lineSegsAtInf,[[discrete,
                                             float([newPtsAtInf[j],
                                             newNonCritPts[j]    ])]])
      
    )/* end if */
  
  ), /* end while */

   return([nonCritPts,critPts,lineSegs,ptsAtInf,lineSegsAtInf])
   ); /* end proc */

getCritPoint(critLine,projX,height) :=
  [projX,critLine[2]*height/critLine[1]];

drawTopology(tpg) :=
  block([nonCritPoints,critPoints,firstAttemptToGetPoints,secondAttemptToGetPoints, topologyPoints,style,preamble,i,
         leftMost,rightMost,top,bottom,ptsAtInf,fixedTpg, lineSegs],

    firstAttemptToGetPoints: getTopologyPoints(tpg),
    if not firstAttemptToGetPoints=false then
       (
       topologyPoints : firstAttemptToGetPoints,
       fixedTpg : tpg
       )
    else
       (
       secondAttemptToGetPoints: getTopologyPoints(second(tpg)),
       if not secondAttemptToGetPoints=false then
          (         
          topologyPoints : secondAttemptToGetPoints,
          fixedTpg : second(tpg)
          )
       ), /* end else */
    if topologyPoints=false then
      (
      print("Wrong input format!"),
      return(false)
      ) /* end if */
    else
     (
     nonCritPoints : topologyPoints[1],
     critPoints : topologyPoints[2],
     lineSegs : topologyPoints[3],

     lineSegs : append(lineSegs,topologyPoints[5]),

     ptsAtInf : topologyPoints[4],

     leftMost : -2,
     rightMost : PLOT_SPACING*length(fixedTpg)+3,
     bottom : -1,
     top : PLOT_HEIGHT+1,
     preamble : concat(PLOT_STYLE, "set xrange[-1:",rightMost,
                       "]; set yrange[-1:",PLOT_HEIGHT,"];"), 

     style : [],
     for i : 1 thru length(lineSegs) do
        style : cons([lines, 1, SARAG_LINE_COLOR],style),

     if not(PS_OUTPUT) then 
       if critPoints=[] then
         plot2d(append([[discrete,float(nonCritPoints)]],
                       lineSegs),
                  cons('style,cons([points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_NONCRITICAL],style)),
                  [gnuplot_preamble, preamble])
       else
         if nonCritPoints = [] then
            plot2d(append([[discrete,float(critPoints)]],
                          lineSegs),
                   cons('style,cons([points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_CRITICAL],style)),
                   [gnuplot_preamble,preamble])
         else
         plot2d(append([[discrete,float(nonCritPoints)],
                        [discrete,float(critPoints)]],
                       lineSegs),
                  cons('style,append([[points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_NONCRITICAL], 
                                      [points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_CRITICAL]],style)),
                  [gnuplot_preamble,preamble])
     else
       if critPoints=[] then
         plot2d(append([[discrete,float(nonCritPoints)]],
                       lineSegs),
                  cons('style,cons([points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_NONCRITICAL],style)),  
                  [gnuplot_preamble, preamble],
                  [gnuplot_term, ps], [gnuplot_out_file, PS_OUTPUT_FILE_NAME])
       else
         if nonCritPoints = [] then
            plot2d(append([[discrete,float(critPoints)]],
                          lineSegs),
                   cons('style,cons([points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_CRITICAL],style)),
                   [gnuplot_preamble,preamble],
                   [gnuplot_term, ps], [gnuplot_out_file, PS_OUTPUT_FILE_NAME])
         else
         plot2d(append([[discrete,float(nonCritPoints)],
                        [discrete,float(critPoints)]],
                       lineSegs),
                  cons('style,append([[points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_NONCRITICAL], 
                                      [points, SARAG_POINT_SIZE, SARAG_POINT_STYLE_CRITICAL]],style)),
                  [gnuplot_preamble,preamble],
                  [gnuplot_term, ps], [gnuplot_out_file, PS_OUTPUT_FILE_NAME])
     ), /* end else */

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

