source: git/Singular/ring.cc @ 63374c

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