source: git/Singular/extra.cc @ 4ae863

spielwiese
Last change on this file since 4ae863 was 4ae863, checked in by Hans Schönemann <hannes@…>, 23 years ago
*hannes: moved units to EXTENDEDSYSTEM git-svn-id: file:///usr/local/Singular/svn/trunk@5173 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 32.3 KB
Line 
1/*****************************************
2*  Computer Algebra System SINGULAR      *
3*****************************************/
4/* $Id: extra.cc,v 1.157 2001-02-02 14:40:13 Singular Exp $ */
5/*
6* ABSTRACT: general interface to internals of Singular ("system" command)
7*/
8
9#include <stdlib.h>
10#if defined(__alpha)
11extern "C"
12{
13  int setenv(const char *name, const char *value, int overwrite);
14}
15#endif
16
17#include <stdio.h>
18#include <string.h>
19#include <ctype.h>
20#include <signal.h>
21#include "mod2.h"
22
23#ifndef __MWERKS__
24#ifdef TIME_WITH_SYS_TIME
25# include <time.h>
26# ifdef HAVE_SYS_TIME_H
27#   include <sys/time.h>
28# endif
29#else
30# ifdef HAVE_SYS_TIME_H
31#   include <sys/time.h>
32# else
33#   include <time.h>
34# endif
35#endif
36#ifdef HAVE_SYS_TIMES_H
37#include <sys/times.h>
38#endif
39
40#endif
41#include <unistd.h>
42
43#include "tok.h"
44#include "ipid.h"
45#include "polys.h"
46#include "kutil.h"
47#include "cntrlc.h"
48#include "stairc.h"
49#include "ipshell.h"
50#include "algmap.h"
51#include "modulop.h"
52#include "febase.h"
53#include "matpol.h"
54#include "longalg.h"
55#include "ideals.h"
56#include "kstd1.h"
57#include "syz.h"
58#include "sdb.h"
59#include "feOpt.h"
60#include "distrib.h"
61#include "prCopy.h"
62#include "mpr_complex.h"
63
64#include "walk.h"
65
66#ifdef HAVE_SPECTRUM
67#include "spectrum.h"
68#endif
69
70#ifdef HAVE_PLURAL
71#include "gring.h"
72#endif
73
74// Define to enable many more system commands
75#ifndef MAKE_DISTRIBUTION
76#define HAVE_EXTENDED_SYSTEM
77#endif
78
79#ifdef HAVE_FACTORY
80#define SI_DONT_HAVE_GLOBAL_VARS
81#include "clapsing.h"
82#include "clapconv.h"
83#include "kstdfac.h"
84#endif
85
86#include "silink.h"
87#include "walk.h"
88
89/*
90 *   New function/system-calls that will be included as dynamic module
91 * should be inserted here.
92 * - without HAVE_DYNAMIC_LOADING: these functions comes as system("....");
93 * - with    HAVE_DYNAMIC_LOADING: these functions are loaded as module.
94 */
95#ifndef HAVE_DYNAMIC_LOADING
96#ifdef HAVE_PCV
97#include "pcv.h"
98#endif
99#endif /* not HAVE_DYNAMIC_LOADING */
100
101// procedures to compute with units
102#ifdef HAVE_UNITS
103#include "units.h"
104#endif
105
106// see clapsing.cc for a description of the `FACTORY_*' options
107
108#ifdef FACTORY_GCD_STAT
109#include "gcd_stat.h"
110#endif
111
112#ifdef FACTORY_GCD_TIMING
113#define TIMING
114#include "timing.h"
115TIMING_DEFINE_PRINTPROTO( contentTimer );
116TIMING_DEFINE_PRINTPROTO( algContentTimer );
117TIMING_DEFINE_PRINTPROTO( algLcmTimer );
118#endif
119
120void piShowProcList();
121#ifndef MAKE_DISTRIBUTION
122static BOOLEAN jjEXTENDED_SYSTEM(leftv res, leftv h);
123#endif
124
125
126//void emStart();
127/*2
128*  the "system" command
129*/
130BOOLEAN jjSYSTEM(leftv res, leftv args)
131{
132  if(args->Typ() == STRING_CMD)
133  {
134    const char *sys_cmd=(char *)(args->Data());
135    leftv h=args->next;
136// ONLY documented system calls go here
137// Undocumented system calls go down into #ifdef HAVE_EXTENDED_SYSTEM
138/*==================== nblocks ==================================*/
139    if (strcmp(sys_cmd, "nblocks") == 0)
140    {
141      ring r;
142      if (h == NULL)
143      {
144        if (currRingHdl != NULL)
145        {
146          r = IDRING(currRingHdl);
147        }
148        else
149        {
150          WerrorS("no ring active");
151          return TRUE;
152        }
153      }
154      else
155      {
156        if (h->Typ() != RING_CMD)
157        {
158          WerrorS("ring expected");
159          return TRUE;
160        }
161        r = (ring) h->Data();
162      }
163      res->rtyp = INT_CMD;
164      res->data = (void*) (rBlocks(r) - 1);
165      return FALSE;
166    }
167/*==================== version ==================================*/
168    if(strcmp(sys_cmd,"version")==0)
169    {
170      res->rtyp=INT_CMD;
171      res->data=(void *)SINGULAR_VERSION;
172      return FALSE;
173    }
174    else
175/*==================== gen ==================================*/
176    if(strcmp(sys_cmd,"gen")==0)
177    {
178      res->rtyp=INT_CMD;
179      res->data=(void *)npGen;
180      return FALSE;
181    }
182    else
183/*==================== sh ==================================*/
184    if(strcmp(sys_cmd,"sh")==0)
185    {
186      res->rtyp=INT_CMD;
187      #ifndef __MWERKS__
188      if (h==NULL) res->data = (void *)system("sh");
189      else if (h->Typ()==STRING_CMD)
190        res->data = (void*) system((char*)(h->Data()));
191      else
192        WerrorS("string expected");
193      #else
194      res->data=(void *)0;
195      #endif
196      return FALSE;
197    }
198    else
199/*==================== uname ==================================*/
200    if(strcmp(sys_cmd,"uname")==0)
201    {
202      res->rtyp=STRING_CMD;
203      res->data = omStrDup(S_UNAME);
204      return FALSE;
205    }
206    else
207/*==================== with ==================================*/
208    if(strcmp(sys_cmd,"with")==0)
209    {
210      if (h==NULL)
211      {
212        res->rtyp=STRING_CMD;
213        res->data=(void *)omStrDup(versionString());
214        return FALSE;
215      }
216      else if (h->Typ()==STRING_CMD)
217      {
218        #define TEST_FOR(A) if(strcmp(s,A)==0) res->data=(void *)1; else
219        char *s=(char *)h->Data();
220        res->rtyp=INT_CMD;
221        #ifdef HAVE_DBM
222          TEST_FOR("DBM")
223        #endif
224        #ifdef HAVE_DLD
225          TEST_FOR("DLD")
226        #endif
227        #ifdef HAVE_FACTORY
228          TEST_FOR("factory")
229        #endif
230        #ifdef HAVE_LIBFAC_P
231          TEST_FOR("libfac")
232        #endif
233        #ifdef HAVE_MPSR
234          TEST_FOR("MP")
235        #endif
236        #ifdef HAVE_READLINE
237          TEST_FOR("readline")
238        #endif
239        #ifdef HAVE_TCL
240          TEST_FOR("tcl")
241        #endif
242        #ifdef TEST_MAC_ORDER
243          TEST_FOR("MAC_ORDER");
244        #endif
245        #ifdef HAVE_NAMESPACES
246          TEST_FOR("Namespaces");
247        #endif
248        #ifdef HAVE_DYNAMIC_LOADING
249          TEST_FOR("DynamicLoading");
250        #endif
251          ;
252        return FALSE;
253        #undef TEST_FOR
254      }
255      return TRUE;
256    }
257    else
258/*==================== browsers ==================================*/
259    if (strcmp(sys_cmd,"browsers")==0)
260    {
261      res->rtyp = STRING_CMD;
262      char* b = StringSetS("");
263      feStringAppendBrowsers(0);
264      res->data = omStrDup(b);
265      return FALSE;
266    }
267    else
268/*==================== pid ==================================*/
269    if (strcmp(sys_cmd,"pid")==0)
270    {
271      res->rtyp=INT_CMD;
272    #ifndef MSDOS
273    #ifndef __MWERKS__
274      res->data=(void *)getpid();
275    #else
276      res->data=(void *)1;
277    #endif
278    #else
279      res->data=(void *)1;
280    #endif
281      return FALSE;
282    }
283    else
284/*==================== getenv ==================================*/
285    if (strcmp(sys_cmd,"getenv")==0)
286    {
287      if ((h!=NULL) && (h->Typ()==STRING_CMD))
288      {
289        res->rtyp=STRING_CMD;
290        char *r=getenv((char *)h->Data());
291        if (r==NULL) r="";
292        res->data=(void *)omStrDup(r);
293        return FALSE;
294      }
295      else
296      {
297        WerrorS("string expected");
298        return TRUE;
299      }
300    }
301    else
302/*==================== setenv ==================================*/
303    if (strcmp(sys_cmd,"setenv")==0)
304    {
305#ifdef HAVE_SETENV
306      if (h!=NULL && h->Typ()==STRING_CMD && h->Data() != NULL &&
307          h->next != NULL && h->next->Typ() == STRING_CMD
308          && h->next->Data() != NULL)
309      {
310        res->rtyp=STRING_CMD;
311        setenv((char *)h->Data(), (char *)h->next->Data(), 1);
312        res->data=(void *)omStrDup((char *)h->next->Data());
313        feReInitResources();
314        return FALSE;
315      }
316      else
317      {
318        WerrorS("two strings expected");
319        return TRUE;
320      }
321#else
322      WerrorS("setenv not supported on this platform");
323      return TRUE;
324#endif
325    }
326    else
327/*==================== Singular ==================================*/
328    if (strcmp(sys_cmd, "Singular") == 0)
329    {
330      res->rtyp=STRING_CMD;
331      char *r=feResource("Singular");
332      if (r != NULL)
333        res->data = (void*) omStrDup( r );
334      else
335        res->data = (void*) omStrDup("");
336      return FALSE;
337    }
338    else
339/*==================== options ==================================*/
340    if (strstr(sys_cmd, "--") == sys_cmd)
341    {
342      if (strcmp(sys_cmd, "--") == 0)
343      {
344        fePrintOptValues();
345        return FALSE;
346      }
347
348      feOptIndex opt = feGetOptIndex(&sys_cmd[2]);
349      if (opt == FE_OPT_UNDEF)
350      {
351        Werror("Unknown option %s", sys_cmd);
352        Werror("Use 'system(\"--\");' for listing of available options");
353        return TRUE;
354      }
355
356      // for Untyped Options (help version),
357      // setting it just triggers action
358      if (feOptSpec[opt].type == feOptUntyped)
359      {
360        feSetOptValue(opt,0);
361        return FALSE;
362      }
363
364      if (h == NULL)
365      {
366        if (feOptSpec[opt].type == feOptString)
367        {
368          res->rtyp = STRING_CMD;
369          if (feOptSpec[opt].value != NULL)
370            res->data = omStrDup((char*) feOptSpec[opt].value);
371          else
372            res->data = omStrDup("");
373        }
374        else
375        {
376          res->rtyp = INT_CMD;
377          res->data = feOptSpec[opt].value;
378        }
379        return FALSE;
380      }
381
382      if (h->Typ() != STRING_CMD &&
383          h->Typ() != INT_CMD)
384      {
385        Werror("Need string or int argument to set option value");
386        return TRUE;
387      }
388      char* errormsg;
389      if (h->Typ() == INT_CMD)
390      {
391        if (feOptSpec[opt].type == feOptString)
392        {
393          Werror("Need string argument to set value of option %s", sys_cmd);
394          return TRUE;
395        }
396        errormsg = feSetOptValue(opt, (int) h->Data());
397        if (errormsg != NULL)
398          Werror("Option '--%s=%d' %s", sys_cmd, (int) h->Data(), errormsg);
399      }
400      else
401      {
402        errormsg = feSetOptValue(opt, (char*) h->Data());
403        if (errormsg != NULL)
404          Werror("Option '--%s=%s' %s", sys_cmd, (char*) h->Data(), errormsg);
405      }
406      if (errormsg != NULL) return TRUE;
407      return FALSE;
408    }
409    else
410/*==================== HC ==================================*/
411    if (strcmp(sys_cmd,"HC")==0)
412    {
413      res->rtyp=INT_CMD;
414      res->data=(void *)HCord;
415      return FALSE;
416    }
417    else
418/*==================== random ==================================*/
419    if(strcmp(sys_cmd,"random")==0)
420    {
421      if ((h!=NULL) &&(h->Typ()==INT_CMD))
422      {
423        siRandomStart=(int)h->Data();
424#ifdef buildin_rand
425        siSeed=siRandomStart;
426#else
427        srand((unsigned int)siRandomStart);
428#endif
429#ifdef HAVE_FACTORY
430        factoryseed(siRandomStart);
431#endif
432        return FALSE;
433      }
434      else if (h != NULL)
435      {
436        WerrorS("int expected");
437        return TRUE;
438      }
439      res->rtyp=INT_CMD;
440      res->data=(void*) siRandomStart;
441      return FALSE;
442    }
443/*==================== complexNearZero ======================*/
444    if(strcmp(sys_cmd,"complexNearZero")==0)
445    {
446      if (h->Typ()==NUMBER_CMD )
447      {
448        if ( h->next!=NULL && h->next->Typ()==INT_CMD )
449        {
450          if ( !rField_is_long_C() )
451            {
452              Werror( "unsupported ground field!");
453              return TRUE;
454            }
455          else
456            {
457              res->rtyp=INT_CMD;
458              res->data=(void*)complexNearZero((gmp_complex*)h->Data(),(int)h->next->Data());
459              return FALSE;
460            }
461        }
462        else
463        {
464          Werror( "expected <int> as third parameter!");
465          return TRUE;
466        }
467      }
468      else
469      {
470        Werror( "expected <number> as second parameter!");
471        return TRUE;
472      }
473    }
474/*==================== getPrecDigits ======================*/
475    if(strcmp(sys_cmd,"getPrecDigits")==0)
476    {
477      if ( !rField_is_long_C() && !rField_is_long_R() )
478      {
479        Werror( "unsupported ground field!");
480        return TRUE;
481      }
482      res->rtyp=INT_CMD;
483      res->data=(void*)getGMPFloatDigits();
484      return FALSE;
485    }
486/*==================== neworder =============================*/
487// should go below
488#ifdef HAVE_LIBFAC_P
489    if(strcmp(sys_cmd,"neworder")==0)
490    {
491      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
492      {
493        res->rtyp=STRING_CMD;
494        res->data=(void *)singclap_neworder((ideal)h->Data());
495        return FALSE;
496      }
497      else
498        WerrorS("ideal expected");
499    }
500    else
501#endif
502/*==================== pcv ==================================*/
503#ifndef HAVE_DYNAMIC_LOADING
504#ifdef HAVE_PCV
505    if(strcmp(sys_cmd,"pcvLAddL")==0)
506    {
507      return pcvLAddL(res,h);
508    }
509    else
510    if(strcmp(sys_cmd,"pcvPMulL")==0)
511    {
512      return pcvPMulL(res,h);
513    }
514    else
515    if(strcmp(sys_cmd,"pcvMinDeg")==0)
516    {
517      return pcvMinDeg(res,h);
518    }
519    else
520    if(strcmp(sys_cmd,"pcvP2CV")==0)
521    {
522      return pcvP2CV(res,h);
523    }
524    else
525    if(strcmp(sys_cmd,"pcvCV2P")==0)
526    {
527      return pcvCV2P(res,h);
528    }
529    else
530    if(strcmp(sys_cmd,"pcvDim")==0)
531    {
532      return pcvDim(res,h);
533    }
534    else
535    if(strcmp(sys_cmd,"pcvBasis")==0)
536    {
537      return pcvBasis(res,h);
538    }
539    else
540#endif
541#endif /* HAVE_DYNAMIC_LOADING */
542/*==================== contributors =============================*/
543   if(strcmp(sys_cmd,"contributors") == 0)
544   {
545     res->rtyp=STRING_CMD;
546     res->data=(void *)omStrDup(
547       "Olaf Bachmann, Hubert Grassmann, Kai Krueger, Wolfgang Neumann, Thomas Nuessler, Wilfred Pohl, Jens Schmidt, Thomas Siebert, Ruediger Stobbe, Moritz Wenk, Tim Wichmann");
548     return FALSE;
549   }
550   else
551/*==================== spectrum =============================*/
552   #ifdef HAVE_SPECTRUM
553   if(strcmp(sys_cmd,"spectrum") == 0)
554   {
555     if (h->Typ()!=POLY_CMD)
556     {
557       WerrorS("poly expected");
558       return TRUE;
559     }
560     if (h->next==NULL)
561       return spectrumProc(res,h);
562     if (h->next->Typ()!=INT_CMD)
563     {
564       WerrorS("poly,int expected");
565       return TRUE;
566     }
567     if(((int)h->next->Data())==1)
568       return spectrumfProc(res,h);
569     return spectrumProc(res,h);
570   }
571   else
572/*==================== semic =============================*/
573   if(strcmp(sys_cmd,"semic") == 0)
574   {
575     if ((h->next!=NULL)
576     && (h->Typ()==LIST_CMD)
577     && (h->next->Typ()==LIST_CMD))
578     {
579       if (h->next->next==NULL)
580         return semicProc(res,h,h->next);
581       else if (h->next->next->Typ()==INT_CMD)
582         return semicProc3(res,h,h->next,h->next->next);
583     }
584     return TRUE;
585   }
586   else
587/*==================== spadd =============================*/
588   if(strcmp(sys_cmd,"spadd") == 0)
589   {
590     if ((h->next!=NULL)
591     && (h->Typ()==LIST_CMD)
592     && (h->next->Typ()==LIST_CMD))
593     {
594       if (h->next->next==NULL)
595         return spaddProc(res,h,h->next);
596     }
597     return TRUE;
598   }
599   else
600/*==================== spmul =============================*/
601   if(strcmp(sys_cmd,"spmul") == 0)
602   {
603     if ((h->next!=NULL)
604     && (h->Typ()==LIST_CMD)
605     && (h->next->Typ()==INT_CMD))
606     {
607       if (h->next->next==NULL)
608         return spmulProc(res,h,h->next);
609     }
610     return TRUE;
611   }
612   else
613   #endif
614/*================= Extended system call ========================*/
615   {
616     #ifndef MAKE_DISTRIBUTION
617     return(jjEXTENDED_SYSTEM(res, args));
618     #else
619     Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
620     #endif
621   }
622  } /* typ==string */
623  return TRUE;
624}
625
626
627
628#ifdef HAVE_EXTENDED_SYSTEM
629// You can put your own system calls here
630#include "fglmcomb.cc"
631#include "fglm.h"
632#ifdef HAVE_NEWTON
633#include <hc_newton.h>
634#endif
635#include "mpsr.h"
636
637#include "mod_raw.h"
638   
639static BOOLEAN jjEXTENDED_SYSTEM(leftv res, leftv h)
640{
641  if(h->Typ() == STRING_CMD)
642  {
643    char *sys_cmd=(char *)(h->Data());
644    h=h->next;
645#ifdef RDEBUG
646/*==================== poly debug ==================================*/
647    if(strcmp(sys_cmd,"p")==0)
648    {
649      pDebugPrint((poly)h->Data());
650      return FALSE;
651    }
652    else
653/*==================== ring debug ==================================*/
654    if(strcmp(sys_cmd,"r")==0)
655    {
656      rDebugPrint((ring)h->Data());
657      return FALSE;
658    }
659    else
660#endif
661/*==================== mtrack ==================================*/
662    if(strcmp(sys_cmd,"mtrack")==0)
663    {
664#ifdef OM_TRACK
665      om_Opts.MarkAsStatic = 1;
666      FILE *fd = NULL;
667      int max = 5;
668      while (h != NULL)
669      {
670        omMarkAsStaticAddr(h);
671        if (fd == NULL && h->Typ()==STRING_CMD)
672        {
673          fd = fopen((char*) h->Data(), "w");
674          if (fd == NULL)
675            Warn("Can not open %s for writing og mtrack. Using stdout");
676        }
677        if (h->Typ() == INT_CMD)
678        {
679          max = (int) h->Data();
680        }
681        h = h->Next();
682      }
683      omPrintUsedTrackAddrs((fd == NULL ? stdout : fd), max);
684      if (fd != NULL) fclose(fd);
685      om_Opts.MarkAsStatic = 0;
686      return FALSE;
687#else
688     WerrorS("mtrack not supported without OM_TRACK");
689     return TRUE;
690#endif
691    }
692/*==================== mtrack_all ==================================*/
693    if(strcmp(sys_cmd,"mtrack_all")==0)
694    {
695#ifdef OM_TRACK
696      om_Opts.MarkAsStatic = 1;
697      FILE *fd = NULL;
698      if ((h!=NULL) &&(h->Typ()==STRING_CMD))
699      {
700        fd = fopen((char*) h->Data(), "w");
701        if (fd == NULL)
702          Warn("Can not open %s for writing og mtrack. Using stdout");
703        omMarkAsStaticAddr(h);
704      }
705      // OB: TBC print to fd
706      omPrintUsedAddrs((fd == NULL ? stdout : fd), 5);
707      if (fd != NULL) fclose(fd);
708      om_Opts.MarkAsStatic = 0;
709      return FALSE;
710#else
711     WerrorS("mtrack not supported without OM_TRACK");
712     return TRUE;
713#endif
714    }
715    else
716/*==================== backtrace ==================================*/
717    if(strcmp(sys_cmd,"backtrace")==0)
718    {
719#ifndef OM_NDEBUG
720      omPrintCurrentBackTrace(stdout);
721      return FALSE;
722#else
723     WerrorS("btrack not supported without OM_TRACK");
724     return TRUE;
725#endif
726    }
727    else
728/*==================== naIdeal ==================================*/
729    if(strcmp(sys_cmd,"naIdeal")==0)
730    {
731      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
732      {
733        naSetIdeal((ideal)h->Data());
734        return FALSE;
735      }
736      else
737         WerrorS("ideal expected");
738    }
739    else
740/*==================== isSqrFree =============================*/
741#ifdef HAVE_FACTORY
742    if(strcmp(sys_cmd,"isSqrFree")==0)
743    {
744      if ((h!=NULL) &&(h->Typ()==POLY_CMD))
745      {
746        res->rtyp=INT_CMD;
747        res->data=(void *)singclap_isSqrFree((poly)h->Data());
748        return FALSE;
749      }
750      else
751        WerrorS("poly expected");
752    }
753    else
754#endif
755/*==================== pDivStat =============================*/
756#if defined(PDEBUG) || defined(PDIV_DEBUG)
757    if(strcmp(sys_cmd,"pDivStat")==0)
758    {
759      extern void pPrintDivisbleByStat();
760      pPrintDivisbleByStat();
761      return FALSE;
762    }
763    else
764#endif
765/*==================== alarm ==================================*/
766#ifndef __MWERKS__
767#ifndef MSDOS
768#ifndef atarist
769#ifdef unix
770    if(strcmp(sys_cmd,"alarm")==0)
771    {
772      if ((h!=NULL) &&(h->Typ()==INT_CMD))
773      {
774        // standard variant -> SIGALARM (standard: abort)
775        //alarm((unsigned)h->next->Data());
776        // process time (user +system): SIGVTALARM
777        struct itimerval t,o;
778        memset(&t,0,sizeof(t));
779        t.it_value.tv_sec     =(unsigned)h->Data();
780        setitimer(ITIMER_VIRTUAL,&t,&o);
781        return FALSE;
782      }
783      else
784        WerrorS("int expected");
785    }
786    else
787#endif
788#endif
789#endif
790#endif
791/*==================== red =============================*/
792#if 0
793    if(strcmp(sys_cmd,"red")==0)
794    {
795      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
796      {
797        res->rtyp=IDEAL_CMD;
798        res->data=(void *)kStdred((ideal)h->Data(),NULL,testHomog,NULL);
799        setFlag(res,FLAG_STD);
800        return FALSE;
801      }
802      else
803        WerrorS("ideal expected");
804    }
805    else
806#endif
807/*==================== algfetch =====================*/
808    if (strcmp(sys_cmd,"algfetch")==0)
809    {
810      int k;
811      idhdl w;
812      ideal i0, i1;
813      ring r0=(ring)h->Data();
814      leftv v = h->next;
815      w = r0->idroot->get(v->Name(),myynest);
816      if (w!=NULL)
817      {
818        if (IDTYP(w)==IDEAL_CMD)
819        {
820          i0 = IDIDEAL(w);
821          i1 = idInit(IDELEMS(i0),i0->rank);
822          for (k=0; k<IDELEMS(i1); k++)
823          {
824            i1->m[k] = maAlgpolyFetch(r0, i0->m[k]);
825          }
826          res->rtyp = IDEAL_CMD;
827          res->data = (void*)i1;
828          return FALSE;
829        }
830        else if (IDTYP(w)==POLY_CMD)
831        {
832          res->rtyp = POLY_CMD;
833          res->data = (void*)maAlgpolyFetch(r0,IDPOLY(w));
834          return FALSE;
835        }
836        else
837          WerrorS("`system(\"algfetch\",<ideal>/<poly>)` expected");
838      }
839      else
840        Werror("`%s` not found in `%s`",v->Name(),h->Name());
841    }
842    else
843/*==================== algmap =======================*/
844    if (strcmp(sys_cmd,"algmap")==0)
845    {
846      int k;
847      idhdl w;
848      ideal i0, i1, i, j;
849      ring r0=(ring)h->Data();
850      leftv v = h->next;
851      w = r0->idroot->get(v->Name(),myynest);
852      i0 = IDIDEAL(w);
853      v = v->next;
854      i = (ideal)v->Data();
855      v = v->next;
856      j = (ideal)v->Data();
857      i1 = idInit(IDELEMS(i0),i0->rank);
858      for (k=0; k<IDELEMS(i1); k++)
859      {
860        i1->m[k] = maAlgpolyMap(r0, i0->m[k], i, j);
861      }
862      res->rtyp = IDEAL_CMD;
863      res->data = (void*)i1;
864      return FALSE;
865    }
866    else
867#ifdef HAVE_FACTORY
868/*==================== fastcomb =============================*/
869    if(strcmp(sys_cmd,"fastcomb")==0)
870    {
871      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
872      {
873        int i=0;
874        if (h->next!=NULL)
875        {
876          if (h->next->Typ()!=POLY_CMD)
877          {
878            Warn("Wrong types for poly= comb(ideal,poly)");
879          }
880        }
881        res->rtyp=POLY_CMD;
882        res->data=(void *) fglmLinearCombination(
883                           (ideal)h->Data(),(poly)h->next->Data());
884        return FALSE;
885      }
886      else
887        WerrorS("ideal expected");
888    }
889    else
890/*==================== comb =============================*/
891    if(strcmp(sys_cmd,"comb")==0)
892    {
893      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
894      {
895        int i=0;
896        if (h->next!=NULL)
897        {
898          if (h->next->Typ()!=POLY_CMD)
899          {
900              Warn("Wrong types for poly= comb(ideal,poly)");
901          }
902        }
903        res->rtyp=POLY_CMD;
904        res->data=(void *)fglmNewLinearCombination(
905                            (ideal)h->Data(),(poly)h->next->Data());
906        return FALSE;
907      }
908      else
909        WerrorS("ideal expected");
910    }
911    else
912#endif
913#ifdef FACTORY_GCD_TEST
914/*=======================gcd Testerei ================================*/
915    if ( ! strcmp( sys_cmd, "setgcd" ) ) {
916        if ( (h != NULL) && (h->Typ() == INT_CMD) ) {
917            CFPrimitiveGcdUtil::setAlgorithm( (int)h->Data() );
918            return FALSE;
919        } else
920            WerrorS("int expected");
921    }
922    else
923#endif
924
925#ifdef FACTORY_GCD_TIMING
926    if ( ! strcmp( sys_cmd, "gcdtime" ) ) {
927        TIMING_PRINT( contentTimer, "time used for content: " );
928        TIMING_PRINT( algContentTimer, "time used for algContent: " );
929        TIMING_PRINT( algLcmTimer, "time used for algLcm: " );
930        TIMING_RESET( contentTimer );
931        TIMING_RESET( algContentTimer );
932        TIMING_RESET( algLcmTimer );
933        return FALSE;
934    }
935    else
936#endif
937
938#ifdef FACTORY_GCD_STAT
939    if ( ! strcmp( sys_cmd, "gcdstat" ) ) {
940        printGcdTotal();
941        printContTotal();
942        resetGcdTotal();
943        resetContTotal();
944        return FALSE;
945    }
946    else
947#endif
948/*==================== lib ==================================*/
949    if(strcmp(sys_cmd,"LIB")==0)
950    {
951#ifdef HAVE_NAMESPACES
952      idhdl hh=namespaceroot->get((char*)h->Data(),0);
953#else /* HAVE_NAMESPACES */
954      idhdl hh=idroot->get((char*)h->Data(),0);
955#endif /* HAVE_NAMESPACES */
956      if ((hh!=NULL)&&(IDTYP(hh)==PROC_CMD))
957      {
958        res->rtyp=STRING_CMD;
959        char *r=iiGetLibName(IDPROC(hh));
960        if (r==NULL) r="";
961        res->data=omStrDup(r);
962        return FALSE;
963      }
964      else
965        Warn("`%s` not found",(char*)h->Data());
966    }
967    else
968#ifdef HAVE_NAMESPACES
969/*==================== nspush ===================================*/
970    if(strcmp(sys_cmd,"nspush")==0)
971    {
972      if (h->Typ()==PACKAGE_CMD)
973      {
974        idhdl hh=(idhdl)h->data;
975        namespaceroot = namespaceroot->push(IDPACKAGE(hh), IDID(hh));
976        return FALSE;
977      }
978      else
979        Warn("argument 2 is not a package");
980    }
981    else
982/*==================== nspop ====================================*/
983    if(strcmp(sys_cmd,"nspop")==0)
984    {
985      namespaceroot->pop();
986      return FALSE;
987    }
988    else
989#endif /* HAVE_NAMESPACES */
990/*==================== nsstack ===================================*/
991    if(strcmp(sys_cmd,"nsstack")==0)
992    {
993      namehdl nshdl = namespaceroot;
994      for( ; nshdl->isroot != TRUE; nshdl = nshdl->next) {
995        Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
996      }
997      Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
998      return FALSE;
999    }
1000    else
1001/*==================== proclist =================================*/
1002    if(strcmp(sys_cmd,"proclist")==0)
1003    {
1004      piShowProcList();
1005      return FALSE;
1006    }
1007    else
1008/* ==================== newton ================================*/
1009#ifdef HAVE_NEWTON
1010    if(strcmp(sys_cmd,"newton")==0)
1011    {
1012      if ((h->Typ()!=POLY_CMD)
1013      || (h->next->Typ()!=INT_CMD)
1014      || (h->next->next->Typ()!=INT_CMD))
1015      {
1016        WerrorS("system(\"newton\",<poly>,<int>,<int>) expected");
1017        return TRUE;
1018      }
1019      poly  p=(poly)(h->Data());
1020      int l=pLength(p);
1021      short *points=(short *)omAlloc(currRing->N*l*sizeof(short));
1022      int i,j,k;
1023      k=0;
1024      poly pp=p;
1025      for (i=0;pp!=NULL;i++)
1026      {
1027        for(j=1;j<=currRing->N;j++)
1028        {
1029          points[k]=pGetExp(pp,j);
1030          k++;
1031        }
1032        pIter(pp);
1033      }
1034      hc_ERG r=hc_KOENIG(currRing->N,      // dimension
1035                l,      // number of points
1036                (short*) points,   // points: x_1, y_1,z_1, x_2,y_2,z2,...
1037                currRing->OrdSgn==-1,
1038                (int) (h->next->Data()),      // 1: Milnor, 0: Newton
1039                (int) (h->next->next->Data()) // debug
1040               );
1041      //----<>---Output-----------------------
1042
1043
1044//  PrintS("Bin jetzt in extra.cc bei der Auswertung.\n"); // **********
1045
1046
1047      lists L=(lists)omAllocBin(slists_bin);
1048      L->Init(6);
1049      L->m[0].rtyp=STRING_CMD;               // newtonnumber;
1050      L->m[0].data=(void *)omStrDup(r.nZahl);
1051      L->m[1].rtyp=INT_CMD;
1052      L->m[1].data=(void *)r.achse;          // flag for unoccupied axes
1053      L->m[2].rtyp=INT_CMD;
1054      L->m[2].data=(void *)r.deg;            // #degenerations
1055      if ( r.deg != 0)              // only if degenerations exist
1056      {
1057        L->m[3].rtyp=INT_CMD;
1058        L->m[3].data=(void *)r.anz_punkte;     // #points
1059        //---<>--number of points------
1060        int anz = r.anz_punkte;    // number of points
1061        int dim = (currRing->N);     // dimension
1062        intvec* v = new intvec( anz*dim );
1063        for (i=0; i<anz*dim; i++)    // copy points
1064          (*v)[i] = r.pu[i];
1065        L->m[4].rtyp=INTVEC_CMD;
1066        L->m[4].data=(void *)v;
1067        //---<>--degenerations---------
1068        int deg = r.deg;    // number of points
1069        intvec* w = new intvec( r.speicher );  // necessary memeory
1070        i=0;               // start copying
1071        do
1072        {
1073          (*w)[i] = r.deg_tab[i];
1074          i++;
1075        }
1076        while (r.deg_tab[i-1] != -2);   // mark for end of list
1077        L->m[5].rtyp=INTVEC_CMD;
1078        L->m[5].data=(void *)w;
1079      }
1080      else
1081      {
1082        L->m[3].rtyp=INT_CMD; L->m[3].data=(char *)0;
1083        L->m[4].rtyp=DEF_CMD;
1084        L->m[5].rtyp=DEF_CMD;
1085      }
1086
1087      res->data=(void *)L;
1088      res->rtyp=LIST_CMD;
1089      // free all pointer in r:
1090      delete[] r.nZahl;
1091      delete[] r.pu;
1092      delete[] r.deg_tab;      // Ist das ein Problem??
1093
1094      omFreeSize((ADDRESS)points,currRing->N*l*sizeof(short));
1095      return FALSE;
1096    }
1097    else
1098#endif
1099/*==================== sdb_flags =================*/
1100    if (strcmp(sys_cmd, "sdb_flags") == 0)
1101    {
1102      if ((h!=NULL) && (h->Typ()==INT_CMD))
1103      {
1104        sdb_flags=(int)h->Data();
1105      }
1106      else
1107      {
1108        WerrorS("system(\"sdb_flags\",`int`) expected");
1109        return TRUE;
1110      }
1111      return FALSE;
1112    }
1113    else
1114/*==================== sdb_edit =================*/
1115    if (strcmp(sys_cmd, "sdb_edit") == 0)
1116    {
1117      if ((h!=NULL) && (h->Typ()==PROC_CMD))
1118      {
1119        procinfov p=(procinfov)h->Data();
1120        sdb_edit(p);
1121      }
1122      else
1123      {
1124        WerrorS("system(\"sdb_edit\",`proc`) expected");
1125        return TRUE;
1126      }
1127      return FALSE;
1128    }
1129    else
1130/*==================== GF =================*/
1131#if 0
1132    if (strcmp(sys_cmd, "GF") == 0)
1133    {
1134      int c=rChar(currRing);
1135      setCharacteristic( c, 2);
1136      CanonicalForm F( convSingGFClapGF( (poly)h->Data() ) );
1137      res->rtyp=POLY_CMD;
1138      res->data=convClapGFSingGF( F );
1139      return FALSE;
1140    }
1141    else
1142#endif
1143/*==================== stdX =================*/
1144    if (strcmp(sys_cmd, "std") == 0)
1145    {
1146      ideal i1;
1147      int i2;
1148      if ((h!=NULL) && (h->Typ()==MODUL_CMD))
1149      {
1150        i1=(ideal)h->CopyD();
1151        h=h->next;
1152      }
1153      else return TRUE;
1154      if ((h!=NULL) && (h->Typ()==INT_CMD))
1155      {
1156        i2=(int)h->Data();
1157      }
1158      else return TRUE;
1159      res->rtyp=MODUL_CMD;
1160      res->data=idXXX(i1,i2);
1161      return FALSE;
1162    }
1163    else
1164#ifdef HAVE_UNITS
1165/*==================== units ==================================*/
1166    if(strcmp(sys_cmd,"invunit")==0)
1167    {
1168      return invunit(res,h);
1169    }
1170    else
1171    if(strcmp(sys_cmd,"series")==0)
1172    {
1173      return series(res,h);
1174    }
1175    else
1176    if(strcmp(sys_cmd,"rednf")==0)
1177    {
1178      return rednf(res,h);
1179    }
1180    else
1181#endif
1182#ifdef HAVE_PLURAL
1183/*==================== PLURAL =================*/
1184    if (strcmp(sys_cmd, "PLURAL") == 0)
1185    {
1186      matrix C;
1187      matrix D;
1188
1189      if ((h!=NULL) && (h->Typ()==MATRIX_CMD))
1190      {
1191        C=(matrix)h->CopyD();
1192        h=h->next;
1193      }
1194      else return TRUE;
1195      if ((h!=NULL) && (h->Typ()==MATRIX_CMD))
1196      {
1197        D=(matrix)h->CopyD();
1198      }
1199      else return TRUE;
1200      if (currRing->nc==NULL)
1201      {
1202        currRing->nc=(nc_struct *)omAlloc0(sizeof(nc_struct));
1203        currRing->nc->MT=(matrix *)omAlloc0(pVariables*(pVariables-1)/2*sizeof(matrix));
1204        currRing->nc->MTsize=(int *)omAlloc0(pVariables*(pVariables-1)/2*sizeof(int));
1205      }
1206      else
1207      {
1208        WarnS("redefining algebra structure");
1209      }
1210      currRing->nc->type=nc_general;
1211      currRing->nc->C=C;
1212      currRing->nc->D=D;
1213      {
1214        int i,j;
1215        poly p;
1216        short DefMTsize=7;
1217        int nv=pVariables;
1218        for(i=1;i<nv;i++)
1219        {
1220          for(j=i+1;j<=nv;j++)
1221          { 
1222            currRing->nc->MTsize[UPMATELEM(i,j)]=DefMTsize; /* default sizes */
1223            currRing->nc->MT[UPMATELEM(i,j)]=mpNew(DefMTsize,DefMTsize);
1224            p=pOne();
1225            pSetCoeff(p,nCopy(pGetCoeff(MATELEM(currRing->nc->C,i,j))));
1226            pSetExp(p,i,1);
1227            pSetExp(p,j,1);
1228            pSetm(p);
1229            p=pAdd(p,pCopy(MATELEM(currRing->nc->D,i,j)));
1230            MATELEM(currRing->nc->MT[UPMATELEM(i,j)],1,1)=p;
1231            /* set MT[i,j,1,1] to c_i_j*x_i*x_j + D_i_j */
1232          }
1233        }
1234      }
1235      // set p_Procs:
1236//      currRing->p_Procs->pp_Mult_mm =nc_pp_Mult_mm;
1237//      currRing->p_Procs->p_Mult_mm =nc_p_Mult_mm;
1238//      currRing->p_Procs->p_Minus_mm_Mult_qq =nc_p_Minus_mm_Mult_qq;
1239
1240      return FALSE;
1241    }
1242    else
1243#endif
1244#ifdef HAVE_WALK
1245/*==================== walk stuff =================*/
1246    if (strcmp(sys_cmd, "walkNextWeight") == 0)
1247    {
1248      if (h == NULL || h->Typ() != INTVEC_CMD ||
1249          h->next == NULL || h->next->Typ() != INTVEC_CMD ||
1250          h->next->next == NULL || h->next->next->Typ() != IDEAL_CMD)
1251      {
1252        Werror("system(\"walkNextWeight\", intvec, intvec, ideal) expected");
1253        return TRUE;
1254      }
1255
1256      if (((intvec*) h->Data())->length() != currRing->N ||
1257          ((intvec*) h->next->Data())->length() != currRing->N)
1258      {
1259        Werror("system(\"walkNextWeight\" ...) intvecs not of length %d\n",
1260               currRing->N);
1261        return TRUE;
1262      }
1263      res->data = (void*) walkNextWeight(((intvec*) h->Data()),
1264                                         ((intvec*) h->next->Data()),
1265                                         (ideal) h->next->next->Data());
1266      if (res->data == (void*) 0 || res->data == (void*) 1)
1267      {
1268        res->rtyp = INT_CMD;
1269      }
1270      else
1271      {
1272        res->rtyp = INTVEC_CMD;
1273      }
1274      return FALSE;
1275    }
1276    else if (strcmp(sys_cmd, "walkInitials") == 0)
1277    {
1278      if (h == NULL || h->Typ() != IDEAL_CMD)
1279      {
1280        WerrorS("system(\"walkInitials\", ideal) expected");
1281        return TRUE;
1282      }
1283
1284      res->data = (void*) walkInitials((ideal) h->Data());
1285      res->rtyp = IDEAL_CMD;
1286      return FALSE;
1287    }
1288    else
1289#endif
1290
1291/*==================== Error =================*/
1292      Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
1293  }
1294  return TRUE;
1295}
1296#endif // HAVE_EXTENDED_SYSTEM
Note: See TracBrowser for help on using the repository browser.