source: git/Singular/spSpolyLoop.pl @ 97a7b44

spielwiese
Last change on this file since 97a7b44 was bf53f8, checked in by Hans Schönemann <hannes@…>, 25 years ago
*hannes: fixes for p_.Order git-svn-id: file:///usr/local/Singular/svn/trunk@2763 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100755
File size: 16.6 KB
Line 
1#!/usr/local/bin/perl
2###########################################################################
3# $Id: spSpolyLoop.pl,v 1.9 1998-12-16 12:04:15 Singular Exp $
4
5###########################################################################
6##
7## FILE: spSpolyLoops.pl
8## PURPOSE: Generates spSpolyLoop's and spGetSpolyLoop as specified by
9## variable @input. Writes result to stdout, warning/errors to stderr.
10## AUTHOR: obachman (3/98)
11##
12
13###########################################################################
14##
15## How to add/modify generation of spSpolyLoops
16##
17
18# 1.) Add property/characterisitc to property specification and make
19# sure that property is checked for in spGetSpolyLoop(...) in
20# spSpolyLoop.cc
21#
22# 2.) Modify macros of spSpolyLoops so that approriate actions are taken
23# for new properties
24#
25# 3.) Add properties to check for in @input
26
27
28
29###########################################################################
30##
31## Supporting procedures
32##
33
34sub Warning
35{
36  print STDERR $_[0], "\n";
37}
38
39
40# Each occureence of CALL_<fn>(...) in $string is replaced by
41# `eval fn(..., $argv)'. Modified string is returned.
42sub Expand
43{
44  local($string, $argv) = @_;
45  local(@lines, @call, $call, $prefix, $postfix, $whitespaces, $result);
46  local($i, $j);
47
48  @lines = split(/\n/, $_[0]);
49  for ($i = 0; $i <= $#lines; $i++)
50  {
51    if ($lines[$i] =~ /CALL_/)
52    {
53      ($whitespaces, $prefix, $call, $postfix) = &ParseLine($lines[$i]);
54      #insert $argv as last argument to call
55      if ($call =~ /\(\s*\)$/)
56      {
57        $call =~ s/\(\s*\)$/\(\$argv\)/;
58      }
59      else
60      {
61        $call =~ s/\)$/\,\$argv\)/;
62      }
63      $call = "& ".$call.";";
64      $call = eval $call;
65      @call = split(/\n/,"$whitespaces$prefix$call$postfix");
66      for ($j=1; $j <= $#call; $j++)
67      {
68        $call[$j] = $whitespaces.$call[$j];
69      }
70      $lines[$i] = join("\n", @call);
71    }
72  }
73  $result = join("\n", @lines);
74  if ($call) 
75  {
76    return (&Expand($result));
77  }
78  else
79  {
80    return $result;
81  }
82}
83
84# takes a line containing CALL_ apart into and returns
85# ($whitespace, $prefix, $call, $postfix)
86sub ParseLine
87{
88  local($line) = @_;
89  local($i, $c_start, $c_length, $bcount);
90  local($whitespace, $prefix, $call, $postfix);
91 
92  while(substr($line, $i, 1) =~ /\s/ && $i <= length($line))
93  {
94    $whitespace = $whitespace.substr($line, $i, 1);
95    $i++;
96  }
97 
98  while(substr($line, $i) !~ /^CALL_/  && $i <= length($line))
99  {
100    $prefix = $prefix.substr($line, $i, 1);
101    $i++;
102  }
103 
104  $i = $i+5;
105  $c_start = $i;
106  while(substr($line, $i, 1) ne "(" && $i <= length($line))
107  {
108    $i++;
109  }
110  if (substr($line, $i, 1) eq "(")
111  {
112    $bcount = 1;
113    $i++;
114    while ($bcount > 0 && $i <= length($line))
115    {
116      if (substr($line, $i, 1) eq ")")
117      {
118        $bcount--;
119      }
120      elsif (substr($line, $i, 1) eq "(")
121      {
122        $bcount++;
123      }
124      elsif (substr($line, $i, 1) eq "\"")
125      {
126        $i++;
127        while ((substr($line, $i, 1) ne "\"" || 
128                substr($line, $i-1, 1) eq "\\") && 
129               $i <= length($line))
130        {
131          $i++;
132        }
133      }
134      $i++;
135    }
136  }
137  $call = substr($line, $c_start, $i - $c_start);
138  $postfix = substr($line, $i);
139  return ($whitespace, $prefix, $call, $postfix);
140}
141
142
143###########################################################################
144##
145## Specification of the properties which determine an spSpolyLoop
146##
147## Properties need to have following syntax: propVAL, where prop is
148## short "prefix" name of properties, and needs to be in lower caps, and
149## VAL is possible value and needs to be in all upper caps.
150##
151## Furthermore, observe the following conventions
152## @Protperty = ("propGEN", "propVAL1", ...)
153## $EnumType{prop} = Property
154## GetProperty($string) should always return a valid value.
155
156## need to hard-wire properties here, because they are needed in the interface to surrounding C++-code:
157
158@Properties = ("ch", "ot", "hom", "nw");
159@Characteristics = ("chGEN", "chMODP");
160$EnumType{"ch"} = "Characteristics";
161sub GetCharacteristic
162{
163  foreach $element (split('_', $_[0]))
164  {
165    return ($element) if ($element =~ /^ch/ && 
166                          grep(/$element/, @Characteristics));
167  }
168  return $Characteristics[0];
169}
170 
171@OrderingTypes = ("otGEN", "otEXP", "otCOMPEXP", "otEXPCOMP");
172$EnumType{"ot"} = "OrderingTypes";
173sub GetOrderingType
174{
175  foreach $element (split('_', $_[0]))
176  {
177    return ($element) if ($element =~ /^ot/ && 
178                         grep(/$element/, @OrderingTypes));
179  }
180  return $OrderingTypes[0];
181}
182
183@Homogs = ("homGEN", "homYES"); 
184$EnumType{"hom"} = "Homogs";
185sub GetHomog
186{
187  foreach $element (split('_', $_[0]))
188  {
189    return ($element) if ($element =~ /^hom/ &&
190                          grep(/$element/, @Homogs));
191  }
192  return $Homogs[0];
193}
194
195@NumWords = ("nwGEN", "nwONE", "nwTWO", "nwEVEN", "nwODD");
196$EnumType{"nw"} = "NumWords";
197sub GetNumWords
198{
199  foreach $element (split('_', $_[0]))
200  {
201    return ($element) if ($element =~ /^nw/ &&
202                          grep(/$element/, @NumWords));
203  }
204  return $NumWords[0];
205}
206
207# given a list of "short" prefix properties, generate enumeration type
208# specification for each property
209sub Generate_EnumTypes
210{
211  local(@evalues, $source);
212 
213  foreach $key (@_)
214  {
215    $etype = $EnumType{$key};
216    if ($etype =~ /\w+/)
217    {
218      @evalues = eval '@'.$etype;
219      if ($#evalues >= 0)
220      {
221        $source = $source."typedef enum $etype {". $evalues[0] . " = 0";
222        shift @evalues;
223        foreach $evalue (@evalues)
224        {
225          $source = $source.", $evalue";
226        }
227        $source = $source."} $etype;\n";
228      }
229      else
230      {
231        & Warning("No enum values for type: $etype");
232      }
233    }
234    else
235    {
236      & Warning("Unknown enumeration type index: $key");
237    }
238  }
239  return $source;
240}
241
242###########################################################################
243##
244## Template of the spSpolyLoop
245## Is modified by Expand
246##
247
248$spSpolyLoopBodyTemplate = <<_EOT_
249(poly a1, poly a2, poly monom, poly spNoether)
250{
251  poly a = monom,                         // collects the result
252       b = NULL,                          // stores a1*monom
253       c;                                 // used for temporary storage
254  number tm   = pGetCoeff(monom),         // coefficient of monom
255         tneg = CALL_NCOPYNEG(tm),        // - (coefficient of monom)
256         tb,                              // used for tm*coeff(a1)
257         tc;                              // used for intermediate coeff
258
259  Order_t order;                          // used for homog case
260
261  if (a2==NULL) goto Finish;              // we are done if a2 is 0
262  b = pNew();   
263
264  CALL_INITORDER(order, a2);              // inits order for homog case
265 
266
267  CALL_PCOPYADDFAST(b, a1, monom, order);  // now a2 != NULL -- set up b
268
269  // MAIN LOOP:
270  Top:     // compare b = monom*a1 and a2 w.r.t. monomial ordering
271    register long d;
272    CALL_COMPARE(b, a2, d);
273
274  Equal:   // b equals a2
275    assume(pComp0(b, a2) == 0);
276    tb = CALL_NMULT("pGetCoeff(a1)",tm);
277    tc = pGetCoeff(a2);
278    if (!CALL_NEQUAL(tc,tb))
279    {
280      tc=CALL_NSUB(tc, tb);
281      CALL_NDELETE("&pGetCoeff(a2)");
282      pSetCoeff0(a2,tc); // adjust coeff of a2
283      a = pNext(a) = a2; // append a2 to result and advance a2
284      pIter(a2);
285    }
286    else
287    { // coeffs are equal, so their difference is 0:
288      c = a2;  // do not append anything to result: Delete a2 and advance
289      pIter(a2);
290      CALL_NDELETE("&tc");
291      pFree1(c);
292    }
293    CALL_NDELETE("&tb");
294    pIter(a1);
295    if (a2 == NULL || a1 == NULL) goto Finish; // are we done ?
296    CALL_PCOPYADDFAST(b, a1, monom, order); // No! So, get new b = a1*monom
297    goto Top;
298
299  NotEqual:     // b != a2
300    if (d < 0)  // b < a2:
301    {
302      assume(pComp0(b, a2) == -1);
303      a = pNext(a) = a2;// append a2 to result and advance a2
304      pIter(a2);
305      if (a2==NULL) goto Finish;;
306      goto Top;
307    }
308    else // now d >= 0, i.e., b > a2
309    {
310      assume(pComp0(b, a2) == 1);
311      pSetCoeff0(b,CALL_NMULT("pGetCoeff(a1)",tneg));
312      a = pNext(a) = b;       // append b to result and advance a1
313      pIter(a1);
314      if (a1 == NULL)         // are we done?
315      {
316        b = pNew();
317        goto Finish;
318      }
319      b = pNew();
320      CALL_PCOPYADDFAST(b, a1, monom, order); // No! So, update b = a1*monom
321      goto Top;
322    }
323 
324 Finish: // a1 or a2 is NULL: Clean-up time
325   assume(a1 == NULL || a2 == NULL);
326   if (a1 == NULL) // append rest of a2 to result
327     pNext(a) = a2;
328   else  // append (- a1*monom) to result
329     CALL_MULTCOPYX(a1, monom, a, tneg, spNoether);
330   CALL_NDELETE("&tneg");
331   if (b != NULL) pFree1(b);
332}
333
334_EOT_
335  ;
336
337###########################################################################
338##
339## "Macros" needed in expansion of spSpolyLoop
340##
341sub NCOPYNEG
342{
343  local($number, $argv) = @_;
344 
345  return "npNegM($number)" if (& GetCharacteristic($argv) eq "chMODP");
346  return "nNeg(nCopy($number))";
347}
348
349sub NDELETE
350{
351  local($number, $argv) = @_;
352 
353  return "" if (& GetCharacteristic($argv) eq "chMODP");
354  return "nDelete($number)";
355}
356
357sub NMULT
358{
359  local($m1, $m2, $argv) = @_;
360 
361  return "npMultM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
362  return "nMult($m1, $m2)";
363}
364
365sub NSUB
366{
367  local($m1, $m2, $argv) = @_;
368 
369  return "npSubM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
370  return "nSub($m1, $m2)";
371}
372
373sub NEQUAL
374{
375  local($m1, $m2, $argv) = @_;
376 
377  return "npEqualM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
378  return "nEqual($m1, $m2)";
379} 
380
381sub MULTCOPYX
382{
383  local($p, $monom, $n, $exp, $spNoether, $argv) = @_;
384 
385  return "spMultCopyX($p, $monom, $n, $exp, $spNoether)" 
386    if (& GetCharacteristic($argv) eq "chMODP");
387  return "spGMultCopyX($p, $monom, $n, $exp, $spNoether)";
388}
389
390sub INITORDER
391{
392  local($order, $p, $argv) = @_;
393 
394  return "$order = pGetOrder($p)" if (&GetHomog($argv) eq "homYES");
395  return "";
396}
397
398 
399sub PCOPYADDFAST
400{
401  local($p1, $p2, $p3, $order, $argv) = @_;
402 
403  return "pCopyAddFastHomog($p1, $p2, $p3, $order)" 
404    if (&GetHomog($argv) eq "homYES");
405  return "pCopyAddFast0($p1, $p2, $p3)";
406}
407
408###########################################################################
409##
410## COMPARE "macro": Besides generating th source code which
411## accomplishes monomial comparisons, it also generates the (global)
412## string $rargv charcaterising the generated spSpolyLoop
413##
414sub COMPARE
415{
416  local($p1, $p2, $d, $argv) = @_;
417  local($ot, $hom, $nw, $res);
418 
419  $rargv = &GetCharacteristic($argv);
420  $ot = &GetOrderingType($argv);
421  $rargv =  $rargv."_".$ot;
422  if ($ot eq "otCOMPEXP" ||
423      $ot eq "otEXPCOMP" ||
424      $ot eq "otEXP")
425  {
426    if ($ot eq "otCOMPEXP")
427    {
428      $res = "$d = pGetComp($p2) - pGetComp($p1);\n";
429      $res = $res."NonZeroTestA($d, pComponentOrder, goto NotEqual);\n";
430      $ot = "otEXP";
431    }
432    $hom = &GetHomog($argv);
433    $rargv =  $rargv."_".$hom;
434    if ($hom ne "homYES")
435    {
436      $res = $res."$d = pGetOrder($p1) - pGetOrder($p2);\n";
437      $res = $res."NonZeroTestA($d, pOrdSgn, goto NotEqual);\n";
438    }
439#     $rargv =  $rargv."_nwGEN";
440#     $res = join("_", $res, pMonComp, $ot, "nwGEN");
441#     $res = $res."($p1, $p2, pVariables1W, $d, NonZeroA($d, pLexSgn, goto NotEqual ), goto Equal);";
442     $nw = &GetNumWords($argv);
443     $rargv =  $rargv."_".$nw;
444     $res = join("_", $res, pMonComp, $ot, $nw);
445     if ($nw eq "nwONE" || $nw eq "nwTWO")
446     {
447       $res = $res."($p1, $p2, $d, NonZeroA($d, pLexSgn, goto NotEqual ), goto Equal);" 
448     }
449     else
450     {
451       $res = $res."($p1, $p2, pVariables1W, $d, NonZeroA($d, pLexSgn, goto NotEqual ), goto Equal);";
452     }
453    return $res;
454  }
455  else
456  {
457    # general ordering type
458    return ("if (($d = pComp0($p1, $p2))) goto NotEqual; else goto Equal;");
459  }
460}
461
462
463###########################################################################
464##
465## Generates an spSpolyLoop from a given "$argv" input string,
466## i.e. property string
467##
468## Returns spSpolyLoop and sets global associative array
469## $loops{$rargv} to generated loop.
470##
471
472sub Generate_SpolyLoop
473{
474  local($argv)= @_;
475  local($loopbody);
476
477  $loopbody = &Expand($spSpolyLoopBodyTemplate, $argv);
478
479  & Warning("Can not realize $argv: Changed to $rargv") if ($argv ne $rargv);
480
481  if (grep(/$rargv/, keys(%loops)))
482  {
483    & Warning("Duplicate entry $rargv: Ignoring $argv");
484    return;
485  }
486  else
487  {
488    $loops{$rargv} = "static void spSpolyLoop_$rargv\n$loopbody\n";
489    return ($loops{$rargv});
490  }
491}
492
493#gnerates SpolyLoops from array of $argv strings
494sub Generate_SpolyLoops
495{
496  local(%loops);
497 
498  foreach $argv (@_)
499  {
500    & Generate_SpolyLoop($argv);
501  }
502  return (%loops);
503}
504
505###########################################################################
506##
507## Generates array of $argv strings from a given input string by
508## "orthoganization", i.e. komma-separated entries in input string are
509## replaced by two argv strings containing the respective entrie.
510##
511
512sub FlattenInputString
513{
514  local($str) = @_;
515 
516  if ($str =~ /_/)
517  {
518    local(@parts, $head, @subresults, @result);
519    @parts = split(/_/, $str);
520    $head = shift(@parts);
521    @subresults = &FlattenInputString(join("_", @parts));
522    foreach $part (split(/,/, $head))
523    {
524      foreach $subresult (@subresults)
525      {
526        @result = (@result, $part."_".$subresult);
527      }
528    }
529    return (@result);
530  }
531  return (split(/,/, $str));
532}
533
534# generate array of $argv strings from array of input strings
535sub FlattenInput
536{
537  local(@result);
538  foreach $entry (@_)
539  {
540    $entry =~ s/\s//;
541    @result = (@result, & FlattenInputString($entry));
542  }
543  return @result;
544}
545
546
547###########################################################################
548##
549## GetSpolyLoop routines
550## They all work on valid $argv strings, only.
551##
552
553## Given a $prefix and an array of $argv's, return all the "next"
554## values, i.e. strings deliminted by $prefix and next '_'.
555sub GetNextKeys
556{
557  local($prefix, @values, $value);
558 
559  $prefix = shift(@_);
560  $prefix = $prefix."_" unless ($prefix eq "");
561  foreach $element (@_)
562  {
563    if ($prefix eq "")
564    {
565      ($value = $element) =~ s/^([a-zA-Z]*)(\w*)/\1/;
566      @values = ($value, @values) unless grep(/^$value$/, @values);
567    }
568    elsif ($element =~ /^$prefix/)
569    {
570      ($value = $element) =~ s/^($prefix)([a-zA-Z]*)(\w*)/\2/;
571      @values = ($value, @values) unless grep(/^$value$/, @values);
572    }
573  }
574  return @values;
575}
576
577# recursively generates "GetSpolyLoop" by working through all $argv's
578# which math $prefix
579# Sets $checks{$prefix}, if $prefix eq $argv
580sub GenerateBody_GetSpolyLoop
581{
582  local($prefix, $nextprefix, $source, $newsource, $prop, $curr_prop, $gen_key);
583 
584  $prefix = shift(@_);
585 
586  #check for exact match -- then we are done
587  if (grep(/^$prefix$/, @_))
588  {
589    $checks{$prefix} = "return spSpolyLoop_$prefix;\n";
590    return ($checks{$prefix});
591  }
592 
593  foreach $key (& GetNextKeys($prefix, @_))
594  {
595    if ($key =~ /\w+/)
596    {
597      # get prop,
598      ($prop = $key) =~ s/([a-z]*)([A-Z]*)/\1/;
599      #check prop against exiting ones
600      if ($curr_prop)
601      {
602        if ($prop ne $curr_prop)
603        {
604          & Warning("Different propes at same level: $prop : $curr_prop");
605          next;
606        }
607      }
608      else
609      {
610        $curr_prop = $prop;
611      }
612      # delay handling of "GEN" field
613      if ($key =~ /GEN/)
614      {
615        $gen_key = $key;
616        next;
617      }
618      # let's work recursively
619      if ($prefix eq "")
620      {
621        $nextprefix = $key;
622      }
623      else
624      {
625        $nextprefix = $prefix."_".$key;
626      }
627      $newsource=&GenerateBody_GetSpolyLoop($nextprefix,grep(/$nextprefix/,@_));
628      if ($newsource)
629      {
630        $source = $source."if ($prop == $key)\n{\n".$newsource."}\n";
631      }
632    }
633  }
634 
635  # take care of general key, if it exists
636  if ($gen_key)
637  {
638    $gen_key  = $prefix."_".$gen_key unless ($prefix eq "");
639    $source = $source . &GenerateBody_GetSpolyLoop($gen_key,grep(/$gen_key/,@_));
640  }
641  return ($source);
642}
643
644
645sub Generate_GetSpolyLoop
646{
647  local($header);
648 
649  $header = "static spSpolyLoopProc spGetSpolyLoop(";
650 
651  foreach $key (@Properties)
652  {
653    $etype = $EnumType{$key};
654    if ($etype =~ /\w+/)
655    {
656      $header = $header."$etype $key,";
657    }
658  }
659  chop($header);
660 
661  return ($header. 
662          ")\n{\n" . 
663          &GenerateBody_GetSpolyLoop("", @_). 
664          "return NULL;\n}\n");
665}
666
667###########################################################################
668##
669## Input Specification
670##
671
672@input = ("chMODP".
673          "_otEXP,otCOMPEXP,otEXPCOMP".
674          "_homGEN,homYES".
675          "_nwONE,nwTWO,nwEVEN,nwODD",
676# this does not seem to pay off -- general loop seems to be better
677#           "chGEN".
678#           "_otEXP,otCOMPEXP,otEXPCOMP".
679#         "_homGEN".
680#           "_nwGEN"
681         );
682
683
684###########################################################################
685##
686## Main program
687##
688
689#flatten out input
690@finput = &FlattenInput(@input);
691
692#generate loops
693%loops = & Generate_SpolyLoops(@finput);
694
695# Generate GetSpolyLoop based on generated loops
696$getspolyloop = & Generate_GetSpolyLoop(sort(keys(%loops)));
697
698# Output results
699print & Generate_EnumTypes(@Properties);
700
701foreach $key (sort(keys(%checks)))
702{
703  print $loops{$key};
704}
705
706print $getspolyloop;
707
Note: See TracBrowser for help on using the repository browser.