source: git/Singular/spSpolyLoop.pl @ 2c694a2

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