source: git/Singular/ring.cc @ 4b2155

spielwiese
Last change on this file since 4b2155 was 4b2155, checked in by Olaf Bachmann <obachman@…>, 24 years ago
*string() implemented for all types -- no line breaks *inmtat(intvec, n, m) implemented git-svn-id: file:///usr/local/Singular/svn/trunk@2986 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 45.7 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ring.cc,v 1.50 1999-04-16 07:53:41 obachman Exp $ */
5
6/*
7* ABSTRACT - the interpreter related ring operations
8*/
9
10/* includes */
11#include <math.h>
12#include "mod2.h"
13#include "mmemory.h"
14#include "tok.h"
15#include "polys.h"
16#include "numbers.h"
17#include "febase.h"
18#include "ipid.h"
19#include "ipshell.h"
20#include "ipconv.h"
21#include "intvec.h"
22#include "longalg.h"
23#include "ffields.h"
24#include "spolys.h"
25#include "subexpr.h"
26#include "ideals.h"
27#include "lists.h"
28#include "ring.h"
29
30/* global variables */
31#ifdef RDEBUG
32short rNumber=0;
33#endif
34
35// static procedures
36// unconditionally deletes fields in r
37static void rDelete(ring r);
38
39/*0 implementation*/
40int rBlocks(ring r)
41{
42  int i=0;
43  while (r->order[i]!=0) i++;
44  return i+1;
45}
46
47// internally changes the gloabl ring and resets the relevant
48// global variables:
49// complete == FALSE : only delete operations are enabled
50// complete == TRUE  : full reset of all variables
51#ifdef DRING
52void rChangeCurrRing(ring r, BOOLEAN complete, idhdl h)
53#else
54void rChangeCurrRing(ring r, BOOLEAN complete)
55#endif
56{
57  /*------------ set global ring vars --------------------------------*/
58  currRing = r;
59  currQuotient=NULL;
60
61  if (r != NULL)
62  {
63    rTest(r);
64    if (complete)
65    {
66      /*------------ set global ring vars --------------------------------*/
67      currQuotient=r->qideal;
68      /*------------ set redTail, except reset by nSetChar or pChangeRing */
69      test |= Sy_bit(OPT_REDTAIL);
70    }
71
72    /*------------ global variables related to coefficients ------------*/
73    nSetChar(r->ch, complete, r->parameter, rPar(r));
74
75    /*------------ global variables related to polys -------------------*/
76    pSetGlobals(r, complete);
77
78
79    if (complete)
80    {
81    /*------------ set naMinimalPoly -----------------------------------*/
82      if (r->minpoly!=NULL)
83      {
84        naMinimalPoly=((lnumber)r->minpoly)->z;
85      }
86
87#ifdef DRING
88      pDRING=FALSE;
89      pSDRING=FALSE;
90      if ((h!=NULL) && (hasFlag(h,FLAG_DRING))) rDSet();
91#endif // DRING
92
93#ifdef SRING
94      if ((currRing->partN<=currRing->N)
95#ifdef DRING
96          && ((h==NULL) || (!hasFlag(h,FLAG_DRING)))
97#endif
98          )
99      {
100        pAltVars=currRing->partN;
101        pSRING=TRUE;
102        pSDRING=TRUE;
103      }
104      else
105      {
106        pAltVars=currRing->N+1;
107      }
108#endif // SRING
109
110    /*------------ set spolys ------------------------------------------*/
111      spSet(r);
112    }
113  }
114}
115
116void rSetHdl(idhdl h, BOOLEAN complete)
117{
118  int i;
119  ring rg = NULL;
120  if (h!=NULL)
121  {
122    rg = IDRING(h);
123    mmTestP((ADDRESS)h,sizeof(idrec));
124    mmTestLP((ADDRESS)IDID(h));
125    mmTestP(rg,sizeof(ip_sring));
126#ifdef MDEBUG
127    i=rBlocks(rg);
128#endif
129    mmTestP(rg->order,i*sizeof(int));
130    mmTestP(rg->block0,i*sizeof(int));
131    mmTestP(rg->block1,i*sizeof(int));
132    mmTestP(rg->wvhdl,i*sizeof(short *));
133  }
134  else complete=FALSE;
135
136  // clean up history
137    if (((sLastPrinted.rtyp>BEGIN_RING) && (sLastPrinted.rtyp<END_RING))
138        || ((sLastPrinted.rtyp==LIST_CMD)&&(lRingDependend((lists)sLastPrinted.data))))
139    {
140      sLastPrinted.CleanUp();
141      memset(&sLastPrinted,0,sizeof(sleftv));
142    }
143
144   /*------------ change the global ring -----------------------*/
145  #ifdef DRING
146  rChangeCurrRing(rg,complete,h);
147  #else
148  rChangeCurrRing(rg,complete);
149  #endif
150  currRingHdl = h;
151
152    /*------------ set pShortOut -----------------------*/
153  if (complete /*&&(h!=NULL)*/)
154  {
155    #ifdef HAVE_TCL
156    if (tclmode)
157    {
158      PrintTCLS('R',IDID(h));
159      pShortOut=(int)FALSE;
160    }
161    else
162    #endif
163    {
164      pShortOut=(int)TRUE;
165      if ((rg->parameter!=NULL) && (rg->ch<2))
166      {
167        for (i=0;i<rPar(rg);i++)
168        {
169          if(strlen(rg->parameter[i])>1)
170          {
171            pShortOut=(int)FALSE;
172            break;
173          }
174        }
175      }
176      if (pShortOut)
177      {
178        for (i=(rg->N-1);i>=0;i--)
179        {
180          if(strlen(rg->names[i])>1)
181          {
182            pShortOut=(int)FALSE;
183            break;
184          }
185        }
186      }
187    }
188  }
189
190}
191
192idhdl rDefault(char *s)
193{
194  idhdl tmp=NULL;
195
196  if (s!=NULL) tmp = enterid(s, myynest, RING_CMD, &IDROOT);
197  if (tmp==NULL) return NULL;
198
199  if (ppNoether!=NULL) pDelete(&ppNoether);
200  if ((sLastPrinted.rtyp>BEGIN_RING) && (sLastPrinted.rtyp<END_RING))
201  {
202    sLastPrinted.CleanUp();
203    memset(&sLastPrinted,0,sizeof(sleftv));
204  }
205
206  currRing = IDRING(tmp);
207
208  currRing->ch    = 32003;
209  currRing->N     = 3;
210  /*currRing->P     = 0; Alloc0 in idhdl::set, ipid.cc*/
211#ifdef RDEBUG
212  rNumber++;
213  currRing->no    =rNumber;
214#endif
215#ifdef SRING
216  currRing->partN = 4;
217#endif
218  /*names*/
219  currRing->names = (char **) Alloc(3 * sizeof(char *));
220  currRing->names[0]  = mstrdup("x");
221  currRing->names[1]  = mstrdup("y");
222  currRing->names[2]  = mstrdup("z");
223  /*weights: entries for 3 blocks: NULL*/
224  currRing->wvhdl = (short **)Alloc0(3 * sizeof(short *));
225  /*order: dp,C,0*/
226  currRing->order = (int *) Alloc(3 * sizeof(int *));
227  currRing->block0 = (int *)Alloc(3 * sizeof(int *));
228  currRing->block1 = (int *)Alloc(3 * sizeof(int *));
229  /* ringorder dp for the first block: var 1..3 */
230  currRing->order[0]  = ringorder_dp;
231  currRing->block0[0] = 1;
232  currRing->block1[0] = 3;
233  /* ringorder C for the second block: no vars */
234  currRing->order[1]  = ringorder_C;
235  currRing->block0[1] = 0;
236  currRing->block1[1] = 0;
237  /* the last block: everything is 0 */
238  currRing->order[2]  = 0;
239  currRing->block0[2] = 0;
240  currRing->block1[2] = 0;
241  /*polynomial ring*/
242  currRing->OrdSgn    = 1;
243
244  /* complete ring intializations */
245  rComplete(currRing);
246  rSetHdl(tmp,TRUE);
247  return currRingHdl;
248}
249
250///////////////////////////////////////////////////////////////////////////
251//
252// rInit: define a new ring from sleftv's
253//
254
255/////////////////////////////
256// Auxillary functions
257//
258
259// check intvec, describing the ordering
260static BOOLEAN rCheckIV(intvec *iv)
261{
262  if ((iv->length()!=2)&&(iv->length()!=3))
263  {
264    WerrorS("weights only for orderings wp,ws,Wp,Ws,a,M");
265    return TRUE;
266  }
267  return FALSE;
268}
269
270static int rTypeOfMatrixOrder(intvec * order)
271{
272  int i=0,j,typ=1;
273  int sz = (int)sqrt((double)(order->length()-2));
274
275  while ((i<sz) && (typ==1))
276  {
277    j=0;
278    while ((j<sz) && ((*order)[j*sz+i+2]==0)) j++;
279    if (j>=sz)
280    {
281      typ = 0;
282      WerrorS("Matrix order not complete");
283    }
284    else if ((*order)[j*sz+i+2]<0)
285      typ = -1;
286    else
287      i++;
288  }
289  return typ;
290}
291
292// set R->order, R->block, R->wvhdl, r->OrdSgn from sleftv
293static BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R)
294{
295  int last = 0, o=0, n = 1, i=0, typ = 1, j;
296  sleftv *sl = ord;
297
298  // determine nBlocks
299  while (sl!=NULL)
300  {
301    intvec *iv = (intvec *)(sl->data);
302    if (((*iv)[1]==ringorder_c)||((*iv)[1]==ringorder_C)) i++;
303    else if ((*iv)[1]!=ringorder_a) o++;
304    n++;
305    sl=sl->next;
306  }
307  // check whether at least one real ordering
308  if (o==0)
309  {
310    WerrorS("invalid combination of orderings");
311    return TRUE;
312  }
313  // if no c/C ordering is given, increment n
314  if (i==0) n++;
315  else if (i != 1)
316  {
317    // throw error if more than one is given
318    WerrorS("more than one ordering c/C specified");
319    return TRUE;
320  }
321 
322  // initialize fields of R
323  R->order=(int *)Alloc0(n*sizeof(int));
324  R->block0=(int *)Alloc0(n*sizeof(int));
325  R->block1=(int *)Alloc0(n*sizeof(int));
326  R->wvhdl=(short**)Alloc0(n*sizeof(short*));
327
328  // init order, so that rBlocks works correctly
329  for (j=0; j < n-1; j++)
330    R->order[j] = (int) ringorder_unspec;
331  // set last _C order, if no c/C order was given
332  if (i == 0) R->order[n-2] = ringorder_C;
333
334  /* init orders */
335  sl=ord;
336  n=-1;
337  while (sl!=NULL)
338  {
339    intvec *iv;
340    iv = (intvec *)(sl->data);
341    n++;
342
343    /* the format of an ordering:
344     *  iv[0]: factor
345     *  iv[1]: ordering
346     *  iv[2..end]: weights
347     */
348    R->order[n] = (*iv)[1];
349    switch ((*iv)[1])
350    {
351        case ringorder_ws:
352        case ringorder_Ws:
353          typ=-1;
354        case ringorder_wp:
355        case ringorder_Wp:
356          R->wvhdl[n]=(short*)AllocL((iv->length()-1)*sizeof(short));
357          for (i=2; i<iv->length(); i++)
358            R->wvhdl[n][i-2] = (short)(*iv)[i];
359          R->block0[n] = last+1;
360          last += iv->length()-2;
361          R->block1[n] = last;
362          break;
363        case ringorder_ls:
364        case ringorder_ds:
365        case ringorder_Ds:
366          typ=-1;
367        case ringorder_lp:
368        case ringorder_dp:
369        case ringorder_Dp:
370          R->block0[n] = last+1;
371          if (iv->length() == 3) last+=(*iv)[2];
372          else last += (*iv)[0];
373          R->block1[n] = last;
374          if (rCheckIV(iv)) return TRUE;
375          break;
376        case ringorder_c:
377        case ringorder_C:
378          if (rCheckIV(iv)) return TRUE;
379          break;
380        case ringorder_a:
381          R->block0[n] = last+1;
382          R->block1[n] = last + iv->length() - 2;
383          R->wvhdl[n] = (short*)AllocL((iv->length()-1)*sizeof(short));
384          for (i=2; i<iv->length(); i++)
385          {
386            R->wvhdl[n][i-2]=(short)(*iv)[i];
387            if ((*iv)[i]<0) typ=-1;
388          }
389          break;
390        case ringorder_M:
391        {
392          int Mtyp=rTypeOfMatrixOrder(iv);
393          if (Mtyp==0) return TRUE;
394          if (Mtyp==-1) typ = -1;
395
396          R->wvhdl[n] =( short*)AllocL((iv->length()-1)*sizeof(short));
397          for (i=2; i<iv->length();i++)
398            R->wvhdl[n][i-2]=(short)(*iv)[i];
399
400          R->block0[n] = last+1;
401          last += (int)sqrt((double)(iv->length()-2));
402          R->block1[n] = last;
403          break;
404        }
405       
406        case ringorder_no:
407           R->order[n] = ringorder_unspec;
408           return TRUE;
409           
410        default:
411          Werror("Internal Error: Unknown ordering %d", (*iv)[1]);
412          R->order[n] = ringorder_unspec;
413          return TRUE;
414    }
415    sl=sl->next;
416  }
417
418  // check for complete coverage
419  if ((R->order[n]==ringorder_c) ||  (R->order[n]==ringorder_C)) n--;
420  if (R->block1[n] != R->N)
421  {
422    if (((R->order[n]==ringorder_dp) ||
423         (R->order[n]==ringorder_ds) ||
424         (R->order[n]==ringorder_Dp) ||
425         (R->order[n]==ringorder_Ds) ||
426         (R->order[n]==ringorder_lp) ||
427         (R->order[n]==ringorder_ls))
428        && 
429        R->block0[n] <= R->N)
430    {
431      R->block1[n] = R->N;
432    }
433    else
434    {
435      Werror("mismatch of number of vars (%d) and ordering (%d vars)",
436             R->N,R->block1[n]);
437      return TRUE;
438    }
439  }
440  R->OrdSgn = typ;
441  return FALSE;
442}
443
444// get array of strings from list of sleftv's
445static BOOLEAN rSleftvList2StringArray(sleftv* sl, char** p)
446{
447 
448  while(sl!=NULL)
449  {
450    if (sl->Name() == sNoName)
451    {
452      if (sl->Typ()==POLY_CMD)
453      {
454        sleftv s_sl;
455        iiConvert(POLY_CMD,ANY_TYPE,-1,sl,&s_sl);
456        if (s_sl.Name() != sNoName) 
457          *p = mstrdup(s_sl.Name());
458        else
459          *p = NULL;
460        sl->next = s_sl.next;
461        s_sl.next = NULL;
462        s_sl.CleanUp(); 
463        if (*p == NULL) return TRUE;
464      }
465      else
466        return TRUE;
467    }
468    else
469      *p = mstrdup(sl->Name());
470    p++;
471    sl=sl->next;
472  }
473  return FALSE;
474}
475
476
477////////////////////
478//
479// rInit itself:
480//
481// INPUT:  s: name, pn: ch & parameter (names), rv: variable (names)
482//         ord: ordering
483// RETURN: currRingHdl on success
484//         NULL        on error
485// NOTE:   * makes new ring to current ring, on success
486//         * considers input sleftv's as read-only
487idhdl rInit(char *s, sleftv* pn, sleftv* rv, sleftv* ord,
488            BOOLEAN isDRing)
489{
490  int ch;
491  ring R = NULL;
492  idhdl tmp = NULL;
493  BOOLEAN ffChar=FALSE;
494
495  /* ch -------------------------------------------------------*/
496  // get ch of ground field
497  if (pn->Typ()==INT_CMD)
498  {
499    ch=(int)pn->Data();
500  }
501  else if (pn->name != NULL && strcmp(pn->name,"real")==0)
502  {
503    ch=-1;
504  }
505  else
506  {
507    Werror("Wrong ground field specification");
508    goto rInitError;
509  }
510  pn=pn->next;
511 
512  /* characteristic -----------------------------------------------*/
513  /* input: 0 ch=0 : Q     parameter=NULL    ffChar=FALSE
514   *         0    1 : Q(a,...)        *names         FALSE
515   *         0   -1 : R               NULL           FALSE
516   *         p    p : Fp              NULL           FALSE
517   *         p   -p : Fp(a)           *names         FALSE
518   *         q    q : GF(q=p^n)       *names         TRUE
519   */
520  if (ch!=-1)
521  {
522    int l = 0;
523   
524    if (ch!=0 && (ch<2) || (ch > 32003)) 
525    {
526      Warn("%d is invalid characteristic of ground field. 32003 is used.", ch);
527      ch=32003;
528    }
529    // load fftable, if necessary
530    if (pn!=NULL)
531    {
532      while ((ch!=fftable[l]) && (fftable[l])) l++;
533      if (fftable[l]==0) ch = IsPrime(ch);
534      else
535      {
536        char *m[1]={(char *)sNoName};
537        nfSetChar(ch,m);
538        if (errorreported) goto rInitError;
539        else ffChar=TRUE;
540      }
541    }
542    else
543      ch = IsPrime(ch);
544  }
545  // allocated ring and set ch
546  R = (ring) Alloc0(sizeof(sip_sring));
547  R->ch = ch;
548 
549  /* parameter -------------------------------------------------------*/
550  if (pn!=NULL)
551  {
552    R->P=pn->listLength();
553    if (ffChar && (R->P > 1) || ch == -1)
554    {
555      WerrorS("too many parameters");
556      goto rInitError;
557    }
558    R->parameter=(char**)Alloc0(R->P*sizeof(char *));
559    if (rSleftvList2StringArray(pn, R->parameter))
560    {
561      WerrorS("parameter expected");
562      goto rInitError;
563    }
564    if (ch>1 && !ffChar) R->ch=-ch;
565    else if (ch==0) R->ch=1;
566  }
567  else if (ffChar)
568  {
569    WerrorS("need one parameter");
570    goto rInitError;
571  }
572
573  /* names and number of variables-------------------------------------*/
574  R->N = rv->listLength();
575  R->names   = (char **)Alloc0(R->N * sizeof(char *));
576  if (rSleftvList2StringArray(rv, R->names))
577  {
578    WerrorS("name of ring variable expected");
579    goto rInitError;
580  }
581 
582  /* ordering -------------------------------------------------------------*/
583  if (rSleftvOrdering2Ordering(ord, R))
584    goto rInitError;
585
586  // Complete the initialization
587  if (rComplete(R))
588    goto rInitError;
589 
590  // try to enter the ring into the name list //
591  if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
592    goto rInitError;
593 
594  memcpy(IDRING(tmp),R,sizeof(*R));
595  // set current ring
596  Free(R,  sizeof(ip_sring));
597#ifdef RDEBUG
598  rNumber++;
599  R->no    =rNumber;
600#endif
601  return tmp;
602
603  // error case:
604  rInitError:
605  if  (R != NULL) rDelete(R);
606  return NULL;
607}
608
609// set those fields of the ring, which can be computed from other fields:
610// More particularly, sets r->VarOffset
611BOOLEAN rComplete(ring r, int force)
612{
613 
614  int VarCompIndex, VarLowIndex, VarHighIndex;
615  // check number of vars and number of params
616  if (r->N + 1 > (int) MAX_EXPONENT_NUMBER)
617  {
618    Werror("Too many ring variables: %d is the maximum", 
619           MAX_EXPONENT_NUMBER -1);
620    return TRUE;
621  }
622 
623
624  r->VarOffset = (int*) Alloc((r->N + 1)*sizeof(int));
625  pGetVarIndicies(r, r->VarOffset, VarCompIndex,
626                  VarLowIndex, VarHighIndex);
627  r->VarCompIndex = VarCompIndex;
628  r->VarLowIndex = VarLowIndex;
629  r->VarHighIndex = VarHighIndex;
630  return FALSE;
631}
632
633/*2
634 * set a new ring from the data:
635 s: name, chr: ch, varnames: rv, ordering: ord, typ: typ
636 */
637#ifdef DRING
638void rDSet()
639{
640  pDRING=TRUE;
641  pSDRING=TRUE;
642  pdN=currRing->partN;
643  pdK=pVariables-pdN*2-1;
644}
645#endif
646
647int rIsRingVar(char *n)
648{
649  if ((currRing!=NULL) && (currRing->names!=NULL))
650  {
651    for (int i=0; i<currRing->N; i++)
652    {
653      if (currRing->names[i]==NULL) return -1;
654      if (strcmp(n,currRing->names[i]) == 0) return (int)i;
655    }
656  }
657  return -1;
658}
659
660char* RingVar(short i)
661{
662  return currRing->names[i];
663}
664
665void rWrite(ring r)
666{
667  if ((r==NULL)||(r->order==NULL))
668    return; /*to avoid printing after errors....*/
669
670  int nblocks=rBlocks(r);
671
672  mmTestP(r,sizeof(ip_sring));
673  mmTestP(r->order,nblocks*sizeof(int));
674  mmTestP(r->block0,nblocks*sizeof(int));
675  mmTestP(r->block1,nblocks*sizeof(int));
676  mmTestP(r->wvhdl,nblocks*sizeof(short *));
677  mmTestP(r->names,r->N*sizeof(char *));
678
679  nblocks--;
680
681
682  if (rField_is_GF(r))
683  {
684    Print("//   # ground field : %d\n",rInternalChar(r));
685    Print("//   primitive element : %s\n", r->parameter[0]);
686    if (r==currRing)
687    {
688      StringSetS("//   minpoly        : ");
689      nfShowMipo();PrintS(StringAppend("\n"));
690    }
691  }
692  else
693  {
694    PrintS("//   characteristic : ");
695    if ( rField_is_R(r) )        PrintS("0 (real)\n");  /* R */
696    else Print ("%d\n",rChar(r)); /* Fp(a) */
697    if (r->parameter!=NULL)
698    {
699      Print ("//   %d parameter    : ",rPar(r));
700      char **sp=r->parameter;
701      int nop=0;
702      while (nop<rPar(r))
703      {
704        PrintS(*sp);
705        PrintS(" ");
706        sp++; nop++;
707      }
708      PrintS("\n//   minpoly        : ");
709      if (r==currRing)
710      {
711        StringSetS(""); nWrite(r->minpoly); PrintS(StringAppendS("\n"));
712      }
713      else if (r->minpoly==NULL)
714      {
715        PrintS("0\n");
716      }
717      else
718      {
719        PrintS("...\n");
720      }
721    }
722  }
723  Print("//   number of vars : %d",r->N);
724
725  //for (nblocks=0; r->order[nblocks]; nblocks++);
726  nblocks=rBlocks(r)-1;
727
728  for (int l=0, nlen=0 ; l<nblocks; l++)
729  {
730    int i;
731    Print("\n//        block %3d : ",l+1);
732
733    Print("ordering %c", (" acCMldDwWldDwWu")[r->order[l]]);
734    if ((r->order[l]>=ringorder_lp)&&(r->order[l]!=ringorder_unspec))
735    {
736      if (r->order[l]>=ringorder_ls)
737        PrintS("s");
738      else
739        PrintS("p");
740    }
741
742    if ((r->order[l] != ringorder_c) && (r->order[l] != ringorder_C))
743    {
744      PrintS("\n//                  : names    ");
745      for (i = r->block0[l]-1; i<r->block1[l]; i++)
746      {
747        nlen = strlen(r->names[i]);
748        Print("%s ",r->names[i]);
749      }
750    }
751
752    if (r->wvhdl[l]!=NULL)
753    {
754      for (int j= 0;
755           j<(r->block1[l]-r->block0[l]+1)*(r->block1[l]-r->block0[l]+1);
756           j+=i)
757      {
758        PrintS("\n//                  : weights  ");
759        for (i = 0; i<=r->block1[l]-r->block0[l]; i++)
760        {
761          Print("%*d " ,nlen,r->wvhdl[l][i+j],i+j);
762        }
763        if (r->order[l]!=ringorder_M) break;
764      }
765    }
766  }
767  if (r->qideal!=NULL)
768  {
769    PrintS("\n// quotient ring from ideal");
770    if (r==currRing)
771    {
772      PrintLn();
773      iiWriteMatrix((matrix)r->qideal,"_",1);
774    }
775    else PrintS(" ...");
776  }
777}
778
779static void rDelete(ring r)
780{
781  int i, j;
782 
783  if (r == NULL) return;
784 
785  // delete order stuff
786  if (r->order != NULL)
787  {
788    i=rBlocks(r);
789    assume(r->block0 != NULL && r->block1 != NULL && r->wvhdl != NULL);
790    // delete order
791    Free((ADDRESS)r->order,i*sizeof(int));
792    Free((ADDRESS)r->block0,i*sizeof(int));
793    Free((ADDRESS)r->block1,i*sizeof(int));
794    // delete weights
795    for (j=0; j<i; j++)
796    {
797      if (r->wvhdl[j]!=NULL)
798        FreeL(r->wvhdl[j]);
799    }
800    Free((ADDRESS)r->wvhdl,i*sizeof(short *));
801  }
802  else
803  {
804    assume(r->block0 == NULL && r->block1 == NULL && r->wvhdl == NULL);
805  }
806 
807  // delete varnames
808  if(r->names!=NULL)
809  {
810    for (i=0; i<r->N; i++)
811    {
812      if (r->names[i] != NULL) FreeL((ADDRESS)r->names[i]);
813    }
814    Free((ADDRESS)r->names,r->N*sizeof(char *));
815  }
816 
817  // delete parameter
818  if (r->parameter!=NULL)
819  {
820    char **s=r->parameter;
821    j = 0;
822    while (j < rPar(r))
823    {
824      if (*s != NULL) FreeL((ADDRESS)*s);
825      s++;
826      j++;
827    }
828    Free((ADDRESS)r->parameter,rPar(r)*sizeof(char *));
829  }
830  if (r->VarOffset != NULL) 
831    Free((ADDRESS)r->VarOffset, (r->N +1)*sizeof(int));
832  Free(r, sizeof(ip_sring));
833}
834
835void rKill(ring r)
836{
837  rTest(r);
838  if ((r->ref<=0)&&(r->order!=NULL))
839  {
840#ifdef RDEBUG
841    if (traceit &TRACE_SHOW_RINGS) Print("kill ring %d\n",r->no);
842#endif
843    if (r==currRing)
844    {
845      if (r->qideal!=NULL)
846      {
847        idDelete(&r->qideal);
848        r->qideal=NULL;
849        currQuotient=NULL;
850      }
851      if (ppNoether!=NULL) pDelete(&ppNoether);
852      if ((sLastPrinted.rtyp>BEGIN_RING) && (sLastPrinted.rtyp<END_RING))
853      {
854        sLastPrinted.CleanUp();
855        memset(&sLastPrinted,0,sizeof(sleftv));
856      }
857      currRing=NULL;
858      currRingHdl=NULL;
859    }
860    else if (r->qideal!=NULL)
861    {
862      ring savecurrRing = currRing;
863      rChangeCurrRing((ring)r,FALSE);
864      idDelete(&r->qideal);
865      r->qideal=NULL;
866      rChangeCurrRing(savecurrRing,FALSE);
867    }
868    int i=1;
869    int j;
870    int *pi=r->order;
871#ifdef USE_IILOCALRING
872    for (j=0;j<iiRETURNEXPR_len;j++)
873    {
874      if (iiLocalRing[j]==r)
875      {
876        if (j<myynest) Warn("killing the basering for level %d",j);
877        iiLocalRing[j]=NULL;
878      }
879    }
880#else /* USE_IILOCALRING */
881    {
882      namehdl nshdl = namespaceroot;
883
884      for(nshdl=namespaceroot; nshdl->isroot != TRUE; nshdl = nshdl->next) {
885        //Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
886        if (nshdl->currRing==r)
887        {
888          if (nshdl->myynest<myynest)
889//            Warn("killing the basering for level %d/%d",nshdl->lev,nshdl->myynest);
890          Warn("killing the basering for level %d",nshdl->myynest);
891          nshdl->currRing=NULL;
892        }
893      }
894      if (nshdl->currRing==r)
895      {
896        //Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
897        if (nshdl->myynest<myynest)
898//          Warn("killing the basering for level %d/%d",nshdl->lev,nshdl->myynest);
899          Warn("killing the basering for level %d",nshdl->myynest);
900        nshdl->currRing=NULL;
901      }
902    }
903#endif /* USE_IILOCALRING */
904
905    rDelete(r);
906    return;
907  }
908  r->ref--;
909}
910
911void rKill(idhdl h)
912{
913#ifndef HAVE_NAMESPACES1
914  ring r = IDRING(h);
915  if (r!=NULL) rKill(r);
916  if (h==currRingHdl)
917  {
918#ifdef HAVE_NAMESPACES
919    namehdl nsHdl = namespaceroot;
920    while(nsHdl!=NULL) {
921      currRingHdl=NSROOT(nsHdl);
922#else /* HAVE_NAMESPACES */
923      currRingHdl=IDROOT;
924#endif /* HAVE_NAMESPACES */
925      while (currRingHdl!=NULL)
926      {
927        if ((currRingHdl!=h)
928            && (IDTYP(currRingHdl)==IDTYP(h))
929            && (h->data.uring==currRingHdl->data.uring))
930          break;
931        currRingHdl=IDNEXT(currRingHdl);
932      }
933#ifdef HAVE_NAMESPACES
934      if ((currRingHdl != NULL) && (currRingHdl!=h)
935          && (IDTYP(currRingHdl)==IDTYP(h))
936          && (h->data.uring==currRingHdl->data.uring))
937        break;
938      nsHdl = nsHdl->next;
939    }
940#endif /* HAVE_NAMESPACES */
941  }
942#else
943    if(currRingHdl==NULL) {
944      namehdl ns = namespaceroot;
945      BOOLEAN found=FALSE;
946
947      while(!ns->isroot) {
948        currRingHdl=NSROOT(namespaceroot->next);
949        while (currRingHdl!=NULL)
950        {
951          if ((currRingHdl!=h)
952              && (IDTYP(currRingHdl)==IDTYP(h))
953              && (h->data.uring==currRingHdl->data.uring))
954          { found=TRUE; break; }
955
956          currRingHdl=IDNEXT(currRingHdl);
957        }
958        if(found) break;
959        ns=IDNEXT(ns);
960      }
961    }
962    if(currRingHdl == NULL || IDRING(h) != IDRING(currRingHdl)) {
963      currRingHdl = namespaceroot->currRingHdl;
964
965/*      PrintS("Running rFind()\n");
966      currRingHdl = rFindHdl(IDRING(h), NULL, NULL);
967      if(currRingHdl == NULL)
968      {
969        PrintS("rFind()return 0\n");
970      }
971      else
972      {
973        PrintS("Huppi rfind return an currRingHDL\n");
974        Print("%x, %x\n", IDRING(h),IDRING(currRingHdl) );
975      }
976*/
977    }
978    else
979    {
980      //PrintS("Huppi found an currRingHDL\n");
981      //Print("%x, %x\n", IDRING(h),IDRING(currRingHdl) );
982
983    }
984#endif /* HAVE_NAMESPACES */
985}
986
987idhdl rFindHdl(ring r, idhdl n, idhdl w)
988{
989#ifdef HAVE_NAMESPACES
990  idhdl h;
991  namehdl ns = namespaceroot;
992
993  while(!ns->isroot) {
994    h = NSROOT(ns);
995    if(w != NULL) h = w;
996    while (h!=NULL)
997    {
998      if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
999          && (h->data.uring==r)
1000          && (h!=n))
1001        return h;
1002      h=IDNEXT(h);
1003    }
1004    ns = ns->next;
1005  }
1006  h = NSROOT(ns);
1007  if(w != NULL) h = w;
1008  while (h!=NULL)
1009  {
1010    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1011        && (h->data.uring==r)
1012        && (h!=n))
1013      return h;
1014    h=IDNEXT(h);
1015  }
1016#if 0
1017  if(namespaceroot->isroot) h = IDROOT;
1018  else h = NSROOT(namespaceroot->next);
1019  if(w != NULL) h = w;
1020  while (h!=NULL)
1021  {
1022    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1023        && (h->data.uring==r)
1024        && (h!=n))
1025      return h;
1026    h=IDNEXT(h);
1027  }
1028#endif
1029#else
1030  idhdl h=IDROOT;
1031  if(w != NULL) h = w;
1032  while (h!=NULL)
1033  {
1034    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1035        && (h->data.uring==r)
1036        && (h!=n))
1037      return h;
1038    h=IDNEXT(h);
1039  }
1040#endif
1041  return NULL;
1042}
1043
1044int rOrderName(char * ordername)
1045{
1046  int order=0;
1047
1048  switch (*ordername)
1049  {
1050  case 'l':
1051    if (*(ordername+1)=='p') order = ringorder_lp;
1052    else if (*(ordername+1)=='s') order = ringorder_ls;
1053    break;
1054  case 'd':
1055    if (*(ordername+1)=='p') order = ringorder_dp;
1056    else if (*(ordername+1)=='s') order = ringorder_ds;
1057    break;
1058  case 'w':
1059    if (*(ordername+1)=='p') order = ringorder_wp;
1060    else if (*(ordername+1)=='s') order = ringorder_ws;
1061    break;
1062  case 'D':
1063    if (*(ordername+1)=='p') order = ringorder_Dp;
1064    else if (*(ordername+1)=='s') order = ringorder_Ds;
1065    break;
1066  case 'W':
1067    if (*(ordername+1)=='p') order = ringorder_Wp;
1068    else if (*(ordername+1)=='s') order = ringorder_Ws;
1069    break;
1070  case 'c': order = ringorder_c; break;
1071  case 'C': order = ringorder_C; break;
1072  case 'a': order = ringorder_a; break;
1073  case 'M': order = ringorder_M; break;
1074  default: break;
1075  }
1076  if (order==0) Werror("wrong ring order `%s`",ordername);
1077  FreeL((ADDRESS)ordername);
1078  return order;
1079}
1080
1081char * rOrdStr(ring r)
1082{
1083  int nblocks,l,i;
1084
1085  for (nblocks=0; r->order[nblocks]; nblocks++);
1086  nblocks--;
1087
1088  StringSetS("");
1089  for (l=0; ; l++)
1090  {
1091    StringAppend("%c",(" acCMldDwWldDwW")[r->order[l]]);
1092    if (r->order[l]>=ringorder_lp)
1093    {
1094      if (r->order[l]>=ringorder_ls)
1095        StringAppendS("s");
1096      else
1097        StringAppendS("p");
1098    }
1099    if ((r->order[l] != ringorder_c) && (r->order[l] != ringorder_C))
1100    {
1101      if (r->wvhdl[l]!=NULL)
1102      {
1103        StringAppendS("(");
1104        for (int j= 0;
1105             j<(r->block1[l]-r->block0[l]+1)*(r->block1[l]-r->block0[l]+1);
1106             j+=i+1)
1107        {
1108          char c=',';
1109          for (i = 0; i<r->block1[l]-r->block0[l]; i++)
1110          {
1111            StringAppend("%d," ,r->wvhdl[l][i+j]);
1112          }
1113          if (r->order[l]!=ringorder_M)
1114          {
1115            StringAppend("%d)" ,r->wvhdl[l][i+j]);
1116            break;
1117          }
1118          if (j+i+1==(r->block1[l]-r->block0[l]+1)*(r->block1[l]-r->block0[l]+1))
1119            c=')';
1120          StringAppend("%d%c" ,r->wvhdl[l][i+j],c);
1121        }
1122      }
1123      else
1124        StringAppend("(%d)",r->block1[l]-r->block0[l]+1);
1125    }
1126    if (l==nblocks) return mstrdup(StringAppendS(""));
1127    StringAppendS(",");
1128  }
1129}
1130
1131char * rVarStr(ring r)
1132{
1133  int i;
1134  int l=2;
1135  char *s;
1136
1137  for (i=0; i<r->N; i++)
1138  {
1139    l+=strlen(r->names[i])+1;
1140  }
1141  s=(char *)AllocL(l);
1142  s[0]='\0';
1143  for (i=0; i<r->N-1; i++)
1144  {
1145    strcat(s,r->names[i]);
1146    strcat(s,",");
1147  }
1148  strcat(s,r->names[i]);
1149  return s;
1150}
1151
1152char * rCharStr(ring r)
1153{
1154  char *s;
1155  int i;
1156
1157  if (r->parameter==NULL)
1158  {
1159    i=r->ch;
1160    if(i==-1)
1161      s=mstrdup("real");                    /* R */
1162    else
1163    {
1164      s=(char *)AllocL(6);
1165      sprintf(s,"%d",i);                   /* Q, Z/p */
1166    }
1167    return s;
1168  }
1169  int l=0;
1170  for(i=0; i<rPar(r);i++)
1171  {
1172    l+=(strlen(r->parameter[i])+1);
1173  }
1174  s=(char *)AllocL(l+6);
1175  s[0]='\0';
1176  if (r->ch<0)       sprintf(s,"%d",-r->ch); /* Fp(a) */
1177  else if (r->ch==1) sprintf(s,"0");         /* Q(a)  */
1178  else
1179  {
1180    sprintf(s,"%d,%s",r->ch,r->parameter[0]); /* Fq  */
1181    return s;
1182  }
1183  char tt[2];
1184  tt[0]=',';
1185  tt[1]='\0';
1186  for(i=0; i<rPar(r);i++)
1187  {
1188    strcat(s,tt);
1189    strcat(s,r->parameter[i]);
1190  }
1191  return s;
1192}
1193
1194char * rParStr(ring r)
1195{
1196  if (r->parameter==NULL) return mstrdup("");
1197
1198  int i;
1199  int l=2;
1200
1201  for (i=0; i<rPar(r); i++)
1202  {
1203    l+=strlen(r->parameter[i])+1;
1204  }
1205  char *s=(char *)AllocL(l);
1206  s[0]='\0';
1207  for (i=0; i<rPar(r)-1; i++)
1208  {
1209    strcat(s,r->parameter[i]);
1210    strcat(s,",");
1211  }
1212  strcat(s,r->parameter[i]);
1213  return s;
1214}
1215
1216char * rString(ring r)
1217{
1218  char *ch=rCharStr(r);
1219  char *var=rVarStr(r);
1220  char *ord=rOrdStr(r);
1221  char *res=(char *)AllocL(strlen(ch)+strlen(var)+strlen(ord)+9);
1222  sprintf(res,"(%s),(%s),(%s)",ch,var,ord);
1223  FreeL((ADDRESS)ch);
1224  FreeL((ADDRESS)var);
1225  FreeL((ADDRESS)ord);
1226  return res;
1227}
1228
1229int rChar(ring r)
1230{
1231  if (r->ch==-1)
1232    return 0;
1233  if (r->parameter==NULL) /* Q, Fp */
1234    return r->ch;
1235  if (r->ch<0)           /* Fp(a)  */
1236    return -r->ch;
1237  if (r->ch==1)          /* Q(a)  */
1238    return 0;
1239  /*else*/               /* GF(p,n) */
1240  {
1241    if ((r->ch & 1)==0) return 2;
1242    int i=3;
1243    while ((r->ch % i)!=0) i+=2;
1244    return i;
1245  }
1246}
1247
1248int    rIsExtension(ring r)
1249{
1250  if (r->parameter==NULL) /* Q, Fp */
1251    return FALSE;
1252  else
1253    return TRUE;
1254}
1255
1256int    rIsExtension()
1257{
1258  return rIsExtension( currRing );
1259}
1260
1261/*2
1262 *returns -1 for not compatible, (sum is undefined)
1263 *         0 for equal, (and sum)
1264 *         1 for compatible (and sum)
1265 */
1266int rSum(ring r1, ring r2, ring &sum)
1267{
1268  if (r1==r2)
1269  {
1270    sum=r1;
1271    r1->ref++;
1272    return 0;
1273  }
1274  ip_sring tmpR;
1275  memset(&tmpR,0,sizeof(tmpR));
1276  /* check coeff. field =====================================================*/
1277  if (rInternalChar(r1)==rInternalChar(r2))
1278  {
1279    tmpR.ch=rInternalChar(r1);
1280    if (rField_is_Q(r1)||rField_is_Zp(r1)||rField_is_GF(r1)) /*Q, Z/p, GF(p,n)*/
1281    {
1282      if (r1->parameter!=NULL)
1283      {
1284        if (strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1285        {
1286          tmpR.parameter=(char **)Alloc(sizeof(char *));
1287          tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1288          tmpR.P=1;
1289        }
1290        else
1291        {
1292          WerrorS("GF(p,n)+GF(p,n)");
1293          return -1;
1294        }
1295      }
1296    }
1297    else if ((r1->ch==1)||(r1->ch<-1)) /* Q(a),Z/p(a) */
1298    {
1299      if (r1->minpoly!=NULL)
1300      {
1301        if (r2->minpoly!=NULL)
1302        {
1303          nSetChar(rInternalChar(r1),TRUE,r1->parameter,rPar(r1));
1304          if ((strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1305              && naEqual(r1->minpoly,r2->minpoly))
1306          {
1307            tmpR.parameter=(char **)Alloc(sizeof(char *));
1308            tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1309            tmpR.minpoly=naCopy(r1->minpoly);
1310            tmpR.P=1;
1311            nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1312              rPar(currRing));
1313          }
1314          else
1315          {
1316            nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1317              rPar(currRing));
1318            WerrorS("different minpolys");
1319            return -1;
1320          }
1321        }
1322        else
1323        {
1324          if ((strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1325              && (rPar(r2)==1))
1326          {
1327            tmpR.parameter=(char **)Alloc0(sizeof(char *));
1328            tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1329            tmpR.P=1;
1330            nSetChar(rInternalChar(r1),TRUE,r1->parameter,rPar(r1));
1331            tmpR.minpoly=naCopy(r1->minpoly);
1332            nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1333              rPar(currRing));
1334          }
1335          else
1336          {
1337            WerrorS("different parameters and minpoly!=0");
1338            return -1;
1339          }
1340        }
1341      }
1342      else /* r1->minpoly==NULL */
1343      {
1344        if (r2->minpoly!=NULL)
1345        {
1346          if ((strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1347              && (rPar(r1)==1))
1348          {
1349            tmpR.parameter=(char **)Alloc(sizeof(char *));
1350            tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1351            tmpR.P=1;
1352            nSetChar(rInternalChar(r2),TRUE,r2->parameter,rPar(r2));
1353            tmpR.minpoly=naCopy(r2->minpoly);
1354            nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1355              rPar(currRing));
1356          }
1357          else
1358          {
1359            WerrorS("different parameters and minpoly!=0");
1360            return -1;
1361          }
1362        }
1363        else
1364        {
1365          int len=rPar(r1)+rPar(r2);
1366          tmpR.parameter=(char **)Alloc(len*sizeof(char *));
1367          int i;
1368          for (i=0;i<rPar(r1);i++)
1369          {
1370            tmpR.parameter[i]=mstrdup(r1->parameter[i]);
1371          }
1372          int j,l;
1373          for(j=0;j<rPar(r2);j++)
1374          {
1375            for(l=0;l<i;l++)
1376            {
1377              if(strcmp(tmpR.parameter[l],r2->parameter[j])==0)
1378                break;
1379            }
1380            if (l==i)
1381            {
1382              tmpR.parameter[i]=mstrdup(r2->parameter[j]);
1383              i++;
1384            }
1385          }
1386          if (i!=len)
1387          {
1388            ReAlloc(tmpR.parameter,len*sizeof(char *),i*sizeof(char *));
1389          }
1390        }
1391      }
1392    }
1393  }
1394  else /* r1->ch!=r2->ch */
1395  {
1396    if (r1->ch<-1) /* Z/p(a) */
1397    {
1398      if ((r2->ch==0) /* Q */
1399          || (r2->ch==-r1->ch)) /* Z/p */
1400      {
1401        tmpR.ch=rInternalChar(r1);
1402        tmpR.parameter=(char **)Alloc(rPar(r1)*sizeof(char *));
1403        tmpR.P=rPar(r1);
1404        memcpy(tmpR.parameter,r1->parameter,rPar(r1)*sizeof(char *));
1405        if (r1->minpoly!=NULL)
1406        {
1407          nSetChar(rInternalChar(r1),TRUE,r1->parameter,rPar(r1));
1408          tmpR.minpoly=naCopy(r1->minpoly);
1409          nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1410            rPar(currRing));
1411        }
1412      }
1413      else  /* R, Q(a),Z/q,Z/p(a),GF(p,n) */
1414      {
1415        WerrorS("Z/p(a)+(R,Q(a),Z/q(a),GF(q,n))");
1416        return -1;
1417      }
1418    }
1419    else if (r1->ch==-1) /* R */
1420    {
1421      WerrorS("R+..");
1422      return -1;
1423    }
1424    else if (r1->ch==0) /* Q */
1425    {
1426      if ((r2->ch<-1)||(r2->ch==1)) /* Z/p(a),Q(a) */
1427      {
1428        tmpR.ch=rInternalChar(r2);
1429        tmpR.P=rPar(r2);
1430        tmpR.parameter=(char **)Alloc(rPar(r2)*sizeof(char *));
1431        memcpy(tmpR.parameter,r2->parameter,rPar(r2)*sizeof(char *));
1432        if (r2->minpoly!=NULL)
1433        {
1434          nSetChar(rInternalChar(r1),TRUE,r1->parameter,rPar(r1));
1435          tmpR.minpoly=naCopy(r2->minpoly);
1436          nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1437            rPar(currRing));
1438        }
1439      }
1440      else if (r2->ch>1) /* Z/p,GF(p,n) */
1441      {
1442        tmpR.ch=r2->ch;
1443        if (r2->parameter!=NULL)
1444        {
1445          tmpR.parameter=(char **)Alloc(sizeof(char *));
1446          tmpR.P=1;
1447          tmpR.parameter[0]=mstrdup(r2->parameter[0]);
1448        }
1449      }
1450      else
1451      {
1452        WerrorS("Q+R");
1453        return -1; /* R */
1454      }
1455    }
1456    else if (r1->ch==1) /* Q(a) */
1457    {
1458      if (r2->ch==0) /* Q */
1459      {
1460        tmpR.ch=rInternalChar(r1);
1461        tmpR.P=rPar(r1);
1462        tmpR.parameter=(char **)Alloc0(rPar(r1)*sizeof(char *));
1463        int i;
1464        for(i=0;i<rPar(r1);i++)
1465        {
1466          tmpR.parameter[i]=mstrdup(r1->parameter[i]);
1467        }
1468        if (r1->minpoly!=NULL)
1469        {
1470          nSetChar(rInternalChar(r1),TRUE,r1->parameter,rPar(r1));
1471          tmpR.minpoly=naCopy(r1->minpoly);
1472          nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1473            rPar(currRing));
1474        }
1475      }
1476      else  /* R, Z/p,GF(p,n) */
1477      {
1478        WerrorS("Q(a)+(R,Z/p,GF(p,n))");
1479        return -1;
1480      }
1481    }
1482    else /* r1->ch >=2 , Z/p */
1483    {
1484      if (r2->ch==0) /* Q */
1485      {
1486        tmpR.ch=r1->ch;
1487      }
1488      else if (r2->ch==-r1->ch) /* Z/p(a) */
1489      {
1490        tmpR.ch=rInternalChar(r2);
1491        tmpR.P=rPar(r2);
1492        tmpR.parameter=(char **)Alloc(rPar(r2)*sizeof(char *));
1493        int i;
1494        for(i=0;i<rPar(r2);i++)
1495        {
1496          tmpR.parameter[i]=mstrdup(r2->parameter[i]);
1497        }
1498        if (r2->minpoly!=NULL)
1499        {
1500          nSetChar(rInternalChar(r2),TRUE,r2->parameter,rPar(r2));
1501          tmpR.minpoly=naCopy(r2->minpoly);
1502          nSetChar(rInternalChar(currRing),TRUE,currRing->parameter,
1503            rPar(currRing));
1504        }
1505      }
1506      else
1507      {
1508        WerrorS("Z/p+(GF(q,n),Z/q(a),R,Q(a))");
1509        return -1; /* GF(p,n),Z/q(a),R,Q(a) */
1510      }
1511    }
1512  }
1513  /* variable names ========================================================*/
1514  int i,j,k;
1515  int l=r1->N+r2->N;
1516  char **names=(char **)Alloc0(l*sizeof(char*));
1517  k=0;
1518
1519  // collect all varnames from r1, except those which are parameters
1520  // of r2, or those which are the empty string
1521  for (i=0;i<r1->N;i++)
1522  {
1523    BOOLEAN b=TRUE;
1524
1525    if (*(r1->names[i]) == '\0')
1526      b = FALSE;
1527    else if ((r2->parameter!=NULL) && (strlen(r1->names[i])==1))
1528    {
1529      for(j=0;j<rPar(r2);j++)
1530      {
1531        if (strcmp(r1->names[i],r2->parameter[j])==0)
1532        {
1533          b=FALSE;
1534          break;
1535        }
1536      }
1537    }
1538
1539    if (b)
1540    {
1541      //Print("name : %d: %s\n",k,r1->names[i]);
1542      names[k]=mstrdup(r1->names[i]);
1543      k++;
1544    }
1545    //else
1546    //  Print("no name (par1) %s\n",r1->names[i]);
1547  }
1548  // Add variables from r2, except those which are parameters of r1
1549  // those which are empty strings, and those which equal a var of r1
1550  for(i=0;i<r2->N;i++)
1551  {
1552    BOOLEAN b=TRUE;
1553
1554    if (*(r2->names[i]) == '\0')
1555      b = FALSE;
1556    else if ((r1->parameter!=NULL) && (strlen(r2->names[i])==1))
1557    {
1558      for(j=0;j<rPar(r1);j++)
1559      {
1560        if (strcmp(r2->names[i],r1->parameter[j])==0)
1561        {
1562          b=FALSE;
1563          break;
1564        }
1565      }
1566    }
1567
1568    if (b)
1569    {
1570      for(j=0;j<r1->N;j++)
1571      {
1572        if (strcmp(r1->names[j],r2->names[i])==0)
1573        {
1574          b=FALSE;
1575          break;
1576        }
1577      }
1578      if (b)
1579      {
1580        names[k]=mstrdup(r2->names[i]);
1581        //Print("name : %d : %s\n",k,r2->names[i]);
1582        k++;
1583      }
1584      //else
1585      //  Print("no name (var): %s\n",r2->names[i]);
1586    }
1587    //else
1588    //  Print("no name (par): %s\n",r2->names[i]);
1589  }
1590  // check whether we found any vars at all
1591  if (k == 0)
1592  {
1593    names[k]=mstrdup("");
1594    k=1;
1595  }
1596  tmpR.N=k;
1597  tmpR.names=names;
1598  /* ordering *======================================================== */
1599  tmpR.OrdSgn=1;
1600  if ((r1->order[0]==ringorder_unspec)
1601      && (r2->order[0]==ringorder_unspec))
1602  {
1603    tmpR.order=(int*)Alloc(3*sizeof(int));
1604    tmpR.block0=(int*)Alloc(3*sizeof(int));
1605    tmpR.block1=(int*)Alloc(3*sizeof(int));
1606    tmpR.wvhdl=(short**)Alloc0(3*sizeof(short*));
1607    tmpR.order[0]=ringorder_unspec;
1608    tmpR.order[1]=ringorder_C;
1609    tmpR.order[2]=0;
1610    tmpR.block0[0]=1;
1611    tmpR.block1[0]=tmpR.N;
1612  }
1613  else if (l==k) /* r3=r1+r2 */
1614  {
1615    int b;
1616    ring rb;
1617    if (r1->order[0]==ringorder_unspec)
1618    {
1619      /* extend order of r2 to r3 */
1620      b=rBlocks(r2);
1621      rb=r2;
1622      tmpR.OrdSgn=r2->OrdSgn;
1623    }
1624    else if (r2->order[0]==ringorder_unspec)
1625    {
1626      /* extend order of r1 to r3 */
1627      b=rBlocks(r1);
1628      rb=r1;
1629      tmpR.OrdSgn=r1->OrdSgn;
1630    }
1631    else
1632    {
1633      b=rBlocks(r1)+rBlocks(r2)-2; /* for only one order C, only one 0 */
1634      rb=NULL;
1635    }
1636    tmpR.order=(int*)Alloc0(b*sizeof(int));
1637    tmpR.block0=(int*)Alloc0(b*sizeof(int));
1638    tmpR.block1=(int*)Alloc0(b*sizeof(int));
1639    tmpR.wvhdl=(short**)Alloc0(b*sizeof(short*));
1640    if (rb!=NULL)
1641    {
1642      for (i=0;i<b;i++)
1643      {
1644        tmpR.order[i]=rb->order[i];
1645        tmpR.block0[i]=rb->block0[i];
1646        tmpR.block1[i]=rb->block1[i];
1647        if (rb->wvhdl[i]!=NULL)
1648          WarnS("rSum: weights not implemented");
1649      }
1650      tmpR.block0[0]=1;
1651    }
1652    else /* ring sum for complete rings */
1653    {
1654      for (i=0;r1->order[i]!=0;i++)
1655      {
1656        tmpR.order[i]=r1->order[i];
1657        tmpR.block0[i]=r1->block0[i];
1658        tmpR.block1[i]=r1->block1[i];
1659        if (r1->wvhdl[i]!=NULL)
1660        {
1661          int l=mmSizeL(r1->wvhdl[i]);
1662          tmpR.wvhdl[i]=(short *)AllocL(l);
1663          memcpy(tmpR.wvhdl[i],r1->wvhdl[i],l);
1664        }
1665      }
1666      j=i;
1667      i--;
1668      if ((r1->order[i]==ringorder_c)
1669          ||(r1->order[i]==ringorder_C))
1670      {
1671        j--;
1672        tmpR.order[b-2]=r1->order[i];
1673      }
1674      for (i=0;r2->order[i]!=0;i++,j++)
1675      {
1676        if ((r2->order[i]!=ringorder_c)
1677            &&(r2->order[i]!=ringorder_C))
1678        {
1679          tmpR.order[j]=r2->order[i];
1680          tmpR.block0[j]=r2->block0[i]+r1->N;
1681          tmpR.block1[j]=r2->block1[i]+r1->N;
1682          if (r2->wvhdl[i]!=NULL)
1683          {
1684            int l=mmSizeL(r2->wvhdl[i]);
1685            tmpR.wvhdl[j]=(short *)AllocL(l);
1686            memcpy(tmpR.wvhdl[j],r2->wvhdl[i],l);
1687          }
1688        }
1689      }
1690      if((r1->OrdSgn==-1)||(r2->OrdSgn==-1))
1691        tmpR.OrdSgn=-1;
1692    }
1693  }
1694  else if ((k==r1->N) && (k==r2->N)) /* r1 and r2 are "quite" the same ring */
1695    /* copy r1, because we have the variables from r1 */
1696  {
1697    int b=rBlocks(r1);
1698
1699    tmpR.order=(int*)Alloc0(b*sizeof(int));
1700    tmpR.block0=(int*)Alloc0(b*sizeof(int));
1701    tmpR.block1=(int*)Alloc0(b*sizeof(int));
1702    tmpR.wvhdl=(short**)Alloc0(b*sizeof(short*));
1703    for (i=0;i<b;i++)
1704    {
1705      tmpR.order[i]=r1->order[i];
1706      tmpR.block0[i]=r1->block0[i];
1707      tmpR.block1[i]=r1->block1[i];
1708      if (r1->wvhdl[i]!=NULL)
1709      {
1710        int l=mmSizeL(r1->wvhdl[i]);
1711        tmpR.wvhdl[i]=(short *)AllocL(l);
1712        memcpy(tmpR.wvhdl[i],r1->wvhdl[i],l);
1713      }
1714    }
1715    tmpR.OrdSgn=r1->OrdSgn;
1716  }
1717  else
1718  {
1719    for(i=0;i<k;i++) FreeL((ADDRESS)tmpR.names[i]);
1720    Free((ADDRESS)names,tmpR.N*sizeof(char *));
1721    Werror("difficulties with variables: %d,%d -> %d",r1->N,r2->N,k);
1722    return -1;
1723  }
1724  sum=(ring)Alloc(sizeof(ip_sring));
1725  memcpy(sum,&tmpR,sizeof(ip_sring));
1726  rComplete(sum);
1727  return 1;
1728}
1729
1730/*2
1731 * create a copy of the ring r, which must be equivalent to currRing
1732 * used for qring definition,..
1733 * (i.e.: normal rings: same nCopy as currRing;
1734 *        qring:        same nCopy, same idCopy as currRing)
1735 */
1736ring rCopy(ring r)
1737{
1738  if (r == NULL) return NULL;
1739  int i,j;
1740  int *pi;
1741  ring res=(ring)Alloc(sizeof(ip_sring));
1742
1743  memcpy4(res,r,sizeof(ip_sring));
1744  res->ref=0;
1745  if (r->parameter!=NULL)
1746  {
1747    res->minpoly=nCopy(r->minpoly);
1748    int l=rPar(r);
1749    res->parameter=(char **)Alloc(l*sizeof(char *));
1750    int i;
1751    for(i=0;i<rPar(r);i++)
1752    {
1753      res->parameter[i]=mstrdup(r->parameter[i]);
1754    }
1755  }
1756  res->names   = (char **)Alloc(r->N * sizeof(char *));
1757  i=1;
1758  pi=r->order;
1759  while ((*pi)!=0) { i++;pi++; }
1760  res->wvhdl   = (short **)Alloc(i * sizeof(short *));
1761  res->order   = (int *)   Alloc(i * sizeof(int));
1762  res->block0  = (int *)   Alloc(i * sizeof(int));
1763  res->block1  = (int *)   Alloc(i * sizeof(int));
1764  for (j=0; j<i; j++)
1765  {
1766    if (r->wvhdl[j]!=NULL)
1767    {
1768      res->wvhdl[j]=(short*)AllocL(mmSizeL((ADDRESS)r->wvhdl[j]));
1769      memcpy(res->wvhdl[j],r->wvhdl[j],mmSizeL((ADDRESS)r->wvhdl[j]));
1770    }
1771    else
1772      res->wvhdl[j]=NULL;
1773  }
1774  memcpy4(res->order,r->order,i * sizeof(int));
1775  memcpy4(res->block0,r->block0,i * sizeof(int));
1776  memcpy4(res->block1,r->block1,i * sizeof(int));
1777  for (i=0; i<res->N; i++)
1778  {
1779    res->names[i] = mstrdup(r->names[i]);
1780  }
1781  res->idroot = NULL;
1782  if (r->qideal!=NULL) res->qideal= idCopy(r->qideal);
1783  res->VarOffset = (int*) Alloc((r->N + 1)*sizeof(int));
1784  memcpy4(res->VarOffset, r->VarOffset, (r->N + 1)*sizeof(int));
1785
1786#ifdef RDEBUG
1787  rNumber++;
1788  res->no=rNumber;
1789#endif
1790
1791  return res;
1792}
1793
1794rOrderType_t rGetOrderType(ring r)
1795{
1796  // check for simple ordering
1797  if (rHasSimpleOrder(r))
1798  {
1799    if ((r->order[1] == ringorder_c) || (r->order[1] == ringorder_C))
1800    {
1801      switch(r->order[0])
1802      {
1803          case ringorder_dp:
1804          case ringorder_wp:
1805          case ringorder_ds:
1806          case ringorder_ws:
1807          case ringorder_ls:
1808          case ringorder_unspec:
1809            if (r->order[1] == ringorder_C ||  r->order[0] == ringorder_unspec)
1810              return rOrderType_ExpComp;
1811            return rOrderType_Exp;
1812
1813          default:
1814            assume(r->order[0] == ringorder_lp ||
1815                   r->order[0] == ringorder_Dp ||
1816                   r->order[0] == ringorder_Wp ||
1817                   r->order[0] == ringorder_Ds ||
1818                   r->order[0] == ringorder_Ws);
1819
1820            if (r->order[1] == ringorder_c) return rOrderType_ExpComp;
1821            return rOrderType_Exp;
1822      }
1823    }
1824    else
1825    {
1826      assume((r->order[0]==ringorder_c)||(r->order[0]==ringorder_C));
1827      return rOrderType_CompExp;
1828    }
1829  }
1830  else
1831    return rOrderType_General;
1832}
1833
1834BOOLEAN rHasSimpleOrder(ring r)
1835{
1836  return
1837    (r->order[0] == ringorder_unspec) ||
1838    ((r->order[2] == 0) &&
1839     (r->order[1] != ringorder_M &&
1840      r->order[0] != ringorder_M));
1841}
1842
1843// returns TRUE, if simple lp or ls ordering
1844BOOLEAN rHasSimpleLexOrder(ring r)
1845{
1846  return rHasSimpleOrder(r) &&
1847    (r->order[0] == ringorder_ls ||
1848     r->order[0] == ringorder_lp ||
1849     r->order[1] == ringorder_ls ||
1850     r->order[1] == ringorder_lp);
1851}
1852
1853BOOLEAN rIsPolyVar(int v)
1854{
1855  int  i=0;
1856  while(currRing->order[i]!=0)
1857  {
1858    if((currRing->block0[i]<=v)
1859    && (currRing->block1[i]>=v))
1860    {
1861      switch(currRing->order[i])
1862      {
1863        case ringorder_a:
1864          return (currRing->wvhdl[i][v-currRing->block0[i]]>0);
1865        case ringorder_M:
1866          return 2; /*don't know*/
1867        case ringorder_lp:
1868        case ringorder_dp:
1869        case ringorder_Dp:
1870        case ringorder_wp:
1871        case ringorder_Wp:
1872          return TRUE;
1873        case ringorder_ls:
1874        case ringorder_ds:
1875        case ringorder_Ds:
1876        case ringorder_ws:
1877        case ringorder_Ws:
1878          return FALSE;
1879        default:
1880          break;
1881      }
1882    }
1883    i++;
1884  }
1885  return 3; /* could not find var v*/
1886}
1887
1888void rUnComplete(ring r)
1889{
1890  Free((ADDRESS)r->VarOffset,(r->N + 1)*sizeof(int));
1891  r->VarOffset=NULL;
1892}
1893
1894#ifdef RDEBUG
1895// This should eventually become a full-fledge ring check, like pTest
1896BOOLEAN rDBTest(ring r, char* fn, int l)
1897{
1898  if (r == NULL)
1899  {
1900    Werror("Null ring in %s:%l\n", fn, l);
1901    return false;
1902  }
1903
1904  if (r->N == 0) return true;
1905
1906  if (r->VarOffset == NULL)
1907  {
1908    Werror("Null ring VarOffset -- no rComplete (?) in n %s:%d\n", fn, l);
1909    assume(0);
1910    return false;
1911  }
1912
1913  int
1914    VarCompIndex = r->VarCompIndex,
1915    VarLowIndex  = r->VarLowIndex,
1916    VarHighIndex = r->VarHighIndex,
1917    i;
1918  BOOLEAN ok = false;
1919  int* VarOffset = r->VarOffset;
1920
1921  rComplete(r);
1922
1923  if (   VarCompIndex != r->VarCompIndex ||
1924         VarLowIndex  != r->VarLowIndex ||
1925         VarHighIndex != r->VarHighIndex)
1926  {
1927    Werror("Wrong ring VarIndicies -- no rComplete (?) in n %s:%d\n", fn, l);
1928    assume(0);
1929    ok = FALSE;
1930  }
1931
1932  for (i=0; i<=r->N; i++)
1933  {
1934    if (VarOffset[i] != r->VarOffset[i])
1935    {
1936      Werror("Wrong VarOffset value at %d in %s:%d\n", i, fn, l);
1937      assume(0);
1938      ok = FALSE;
1939    }
1940  }
1941  Free(r->VarOffset, (r->N + 1)*sizeof(int));
1942  r->VarOffset = VarOffset;
1943  return ok;
1944}
1945#endif
Note: See TracBrowser for help on using the repository browser.