source: git/Singular/extra.cc @ fc4782a

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