source: git/Singular/ring.cc @ 6959c4

spielwiese
Last change on this file since 6959c4 was 6959c4, checked in by Hans Schönemann <hannes@…>, 25 years ago
* hannes: name conflicts parameter, varnames (+ bug fix for "real(..)") git-svn-id: file:///usr/local/Singular/svn/trunk@3256 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 48.1 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ring.cc,v 1.60 1999-07-09 15:27:28 Singular 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  /* check names nad parameters for conflicts ------------------------- */
611  {
612    int i,j;
613    for(i=0;i<R->P; i++)
614    {
615      for(j=0;j<R->N;j++)
616      {
617        if (strcmp(R->parameter[i],R->names[j])==0)
618        {
619          Werror("parameter %d conflicts with variable %d",i+1,j+1);
620          goto rInitError;
621        }
622      }
623    }
624  }
625  /* ordering -------------------------------------------------------------*/
626  if (rSleftvOrdering2Ordering(ord, R))
627    goto rInitError;
628
629  // Complete the initialization
630  if (rComplete(R))
631    goto rInitError;
632
633  // try to enter the ring into the name list //
634  if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
635    goto rInitError;
636
637  memcpy(IDRING(tmp),R,sizeof(*R));
638  // set current ring
639  Free(R,  sizeof(ip_sring));
640#ifdef RDEBUG
641  rNumber++;
642  R->no    =rNumber;
643#endif
644  return tmp;
645
646  // error case:
647  rInitError:
648  if  (R != NULL) rDelete(R);
649  return NULL;
650}
651
652// set those fields of the ring, which can be computed from other fields:
653// More particularly, sets r->VarOffset
654BOOLEAN rComplete(ring r, int force)
655{
656
657  int VarCompIndex, VarLowIndex, VarHighIndex;
658  // check number of vars and number of params
659  if (r->N + 1 > (int) MAX_EXPONENT_NUMBER)
660  {
661    Werror("Too many ring variables: %d is the maximum",
662           MAX_EXPONENT_NUMBER -1);
663    return TRUE;
664  }
665
666
667  r->VarOffset = (int*) Alloc((r->N + 1)*sizeof(int));
668  pGetVarIndicies(r, r->VarOffset, VarCompIndex,
669                  VarLowIndex, VarHighIndex);
670  r->VarCompIndex = VarCompIndex;
671  r->VarLowIndex = VarLowIndex;
672  r->VarHighIndex = VarHighIndex;
673  return FALSE;
674}
675
676/*2
677 * set a new ring from the data:
678 s: name, chr: ch, varnames: rv, ordering: ord, typ: typ
679 */
680#ifdef DRING
681void rDSet()
682{
683  pDRING=TRUE;
684  pSDRING=TRUE;
685  pdN=currRing->partN;
686  pdK=pVariables-pdN*2-1;
687}
688#endif
689
690int rIsRingVar(char *n)
691{
692  if ((currRing!=NULL) && (currRing->names!=NULL))
693  {
694    for (int i=0; i<currRing->N; i++)
695    {
696      if (currRing->names[i]==NULL) return -1;
697      if (strcmp(n,currRing->names[i]) == 0) return (int)i;
698    }
699  }
700  return -1;
701}
702
703char* RingVar(short i)
704{
705  return currRing->names[i];
706}
707
708void rWrite(ring r)
709{
710  if ((r==NULL)||(r->order==NULL))
711    return; /*to avoid printing after errors....*/
712
713  int nblocks=rBlocks(r);
714
715  mmTestP(r,sizeof(ip_sring));
716  mmTestP(r->order,nblocks*sizeof(int));
717  mmTestP(r->block0,nblocks*sizeof(int));
718  mmTestP(r->block1,nblocks*sizeof(int));
719  mmTestP(r->wvhdl,nblocks*sizeof(short *));
720  mmTestP(r->names,r->N*sizeof(char *));
721
722  nblocks--;
723
724
725  if (rField_is_GF(r))
726  {
727    Print("//   # ground field : %d\n",rInternalChar(r));
728    Print("//   primitive element : %s\n", r->parameter[0]);
729    if (r==currRing)
730    {
731      StringSetS("//   minpoly        : ");
732      nfShowMipo();PrintS(StringAppendS("\n"));
733    }
734  }
735  else
736  {
737    PrintS("//   characteristic : ");
738    if ( rField_is_R(r) )             PrintS("0 (real)\n");  /* R */
739    else if ( rField_is_long_R(r) )
740      Print("0 (real:%d digits)\n",r->ch_flags);  /* long R */
741    else if ( rField_is_long_C(r) )
742      Print("0 (complex:%d digits)\n",r->ch_flags);  /* long C */
743    else
744      Print ("%d\n",rChar(r)); /* Fp(a) */
745    if (r->parameter!=NULL)
746    {
747      Print ("//   %d parameter    : ",rPar(r));
748      char **sp=r->parameter;
749      int nop=0;
750      while (nop<rPar(r))
751      {
752        PrintS(*sp);
753        PrintS(" ");
754        sp++; nop++;
755      }
756      PrintS("\n//   minpoly        : ");
757      if ( rField_is_long_C(r) )
758      {
759        // i^2+1:
760        Print("(%s^2+1)\n",r->parameter[0]);
761      }
762      else if (r->minpoly==NULL)
763      {
764        PrintS("0\n");
765      }
766      else if (r==currRing)
767      {
768        StringSetS(""); nWrite(r->minpoly); PrintS(StringAppendS("\n"));
769      }
770      else
771      {
772        PrintS("...\n");
773      }
774    }
775  }
776  Print("//   number of vars : %d",r->N);
777
778  //for (nblocks=0; r->order[nblocks]; nblocks++);
779  nblocks=rBlocks(r)-1;
780
781  for (int l=0, nlen=0 ; l<nblocks; l++)
782  {
783    int i;
784    Print("\n//        block %3d : ",l+1);
785
786    Print("ordering %c", (" acCMldDwWldDwWu")[r->order[l]]);
787    if ((r->order[l]>=ringorder_lp)&&(r->order[l]!=ringorder_unspec))
788    {
789      if (r->order[l]>=ringorder_ls)
790        PrintS("s");
791      else
792        PrintS("p");
793    }
794
795    if ((r->order[l] != ringorder_c) && (r->order[l] != ringorder_C))
796    {
797      PrintS("\n//                  : names    ");
798      for (i = r->block0[l]-1; i<r->block1[l]; i++)
799      {
800        nlen = strlen(r->names[i]);
801        Print("%s ",r->names[i]);
802      }
803    }
804
805    if (r->wvhdl[l]!=NULL)
806    {
807      for (int j= 0;
808           j<(r->block1[l]-r->block0[l]+1)*(r->block1[l]-r->block0[l]+1);
809           j+=i)
810      {
811        PrintS("\n//                  : weights  ");
812        for (i = 0; i<=r->block1[l]-r->block0[l]; i++)
813        {
814          Print("%*d " ,nlen,r->wvhdl[l][i+j],i+j);
815        }
816        if (r->order[l]!=ringorder_M) break;
817      }
818    }
819  }
820  if (r->qideal!=NULL)
821  {
822    PrintS("\n// quotient ring from ideal");
823    if (r==currRing)
824    {
825      PrintLn();
826      iiWriteMatrix((matrix)r->qideal,"_",1);
827    }
828    else PrintS(" ...");
829  }
830}
831
832static void rDelete(ring r)
833{
834  int i, j;
835
836  if (r == NULL) return;
837
838  // delete order stuff
839  if (r->order != NULL)
840  {
841    i=rBlocks(r);
842    assume(r->block0 != NULL && r->block1 != NULL && r->wvhdl != NULL);
843    // delete order
844    Free((ADDRESS)r->order,i*sizeof(int));
845    Free((ADDRESS)r->block0,i*sizeof(int));
846    Free((ADDRESS)r->block1,i*sizeof(int));
847    // delete weights
848    for (j=0; j<i; j++)
849    {
850      if (r->wvhdl[j]!=NULL)
851        FreeL(r->wvhdl[j]);
852    }
853    Free((ADDRESS)r->wvhdl,i*sizeof(short *));
854  }
855  else
856  {
857    assume(r->block0 == NULL && r->block1 == NULL && r->wvhdl == NULL);
858  }
859
860  // delete varnames
861  if(r->names!=NULL)
862  {
863    for (i=0; i<r->N; i++)
864    {
865      if (r->names[i] != NULL) FreeL((ADDRESS)r->names[i]);
866    }
867    Free((ADDRESS)r->names,r->N*sizeof(char *));
868  }
869
870  // delete parameter
871  if (r->parameter!=NULL)
872  {
873    char **s=r->parameter;
874    j = 0;
875    while (j < rPar(r))
876    {
877      if (*s != NULL) FreeL((ADDRESS)*s);
878      s++;
879      j++;
880    }
881    Free((ADDRESS)r->parameter,rPar(r)*sizeof(char *));
882  }
883  if (r->VarOffset != NULL)
884    Free((ADDRESS)r->VarOffset, (r->N +1)*sizeof(int));
885  Free(r, sizeof(ip_sring));
886}
887
888void rKill(ring r)
889{
890  rTest(r);
891  if ((r->ref<=0)&&(r->order!=NULL))
892  {
893#ifdef RDEBUG
894    if (traceit &TRACE_SHOW_RINGS) Print("kill ring %d\n",r->no);
895#endif
896    if (r==currRing)
897    {
898      if (r->qideal!=NULL)
899      {
900        idDelete(&r->qideal);
901        r->qideal=NULL;
902        currQuotient=NULL;
903      }
904      if (ppNoether!=NULL) pDelete(&ppNoether);
905      if ((sLastPrinted.rtyp>BEGIN_RING) && (sLastPrinted.rtyp<END_RING))
906      {
907        sLastPrinted.CleanUp();
908        memset(&sLastPrinted,0,sizeof(sleftv));
909      }
910      currRing=NULL;
911      currRingHdl=NULL;
912    }
913    else if (r->qideal!=NULL)
914    {
915      ring savecurrRing = currRing;
916      rChangeCurrRing((ring)r,FALSE);
917      idDelete(&r->qideal);
918      r->qideal=NULL;
919      rChangeCurrRing(savecurrRing,FALSE);
920    }
921    int i=1;
922    int j;
923    int *pi=r->order;
924#ifdef USE_IILOCALRING
925    for (j=0;j<iiRETURNEXPR_len;j++)
926    {
927      if (iiLocalRing[j]==r)
928      {
929        if (j<myynest) Warn("killing the basering for level %d",j);
930        iiLocalRing[j]=NULL;
931      }
932    }
933#else /* USE_IILOCALRING */
934    {
935      namehdl nshdl = namespaceroot;
936
937      for(nshdl=namespaceroot; nshdl->isroot != TRUE; nshdl = nshdl->next) {
938        //Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
939        if (nshdl->currRing==r)
940        {
941          if (nshdl->myynest<myynest)
942//            Warn("killing the basering for level %d/%d",nshdl->lev,nshdl->myynest);
943          Warn("killing the basering for level %d",nshdl->myynest);
944          nshdl->currRing=NULL;
945        }
946      }
947      if (nshdl->currRing==r)
948      {
949        //Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
950        if (nshdl->myynest<myynest)
951//          Warn("killing the basering for level %d/%d",nshdl->lev,nshdl->myynest);
952          Warn("killing the basering for level %d",nshdl->myynest);
953        nshdl->currRing=NULL;
954      }
955    }
956#endif /* USE_IILOCALRING */
957
958    rDelete(r);
959    return;
960  }
961  r->ref--;
962}
963
964void rKill(idhdl h)
965{
966#ifndef HAVE_NAMESPACES1
967  ring r = IDRING(h);
968  if (r!=NULL) rKill(r);
969  if (h==currRingHdl)
970  {
971#ifdef HAVE_NAMESPACES
972    namehdl nsHdl = namespaceroot;
973    while(nsHdl!=NULL) {
974      currRingHdl=NSROOT(nsHdl);
975#else /* HAVE_NAMESPACES */
976      currRingHdl=IDROOT;
977#endif /* HAVE_NAMESPACES */
978      while (currRingHdl!=NULL)
979      {
980        if ((currRingHdl!=h)
981            && (IDTYP(currRingHdl)==IDTYP(h))
982            && (h->data.uring==currRingHdl->data.uring))
983          break;
984        currRingHdl=IDNEXT(currRingHdl);
985      }
986#ifdef HAVE_NAMESPACES
987      if ((currRingHdl != NULL) && (currRingHdl!=h)
988          && (IDTYP(currRingHdl)==IDTYP(h))
989          && (h->data.uring==currRingHdl->data.uring))
990        break;
991      nsHdl = nsHdl->next;
992    }
993#endif /* HAVE_NAMESPACES */
994  }
995#else
996    if(currRingHdl==NULL) {
997      namehdl ns = namespaceroot;
998      BOOLEAN found=FALSE;
999
1000      while(!ns->isroot) {
1001        currRingHdl=NSROOT(namespaceroot->next);
1002        while (currRingHdl!=NULL)
1003        {
1004          if ((currRingHdl!=h)
1005              && (IDTYP(currRingHdl)==IDTYP(h))
1006              && (h->data.uring==currRingHdl->data.uring))
1007          { found=TRUE; break; }
1008
1009          currRingHdl=IDNEXT(currRingHdl);
1010        }
1011        if(found) break;
1012        ns=IDNEXT(ns);
1013      }
1014    }
1015    if(currRingHdl == NULL || IDRING(h) != IDRING(currRingHdl)) {
1016      currRingHdl = namespaceroot->currRingHdl;
1017
1018/*      PrintS("Running rFind()\n");
1019      currRingHdl = rFindHdl(IDRING(h), NULL, NULL);
1020      if(currRingHdl == NULL)
1021      {
1022        PrintS("rFind()return 0\n");
1023      }
1024      else
1025      {
1026        PrintS("Huppi rfind return an currRingHDL\n");
1027        Print("%x, %x\n", IDRING(h),IDRING(currRingHdl) );
1028      }
1029*/
1030    }
1031    else
1032    {
1033      //PrintS("Huppi found an currRingHDL\n");
1034      //Print("%x, %x\n", IDRING(h),IDRING(currRingHdl) );
1035
1036    }
1037#endif /* HAVE_NAMESPACES */
1038}
1039
1040idhdl rFindHdl(ring r, idhdl n, idhdl w)
1041{
1042#ifdef HAVE_NAMESPACES
1043  idhdl h;
1044  namehdl ns = namespaceroot;
1045
1046  while(!ns->isroot) {
1047    h = NSROOT(ns);
1048    if(w != NULL) h = w;
1049    while (h!=NULL)
1050    {
1051      if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1052          && (h->data.uring==r)
1053          && (h!=n))
1054        return h;
1055      h=IDNEXT(h);
1056    }
1057    ns = ns->next;
1058  }
1059  h = NSROOT(ns);
1060  if(w != NULL) h = w;
1061  while (h!=NULL)
1062  {
1063    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1064        && (h->data.uring==r)
1065        && (h!=n))
1066      return h;
1067    h=IDNEXT(h);
1068  }
1069#if 0
1070  if(namespaceroot->isroot) h = IDROOT;
1071  else h = NSROOT(namespaceroot->next);
1072  if(w != NULL) h = w;
1073  while (h!=NULL)
1074  {
1075    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1076        && (h->data.uring==r)
1077        && (h!=n))
1078      return h;
1079    h=IDNEXT(h);
1080  }
1081#endif
1082#else
1083  idhdl h=IDROOT;
1084  if(w != NULL) h = w;
1085  while (h!=NULL)
1086  {
1087    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1088        && (h->data.uring==r)
1089        && (h!=n))
1090      return h;
1091    h=IDNEXT(h);
1092  }
1093#endif
1094  return NULL;
1095}
1096
1097int rOrderName(char * ordername)
1098{
1099  int order=0;
1100
1101  switch (*ordername)
1102  {
1103  case 'l':
1104    if (*(ordername+1)=='p') order = ringorder_lp;
1105    else if (*(ordername+1)=='s') order = ringorder_ls;
1106    break;
1107  case 'd':
1108    if (*(ordername+1)=='p') order = ringorder_dp;
1109    else if (*(ordername+1)=='s') order = ringorder_ds;
1110    break;
1111  case 'w':
1112    if (*(ordername+1)=='p') order = ringorder_wp;
1113    else if (*(ordername+1)=='s') order = ringorder_ws;
1114    break;
1115  case 'D':
1116    if (*(ordername+1)=='p') order = ringorder_Dp;
1117    else if (*(ordername+1)=='s') order = ringorder_Ds;
1118    break;
1119  case 'W':
1120    if (*(ordername+1)=='p') order = ringorder_Wp;
1121    else if (*(ordername+1)=='s') order = ringorder_Ws;
1122    break;
1123  case 'c': order = ringorder_c; break;
1124  case 'C': order = ringorder_C; break;
1125  case 'a': order = ringorder_a; break;
1126  case 'M': order = ringorder_M; break;
1127  default: break;
1128  }
1129  if (order==0) Werror("wrong ring order `%s`",ordername);
1130  FreeL((ADDRESS)ordername);
1131  return order;
1132}
1133
1134char * rOrdStr(ring r)
1135{
1136  int nblocks,l,i;
1137
1138  for (nblocks=0; r->order[nblocks]; nblocks++);
1139  nblocks--;
1140
1141  StringSetS("");
1142  for (l=0; ; l++)
1143  {
1144    StringAppend("%c",(" acCMldDwWldDwW")[r->order[l]]);
1145    if (r->order[l]>=ringorder_lp)
1146    {
1147      if (r->order[l]>=ringorder_ls)
1148        StringAppendS("s");
1149      else
1150        StringAppendS("p");
1151    }
1152    if ((r->order[l] != ringorder_c) && (r->order[l] != ringorder_C))
1153    {
1154      if (r->wvhdl[l]!=NULL)
1155      {
1156        StringAppendS("(");
1157        for (int j= 0;
1158             j<(r->block1[l]-r->block0[l]+1)*(r->block1[l]-r->block0[l]+1);
1159             j+=i+1)
1160        {
1161          char c=',';
1162          for (i = 0; i<r->block1[l]-r->block0[l]; i++)
1163          {
1164            StringAppend("%d," ,r->wvhdl[l][i+j]);
1165          }
1166          if (r->order[l]!=ringorder_M)
1167          {
1168            StringAppend("%d)" ,r->wvhdl[l][i+j]);
1169            break;
1170          }
1171          if (j+i+1==(r->block1[l]-r->block0[l]+1)*(r->block1[l]-r->block0[l]+1))
1172            c=')';
1173          StringAppend("%d%c" ,r->wvhdl[l][i+j],c);
1174        }
1175      }
1176      else
1177        StringAppend("(%d)",r->block1[l]-r->block0[l]+1);
1178    }
1179    if (l==nblocks) return mstrdup(StringAppendS(""));
1180    StringAppendS(",");
1181  }
1182}
1183
1184char * rVarStr(ring r)
1185{
1186  int i;
1187  int l=2;
1188  char *s;
1189
1190  for (i=0; i<r->N; i++)
1191  {
1192    l+=strlen(r->names[i])+1;
1193  }
1194  s=(char *)AllocL(l);
1195  s[0]='\0';
1196  for (i=0; i<r->N-1; i++)
1197  {
1198    strcat(s,r->names[i]);
1199    strcat(s,",");
1200  }
1201  strcat(s,r->names[i]);
1202  return s;
1203}
1204
1205char * rCharStr(ring r)
1206{
1207  char *s;
1208  int i;
1209
1210  if (r->parameter==NULL)
1211  {
1212    i=r->ch;
1213    if(i==-1)
1214      s=mstrdup("real");                    /* R */
1215    else
1216    {
1217      s=(char *)AllocL(6);
1218      sprintf(s,"%d",i);                   /* Q, Z/p */
1219    }
1220    return s;
1221  }
1222  int l=0;
1223  for(i=0; i<rPar(r);i++)
1224  {
1225    l+=(strlen(r->parameter[i])+1);
1226  }
1227  s=(char *)AllocL(l+6);
1228  s[0]='\0';
1229  if (r->ch<0)       sprintf(s,"%d",-r->ch); /* Fp(a) */
1230  else if (r->ch==1) sprintf(s,"0");         /* Q(a)  */
1231  else
1232  {
1233    sprintf(s,"%d,%s",r->ch,r->parameter[0]); /* Fq  */
1234    return s;
1235  }
1236  char tt[2];
1237  tt[0]=',';
1238  tt[1]='\0';
1239  for(i=0; i<rPar(r);i++)
1240  {
1241    strcat(s,tt);
1242    strcat(s,r->parameter[i]);
1243  }
1244  return s;
1245}
1246
1247char * rParStr(ring r)
1248{
1249  if (r->parameter==NULL) return mstrdup("");
1250
1251  int i;
1252  int l=2;
1253
1254  for (i=0; i<rPar(r); i++)
1255  {
1256    l+=strlen(r->parameter[i])+1;
1257  }
1258  char *s=(char *)AllocL(l);
1259  s[0]='\0';
1260  for (i=0; i<rPar(r)-1; i++)
1261  {
1262    strcat(s,r->parameter[i]);
1263    strcat(s,",");
1264  }
1265  strcat(s,r->parameter[i]);
1266  return s;
1267}
1268
1269char * rString(ring r)
1270{
1271  char *ch=rCharStr(r);
1272  char *var=rVarStr(r);
1273  char *ord=rOrdStr(r);
1274  char *res=(char *)AllocL(strlen(ch)+strlen(var)+strlen(ord)+9);
1275  sprintf(res,"(%s),(%s),(%s)",ch,var,ord);
1276  FreeL((ADDRESS)ch);
1277  FreeL((ADDRESS)var);
1278  FreeL((ADDRESS)ord);
1279  return res;
1280}
1281
1282int rChar(ring r)
1283{
1284  if (r->ch==-1)
1285    return 0;
1286  if (r->parameter==NULL) /* Q, Fp */
1287    return r->ch;
1288  if (r->ch<0)           /* Fp(a)  */
1289    return -r->ch;
1290  if (r->ch==1)          /* Q(a)  */
1291    return 0;
1292  /*else*/               /* GF(p,n) */
1293  {
1294    if ((r->ch & 1)==0) return 2;
1295    int i=3;
1296    while ((r->ch % i)!=0) i+=2;
1297    return i;
1298  }
1299}
1300
1301int    rIsExtension(ring r)
1302{
1303  if (r->parameter==NULL) /* Q, Fp */
1304    return FALSE;
1305  else
1306    return TRUE;
1307}
1308
1309int    rIsExtension()
1310{
1311  return rIsExtension( currRing );
1312}
1313
1314/*2
1315 *returns -1 for not compatible, (sum is undefined)
1316 *         0 for equal, (and sum)
1317 *         1 for compatible (and sum)
1318 */
1319int rSum(ring r1, ring r2, ring &sum)
1320{
1321  if (r1==r2)
1322  {
1323    sum=r1;
1324    r1->ref++;
1325    return 0;
1326  }
1327  ip_sring tmpR;
1328  memset(&tmpR,0,sizeof(tmpR));
1329  /* check coeff. field =====================================================*/
1330  if (rInternalChar(r1)==rInternalChar(r2))
1331  {
1332    tmpR.ch=rInternalChar(r1);
1333    if (rField_is_Q(r1)||rField_is_Zp(r1)||rField_is_GF(r1)) /*Q, Z/p, GF(p,n)*/
1334    {
1335      if (r1->parameter!=NULL)
1336      {
1337        if (strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1338        {
1339          tmpR.parameter=(char **)Alloc(sizeof(char *));
1340          tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1341          tmpR.P=1;
1342        }
1343        else
1344        {
1345          WerrorS("GF(p,n)+GF(p,n)");
1346          return -1;
1347        }
1348      }
1349    }
1350    else if ((r1->ch==1)||(r1->ch<-1)) /* Q(a),Z/p(a) */
1351    {
1352      if (r1->minpoly!=NULL)
1353      {
1354        if (r2->minpoly!=NULL)
1355        {
1356          nSetChar(r1,TRUE);
1357          if ((strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1358              && naEqual(r1->minpoly,r2->minpoly))
1359          {
1360            tmpR.parameter=(char **)Alloc(sizeof(char *));
1361            tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1362            tmpR.minpoly=naCopy(r1->minpoly);
1363            tmpR.P=1;
1364            nSetChar(currRing,TRUE);
1365          }
1366          else
1367          {
1368            nSetChar(currRing,TRUE);
1369            WerrorS("different minpolys");
1370            return -1;
1371          }
1372        }
1373        else
1374        {
1375          if ((strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1376              && (rPar(r2)==1))
1377          {
1378            tmpR.parameter=(char **)Alloc0(sizeof(char *));
1379            tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1380            tmpR.P=1;
1381            nSetChar(r1,TRUE);
1382            tmpR.minpoly=naCopy(r1->minpoly);
1383            nSetChar(currRing,TRUE);
1384          }
1385          else
1386          {
1387            WerrorS("different parameters and minpoly!=0");
1388            return -1;
1389          }
1390        }
1391      }
1392      else /* r1->minpoly==NULL */
1393      {
1394        if (r2->minpoly!=NULL)
1395        {
1396          if ((strcmp(r1->parameter[0],r2->parameter[0])==0) /* 1 char */
1397              && (rPar(r1)==1))
1398          {
1399            tmpR.parameter=(char **)Alloc(sizeof(char *));
1400            tmpR.parameter[0]=mstrdup(r1->parameter[0]);
1401            tmpR.P=1;
1402            nSetChar(r2,TRUE);
1403            tmpR.minpoly=naCopy(r2->minpoly);
1404            nSetChar(currRing,TRUE);
1405          }
1406          else
1407          {
1408            WerrorS("different parameters and minpoly!=0");
1409            return -1;
1410          }
1411        }
1412        else
1413        {
1414          int len=rPar(r1)+rPar(r2);
1415          tmpR.parameter=(char **)Alloc(len*sizeof(char *));
1416          int i;
1417          for (i=0;i<rPar(r1);i++)
1418          {
1419            tmpR.parameter[i]=mstrdup(r1->parameter[i]);
1420          }
1421          int j,l;
1422          for(j=0;j<rPar(r2);j++)
1423          {
1424            for(l=0;l<i;l++)
1425            {
1426              if(strcmp(tmpR.parameter[l],r2->parameter[j])==0)
1427                break;
1428            }
1429            if (l==i)
1430            {
1431              tmpR.parameter[i]=mstrdup(r2->parameter[j]);
1432              i++;
1433            }
1434          }
1435          if (i!=len)
1436          {
1437            ReAlloc(tmpR.parameter,len*sizeof(char *),i*sizeof(char *));
1438          }
1439        }
1440      }
1441    }
1442  }
1443  else /* r1->ch!=r2->ch */
1444  {
1445    if (r1->ch<-1) /* Z/p(a) */
1446    {
1447      if ((r2->ch==0) /* Q */
1448          || (r2->ch==-r1->ch)) /* Z/p */
1449      {
1450        tmpR.ch=rInternalChar(r1);
1451        tmpR.parameter=(char **)Alloc(rPar(r1)*sizeof(char *));
1452        tmpR.P=rPar(r1);
1453        memcpy(tmpR.parameter,r1->parameter,rPar(r1)*sizeof(char *));
1454        if (r1->minpoly!=NULL)
1455        {
1456          nSetChar(r1,TRUE);
1457          tmpR.minpoly=naCopy(r1->minpoly);
1458          nSetChar(currRing,TRUE);
1459        }
1460      }
1461      else  /* R, Q(a),Z/q,Z/p(a),GF(p,n) */
1462      {
1463        WerrorS("Z/p(a)+(R,Q(a),Z/q(a),GF(q,n))");
1464        return -1;
1465      }
1466    }
1467    else if (r1->ch==-1) /* R */
1468    {
1469      WerrorS("R+..");
1470      return -1;
1471    }
1472    else if (r1->ch==0) /* Q */
1473    {
1474      if ((r2->ch<-1)||(r2->ch==1)) /* Z/p(a),Q(a) */
1475      {
1476        tmpR.ch=rInternalChar(r2);
1477        tmpR.P=rPar(r2);
1478        tmpR.parameter=(char **)Alloc(rPar(r2)*sizeof(char *));
1479        memcpy(tmpR.parameter,r2->parameter,rPar(r2)*sizeof(char *));
1480        if (r2->minpoly!=NULL)
1481        {
1482          nSetChar(r1,TRUE);
1483          tmpR.minpoly=naCopy(r2->minpoly);
1484          nSetChar(currRing,TRUE);
1485        }
1486      }
1487      else if (r2->ch>1) /* Z/p,GF(p,n) */
1488      {
1489        tmpR.ch=r2->ch;
1490        if (r2->parameter!=NULL)
1491        {
1492          tmpR.parameter=(char **)Alloc(sizeof(char *));
1493          tmpR.P=1;
1494          tmpR.parameter[0]=mstrdup(r2->parameter[0]);
1495        }
1496      }
1497      else
1498      {
1499        WerrorS("Q+R");
1500        return -1; /* R */
1501      }
1502    }
1503    else if (r1->ch==1) /* Q(a) */
1504    {
1505      if (r2->ch==0) /* Q */
1506      {
1507        tmpR.ch=rInternalChar(r1);
1508        tmpR.P=rPar(r1);
1509        tmpR.parameter=(char **)Alloc0(rPar(r1)*sizeof(char *));
1510        int i;
1511        for(i=0;i<rPar(r1);i++)
1512        {
1513          tmpR.parameter[i]=mstrdup(r1->parameter[i]);
1514        }
1515        if (r1->minpoly!=NULL)
1516        {
1517          nSetChar(r1,TRUE);
1518          tmpR.minpoly=naCopy(r1->minpoly);
1519          nSetChar(currRing,TRUE);
1520        }
1521      }
1522      else  /* R, Z/p,GF(p,n) */
1523      {
1524        WerrorS("Q(a)+(R,Z/p,GF(p,n))");
1525        return -1;
1526      }
1527    }
1528    else /* r1->ch >=2 , Z/p */
1529    {
1530      if (r2->ch==0) /* Q */
1531      {
1532        tmpR.ch=r1->ch;
1533      }
1534      else if (r2->ch==-r1->ch) /* Z/p(a) */
1535      {
1536        tmpR.ch=rInternalChar(r2);
1537        tmpR.P=rPar(r2);
1538        tmpR.parameter=(char **)Alloc(rPar(r2)*sizeof(char *));
1539        int i;
1540        for(i=0;i<rPar(r2);i++)
1541        {
1542          tmpR.parameter[i]=mstrdup(r2->parameter[i]);
1543        }
1544        if (r2->minpoly!=NULL)
1545        {
1546          nSetChar(r2,TRUE);
1547          tmpR.minpoly=naCopy(r2->minpoly);
1548          nSetChar(currRing,TRUE);
1549        }
1550      }
1551      else
1552      {
1553        WerrorS("Z/p+(GF(q,n),Z/q(a),R,Q(a))");
1554        return -1; /* GF(p,n),Z/q(a),R,Q(a) */
1555      }
1556    }
1557  }
1558  /* variable names ========================================================*/
1559  int i,j,k;
1560  int l=r1->N+r2->N;
1561  char **names=(char **)Alloc0(l*sizeof(char*));
1562  k=0;
1563
1564  // collect all varnames from r1, except those which are parameters
1565  // of r2, or those which are the empty string
1566  for (i=0;i<r1->N;i++)
1567  {
1568    BOOLEAN b=TRUE;
1569
1570    if (*(r1->names[i]) == '\0')
1571      b = FALSE;
1572    else if ((r2->parameter!=NULL) && (strlen(r1->names[i])==1))
1573    {
1574      for(j=0;j<rPar(r2);j++)
1575      {
1576        if (strcmp(r1->names[i],r2->parameter[j])==0)
1577        {
1578          b=FALSE;
1579          break;
1580        }
1581      }
1582    }
1583
1584    if (b)
1585    {
1586      //Print("name : %d: %s\n",k,r1->names[i]);
1587      names[k]=mstrdup(r1->names[i]);
1588      k++;
1589    }
1590    //else
1591    //  Print("no name (par1) %s\n",r1->names[i]);
1592  }
1593  // Add variables from r2, except those which are parameters of r1
1594  // those which are empty strings, and those which equal a var of r1
1595  for(i=0;i<r2->N;i++)
1596  {
1597    BOOLEAN b=TRUE;
1598
1599    if (*(r2->names[i]) == '\0')
1600      b = FALSE;
1601    else if ((r1->parameter!=NULL) && (strlen(r2->names[i])==1))
1602    {
1603      for(j=0;j<rPar(r1);j++)
1604      {
1605        if (strcmp(r2->names[i],r1->parameter[j])==0)
1606        {
1607          b=FALSE;
1608          break;
1609        }
1610      }
1611    }
1612
1613    if (b)
1614    {
1615      for(j=0;j<r1->N;j++)
1616      {
1617        if (strcmp(r1->names[j],r2->names[i])==0)
1618        {
1619          b=FALSE;
1620          break;
1621        }
1622      }
1623      if (b)
1624      {
1625        names[k]=mstrdup(r2->names[i]);
1626        //Print("name : %d : %s\n",k,r2->names[i]);
1627        k++;
1628      }
1629      //else
1630      //  Print("no name (var): %s\n",r2->names[i]);
1631    }
1632    //else
1633    //  Print("no name (par): %s\n",r2->names[i]);
1634  }
1635  // check whether we found any vars at all
1636  if (k == 0)
1637  {
1638    names[k]=mstrdup("");
1639    k=1;
1640  }
1641  tmpR.N=k;
1642  tmpR.names=names;
1643  /* ordering *======================================================== */
1644  tmpR.OrdSgn=1;
1645  if ((r1->order[0]==ringorder_unspec)
1646      && (r2->order[0]==ringorder_unspec))
1647  {
1648    tmpR.order=(int*)Alloc(3*sizeof(int));
1649    tmpR.block0=(int*)Alloc(3*sizeof(int));
1650    tmpR.block1=(int*)Alloc(3*sizeof(int));
1651    tmpR.wvhdl=(short**)Alloc0(3*sizeof(short*));
1652    tmpR.order[0]=ringorder_unspec;
1653    tmpR.order[1]=ringorder_C;
1654    tmpR.order[2]=0;
1655    tmpR.block0[0]=1;
1656    tmpR.block1[0]=tmpR.N;
1657  }
1658  else if (l==k) /* r3=r1+r2 */
1659  {
1660    int b;
1661    ring rb;
1662    if (r1->order[0]==ringorder_unspec)
1663    {
1664      /* extend order of r2 to r3 */
1665      b=rBlocks(r2);
1666      rb=r2;
1667      tmpR.OrdSgn=r2->OrdSgn;
1668    }
1669    else if (r2->order[0]==ringorder_unspec)
1670    {
1671      /* extend order of r1 to r3 */
1672      b=rBlocks(r1);
1673      rb=r1;
1674      tmpR.OrdSgn=r1->OrdSgn;
1675    }
1676    else
1677    {
1678      b=rBlocks(r1)+rBlocks(r2)-2; /* for only one order C, only one 0 */
1679      rb=NULL;
1680    }
1681    tmpR.order=(int*)Alloc0(b*sizeof(int));
1682    tmpR.block0=(int*)Alloc0(b*sizeof(int));
1683    tmpR.block1=(int*)Alloc0(b*sizeof(int));
1684    tmpR.wvhdl=(short**)Alloc0(b*sizeof(short*));
1685    if (rb!=NULL)
1686    {
1687      for (i=0;i<b;i++)
1688      {
1689        tmpR.order[i]=rb->order[i];
1690        tmpR.block0[i]=rb->block0[i];
1691        tmpR.block1[i]=rb->block1[i];
1692        if (rb->wvhdl[i]!=NULL)
1693          WarnS("rSum: weights not implemented");
1694      }
1695      tmpR.block0[0]=1;
1696    }
1697    else /* ring sum for complete rings */
1698    {
1699      for (i=0;r1->order[i]!=0;i++)
1700      {
1701        tmpR.order[i]=r1->order[i];
1702        tmpR.block0[i]=r1->block0[i];
1703        tmpR.block1[i]=r1->block1[i];
1704        if (r1->wvhdl[i]!=NULL)
1705        {
1706          int l=mmSizeL(r1->wvhdl[i]);
1707          tmpR.wvhdl[i]=(short *)AllocL(l);
1708          memcpy(tmpR.wvhdl[i],r1->wvhdl[i],l);
1709        }
1710      }
1711      j=i;
1712      i--;
1713      if ((r1->order[i]==ringorder_c)
1714          ||(r1->order[i]==ringorder_C))
1715      {
1716        j--;
1717        tmpR.order[b-2]=r1->order[i];
1718      }
1719      for (i=0;r2->order[i]!=0;i++,j++)
1720      {
1721        if ((r2->order[i]!=ringorder_c)
1722            &&(r2->order[i]!=ringorder_C))
1723        {
1724          tmpR.order[j]=r2->order[i];
1725          tmpR.block0[j]=r2->block0[i]+r1->N;
1726          tmpR.block1[j]=r2->block1[i]+r1->N;
1727          if (r2->wvhdl[i]!=NULL)
1728          {
1729            int l=mmSizeL(r2->wvhdl[i]);
1730            tmpR.wvhdl[j]=(short *)AllocL(l);
1731            memcpy(tmpR.wvhdl[j],r2->wvhdl[i],l);
1732          }
1733        }
1734      }
1735      if((r1->OrdSgn==-1)||(r2->OrdSgn==-1))
1736        tmpR.OrdSgn=-1;
1737    }
1738  }
1739  else if ((k==r1->N) && (k==r2->N)) /* r1 and r2 are "quite" the same ring */
1740    /* copy r1, because we have the variables from r1 */
1741  {
1742    int b=rBlocks(r1);
1743
1744    tmpR.order=(int*)Alloc0(b*sizeof(int));
1745    tmpR.block0=(int*)Alloc0(b*sizeof(int));
1746    tmpR.block1=(int*)Alloc0(b*sizeof(int));
1747    tmpR.wvhdl=(short**)Alloc0(b*sizeof(short*));
1748    for (i=0;i<b;i++)
1749    {
1750      tmpR.order[i]=r1->order[i];
1751      tmpR.block0[i]=r1->block0[i];
1752      tmpR.block1[i]=r1->block1[i];
1753      if (r1->wvhdl[i]!=NULL)
1754      {
1755        int l=mmSizeL(r1->wvhdl[i]);
1756        tmpR.wvhdl[i]=(short *)AllocL(l);
1757        memcpy(tmpR.wvhdl[i],r1->wvhdl[i],l);
1758      }
1759    }
1760    tmpR.OrdSgn=r1->OrdSgn;
1761  }
1762  else
1763  {
1764    for(i=0;i<k;i++) FreeL((ADDRESS)tmpR.names[i]);
1765    Free((ADDRESS)names,tmpR.N*sizeof(char *));
1766    Werror("difficulties with variables: %d,%d -> %d",r1->N,r2->N,k);
1767    return -1;
1768  }
1769  sum=(ring)Alloc(sizeof(ip_sring));
1770  memcpy(sum,&tmpR,sizeof(ip_sring));
1771  rComplete(sum);
1772  return 1;
1773}
1774
1775/*2
1776 * create a copy of the ring r, which must be equivalent to currRing
1777 * used for qring definition,..
1778 * (i.e.: normal rings: same nCopy as currRing;
1779 *        qring:        same nCopy, same idCopy as currRing)
1780 */
1781ring rCopy(ring r)
1782{
1783  if (r == NULL) return NULL;
1784  int i,j;
1785  int *pi;
1786  ring res=(ring)Alloc(sizeof(ip_sring));
1787
1788  memcpy4(res,r,sizeof(ip_sring));
1789  res->ref=0;
1790  if (r->parameter!=NULL)
1791  {
1792    res->minpoly=nCopy(r->minpoly);
1793    int l=rPar(r);
1794    res->parameter=(char **)Alloc(l*sizeof(char *));
1795    int i;
1796    for(i=0;i<rPar(r);i++)
1797    {
1798      res->parameter[i]=mstrdup(r->parameter[i]);
1799    }
1800  }
1801  res->names   = (char **)Alloc(r->N * sizeof(char *));
1802  i=1;
1803  pi=r->order;
1804  while ((*pi)!=0) { i++;pi++; }
1805  res->wvhdl   = (short **)Alloc(i * sizeof(short *));
1806  res->order   = (int *)   Alloc(i * sizeof(int));
1807  res->block0  = (int *)   Alloc(i * sizeof(int));
1808  res->block1  = (int *)   Alloc(i * sizeof(int));
1809  for (j=0; j<i; j++)
1810  {
1811    if (r->wvhdl[j]!=NULL)
1812    {
1813      res->wvhdl[j]=(short*)AllocL(mmSizeL((ADDRESS)r->wvhdl[j]));
1814      memcpy(res->wvhdl[j],r->wvhdl[j],mmSizeL((ADDRESS)r->wvhdl[j]));
1815    }
1816    else
1817      res->wvhdl[j]=NULL;
1818  }
1819  memcpy4(res->order,r->order,i * sizeof(int));
1820  memcpy4(res->block0,r->block0,i * sizeof(int));
1821  memcpy4(res->block1,r->block1,i * sizeof(int));
1822  for (i=0; i<res->N; i++)
1823  {
1824    res->names[i] = mstrdup(r->names[i]);
1825  }
1826  res->idroot = NULL;
1827  if (r->qideal!=NULL) res->qideal= idCopy(r->qideal);
1828  res->VarOffset = (int*) Alloc((r->N + 1)*sizeof(int));
1829  memcpy4(res->VarOffset, r->VarOffset, (r->N + 1)*sizeof(int));
1830
1831#ifdef RDEBUG
1832  rNumber++;
1833  res->no=rNumber;
1834#endif
1835
1836  return res;
1837}
1838
1839// returns TRUE, if r1 equals r2 FALSE, otherwise Equality is
1840// determined componentwise, if qr == 1, then qrideal equality is
1841// tested, as well
1842BOOLEAN rEqual(ring r1, ring r2, BOOLEAN qr)
1843{
1844  int i, j;
1845
1846  if (r1 == r2) return 1;
1847
1848  if (r1 == NULL || r2 == NULL) return 0;
1849
1850  if ((rInternalChar(r1) != rInternalChar(r2))
1851  // orig: r1->ch == r2->ch ???
1852  || (r1->N != r2->N) || (r1->OrdSgn != r2->OrdSgn)
1853      || (rPar(r1) != rPar(r2)))
1854    return 0;
1855
1856  for (i=0; i<r1->N; i++)
1857    if (strcmp(r1->names[i], r2->names[i])) return 0;
1858
1859  i=0;
1860  while (r1->order[i] != 0)
1861  {
1862    if (r2->order[i] == 0) return 0;
1863    if ((r1->order[i] != r2->order[i]) ||
1864        (r1->block0[i] != r2->block0[i]) || (r2->block0[i] != r1->block0[i]))
1865      return 0;
1866    if (r1->wvhdl[i] != NULL)
1867    {
1868      if (r2->wvhdl[i] == NULL)
1869        return 0;
1870      for (j=0; j<r1->block1[i]-r1->block0[i]+1; j++)
1871        if (r2->wvhdl[i][j] != r1->wvhdl[i][j])
1872          return 0;
1873    }
1874    else if (r2->wvhdl[i] != NULL) return 0;
1875    i++;
1876  }
1877
1878  for (i=0; i<rPar(r1);i++)
1879  {
1880      if (strcmp(r1->parameter[i], r2->parameter[i])!=0)
1881        return 0;
1882  }
1883
1884  if (r1->minpoly != NULL)
1885  {
1886    if (r2->minpoly == NULL) return 0;
1887    if (currRing == r1 || currRing == r2)
1888    {
1889      if (! nEqual(r1->minpoly, r2->minpoly)) return 0;
1890    }
1891  }
1892  else if (r2->minpoly != NULL) return 0;
1893
1894  if (qr)
1895  {
1896    if (r1->qideal != NULL)
1897    {
1898      ideal id1 = r1->qideal, id2 = r2->qideal;
1899      int i, n;
1900      poly *m1, *m2;
1901
1902      if (id2 == NULL) return 0;
1903      if ((n = IDELEMS(id1)) != IDELEMS(id2)) return 0;
1904
1905      if (currRing == r1 || currRing == r2)
1906      {
1907        m1 = id1->m;
1908        m2 = id2->m;
1909        for (i=0; i<n; i++)
1910          if (! pEqualPolys(m1[i],m2[i])) return 0;
1911      }
1912    }
1913    else if (r2->qideal != NULL) return 0;
1914  }
1915
1916  return 1;
1917}
1918
1919rOrderType_t rGetOrderType(ring r)
1920{
1921  // check for simple ordering
1922  if (rHasSimpleOrder(r))
1923  {
1924    if ((r->order[1] == ringorder_c) || (r->order[1] == ringorder_C))
1925    {
1926      switch(r->order[0])
1927      {
1928          case ringorder_dp:
1929          case ringorder_wp:
1930          case ringorder_ds:
1931          case ringorder_ws:
1932          case ringorder_ls:
1933          case ringorder_unspec:
1934            if (r->order[1] == ringorder_C ||  r->order[0] == ringorder_unspec)
1935              return rOrderType_ExpComp;
1936            return rOrderType_Exp;
1937
1938          default:
1939            assume(r->order[0] == ringorder_lp ||
1940                   r->order[0] == ringorder_Dp ||
1941                   r->order[0] == ringorder_Wp ||
1942                   r->order[0] == ringorder_Ds ||
1943                   r->order[0] == ringorder_Ws);
1944
1945            if (r->order[1] == ringorder_c) return rOrderType_ExpComp;
1946            return rOrderType_Exp;
1947      }
1948    }
1949    else
1950    {
1951      assume((r->order[0]==ringorder_c)||(r->order[0]==ringorder_C));
1952      return rOrderType_CompExp;
1953    }
1954  }
1955  else
1956    return rOrderType_General;
1957}
1958
1959BOOLEAN rHasSimpleOrder(ring r)
1960{
1961  return
1962    (r->order[0] == ringorder_unspec) ||
1963    ((r->order[2] == 0) &&
1964     (r->order[1] != ringorder_M &&
1965      r->order[0] != ringorder_M));
1966}
1967
1968// returns TRUE, if simple lp or ls ordering
1969BOOLEAN rHasSimpleLexOrder(ring r)
1970{
1971  return rHasSimpleOrder(r) &&
1972    (r->order[0] == ringorder_ls ||
1973     r->order[0] == ringorder_lp ||
1974     r->order[1] == ringorder_ls ||
1975     r->order[1] == ringorder_lp);
1976}
1977
1978BOOLEAN rIsPolyVar(int v)
1979{
1980  int  i=0;
1981  while(currRing->order[i]!=0)
1982  {
1983    if((currRing->block0[i]<=v)
1984    && (currRing->block1[i]>=v))
1985    {
1986      switch(currRing->order[i])
1987      {
1988        case ringorder_a:
1989          return (currRing->wvhdl[i][v-currRing->block0[i]]>0);
1990        case ringorder_M:
1991          return 2; /*don't know*/
1992        case ringorder_lp:
1993        case ringorder_dp:
1994        case ringorder_Dp:
1995        case ringorder_wp:
1996        case ringorder_Wp:
1997          return TRUE;
1998        case ringorder_ls:
1999        case ringorder_ds:
2000        case ringorder_Ds:
2001        case ringorder_ws:
2002        case ringorder_Ws:
2003          return FALSE;
2004        default:
2005          break;
2006      }
2007    }
2008    i++;
2009  }
2010  return 3; /* could not find var v*/
2011}
2012
2013void rUnComplete(ring r)
2014{
2015  Free((ADDRESS)r->VarOffset,(r->N + 1)*sizeof(int));
2016  r->VarOffset=NULL;
2017}
2018
2019#ifdef RDEBUG
2020// This should eventually become a full-fledge ring check, like pTest
2021BOOLEAN rDBTest(ring r, char* fn, int l)
2022{
2023  if (r == NULL)
2024  {
2025    Werror("Null ring in %s:%l\n", fn, l);
2026    return false;
2027  }
2028
2029  if (r->N == 0) return true;
2030
2031  if (r->VarOffset == NULL)
2032  {
2033    Werror("Null ring VarOffset -- no rComplete (?) in n %s:%d\n", fn, l);
2034    assume(0);
2035    return false;
2036  }
2037
2038  int
2039    VarCompIndex = r->VarCompIndex,
2040    VarLowIndex  = r->VarLowIndex,
2041    VarHighIndex = r->VarHighIndex,
2042    i;
2043  BOOLEAN ok = false;
2044  int* VarOffset = r->VarOffset;
2045
2046  rComplete(r);
2047
2048  if (   VarCompIndex != r->VarCompIndex ||
2049         VarLowIndex  != r->VarLowIndex ||
2050         VarHighIndex != r->VarHighIndex)
2051  {
2052    Werror("Wrong ring VarIndicies -- no rComplete (?) in n %s:%d\n", fn, l);
2053    assume(0);
2054    ok = FALSE;
2055  }
2056
2057  for (i=0; i<=r->N; i++)
2058  {
2059    if (VarOffset[i] != r->VarOffset[i])
2060    {
2061      Werror("Wrong VarOffset value at %d in %s:%d\n", i, fn, l);
2062      assume(0);
2063      ok = FALSE;
2064    }
2065  }
2066  Free(r->VarOffset, (r->N + 1)*sizeof(int));
2067  r->VarOffset = VarOffset;
2068  return ok;
2069}
2070#endif
Note: See TracBrowser for help on using the repository browser.