source: git/Singular/extra.cc @ 1f591a

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