Artifact 279c2c824f18eb3473d0487499f839913fc6cff44d3df64b33e3d48a5bab5cfc:
- Executable file
r37/packages/cali/red.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12068) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/cali/red.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12068) [annotate] [blame] [check-ins using]
module red; COMMENT ################# ## ## ## NORMAL FORM ## ## ALGORITHMS ## ## ## ################# This module contains normal form algorithms for base elements. All reductions executed on the dpoly part, are repeated on the rep part, hence tracing them up for further use. We do pseudoreduction, but organized following up the multipliers in a different way than in the version 2.1 : For total reduction we hide terms prefixing the current lead term on the negative slots of the rep part. This allows not to follow up the multipliers, since head terms are multiplied automatically. If You nevertheless need the multipliers, You can prepare the base elements with "red_prepare" to keep track of them using the 0-slot of the rep-part : f --> (f,e_0) -NF-> (f',z*e_0) --> (f' . z) Extract the multiplier back with "red_extract". This allows a unified treating of the multipliers for both noetherian and non noetherian term orders. For NF : [f,r] |--> [f',r'] using B={[f_i,r_i]} with representation parts r, r_i we get f' = z*f + \sum a_i*f_i r' = z*r + \sum a_i*r_i The output trace intensity can be managed with cali_trace() that has the following meaning : cali_trace() >= 0 no trace 10 '.' for each substitution 70 trace interreduce!* 80 trace redpol 90 show substituents The reduction strategy is first matching in the simplifier (base) list. It can be changed overloading red_better, the relation according to what base lists are sorted. Standard is minimal ecart, breaking ties with minimal length (since such a strategy is good for both the classical and the local case). There are two (head) reduction functions, the usual one and one, that allows reduction only by reducers with bounded ecart, i.e. where the ecart of the reducer is leq the ecart of the poly to be reduced. This allows a unified handling of noetherian and non-noetherian term orders. Switches : red_total : t compute total normal forms nil reduce only until lt is standard bcsimp : t apply bas_simp END COMMENT; % Standard is : !*red_total:=t; !*bcsimp:=t; symbolic procedure red_better(a,b); % Base list sort criterion. Simplifier lists are sorted such that the % best substituent comes first. Due to reduction with bounded ecart we % need no more lowest ecarts first. bas_dplen a < bas_dplen b; % ---- Preparing data for collecting multipliers --- symbolic procedure red_prepare model; % Prepare the zero rep-part to follow up multipliers % in the pseudoreductions. % if !*binomial then model else bas_make1(bas_nr model,bas_dpoly model, dp_sum(bas_rep model,dp_from_ei 0)); symbolic procedure red_extract model; % Returns (model . dpoly), extracting the multiplier part from the % zero rep-part. % if !*binomial then (model . dp_fi 1) else (bas_make1(bas_nr model, bas_dpoly model, dp_diff(bas_rep model,z)) . z where z=dp_comp(0,bas_rep model)); % -------- Substitution operations ---------------- symbolic procedure red_subst(model,basel); % model and basel = base elements % Returns a base element, such that % pol_new := z * pol_old - z1 * mo * f_a % rep_new := z * rep_old - z1 * mo * rep_a % with appropriate base coeff. z and z1 and monomial mo. % if !*binomial then red!=subst2(model,basel) else red!=subst1(model,basel); symbolic procedure red!=subst1(model,basel); begin scalar polold,polnew,repold,repnew,gcd,mo,fa,z,z1; polold:=bas_dpoly model; z1:=dp_lc polold; repold:=bas_rep model; fa:=bas_dpoly basel; z:= dp_lc fa; if !*bcsimp then % modify z and z1 if (gcd:=bc_inv z) then << z1:=bc_prod(z1,gcd); z:=bc_fi 1 >> else << gcd:=bc_gcd(z,z1); z:=car bc_divmod(z,gcd); z1:=car bc_divmod(z1,gcd) >>; mo:=mo_diff(dp_lmon polold,dp_lmon fa); polnew:=dp_diff(dp_times_bc(z,polold), dp_times_bcmo(z1,mo,fa)); repnew:=dp_diff(dp_times_bc(z,repold), dp_times_bcmo(z1,mo,bas_rep basel)); if cali_trace() > 79 then << prin2 "---> "; dp_print polnew >> else if cali_trace() > 0 then prin2 "."; if cali_trace() > 89 then << prin2 " uses "; dp_print fa >>; return bas_make1(bas_nr model,polnew,repnew); end; symbolic procedure red!=subst2(model,basel); % Only for binomials without representation parts. begin scalar m,b,u,r; if cali_trace()>0 then prin2 "."; m:=bas_dpoly model; b:=bas_dpoly basel; if (length b neq 2) or bas_rep model then rederr"switch off binomial"; u:=mo_qrem(dp_lmon m,dp_lmon b); r:=list dp_term(dp_lc m, mo_sum(mo_power(dp_lmon cdr b,car u),cdr u)); return bas_make(bas_nr model,dp_sum(r,cdr m)); end; % ---------------- Top reduction ------------------------ symbolic procedure red_TopRedBE(bas,model); % Takes a base element model and returns it top reduced with bounded % ecart. if (null bas_dpoly model) or (null bas) then model else begin scalar v,q; if cali_trace()>79 then << write" reduce "; dp_print bas_dpoly model >>; while (q:=bas_dpoly model) and (v:=red_divtestBE(bas,dp_lmon q,bas_dpecart model)) do model:=red_subst(model,v); return model; end; symbolic procedure red_divtestBE(a,b,e); % Returns the first f in the base list a, such that lt(f) | b % and ec(f)<=e, else nil. b is a monomial. if null a then nil else if (bas_dpecart(car a) <= e) and mo_vdivides!?(dp_lmon bas_dpoly car a,b) then car a else red_divtestBE(cdr a,b,e); symbolic procedure red_divtest(a,b); % Returns the first f in the base list a, such that lt(f) | b else nil. % b is a monomial. if null a then nil else if mo_vdivides!?(dp_lmon bas_dpoly car a,b) then car a else red_divtest(cdr a,b); symbolic procedure red_TopRed(bas,model); % Takes a base element model and returns it top reduced. % For noetherian term orders this is the classical top reduction; no % additional simplifiers occur. For local term orders it is Mora's % reduction by minimal ecart. if (null bas_dpoly model) or (null bas) then model else begin scalar v,q; % Make first reduction with bounded ecart. model:=red_TopRedBE(bas,model); % Now loop into reduction with minimal ecart. while (q:=bas_dpoly model) and (v:=red_divtest(bas,dp_lmon q)) do << v:=red_subst(model,v); if not !*noetherian then bas:=red_update(bas,model); model:=red_TopRedBE(bas,v); >>; return model; end; % Management of the simplifier list. Has a meaning only in the % non noetherian case. symbolic procedure red_update(simp,b); % Update the simplifier list simp with the base element b. begin if cali_trace()>59 then << terpri(); write "[ec:",bas_dpecart b,"] ->"; dp_print2 bas_dpoly b >> else if cali_trace()>0 then write"*"; return merge(list b, for each x in simp join if red!=cancelsimp(b,x) then nil else {x}, function red_better); end; symbolic procedure red!=cancelsimp(a,b); % Test for updating the simplifier list. red_better(a,b) and mo_vdivides!?(dp_lmon bas_dpoly a,dp_lmon bas_dpoly b); % ------------- Total reduction and Tail reduction ----------- Comment For total reduction one has to organize recursive calls of TopRed on tails of the current model. Since we do pseudoreduction, we have to multiply the prefix terms with the multiplier during recursive calls. We do that, hiding the prefix terms on rep part components with negative component number. Retrival may be done not recursively, but in a single step. end Comment; symbolic procedure red!=hide p; % Hide the terms of the dpoly p. This is involutive ! for each x in p collect (mo_times_ei(-1,mo_neg car x) . cdr x); symbolic procedure red!=hideLt model; bas_make1(bas_nr model,cdr p, dp_sum(bas_rep model, red!=hide({car p}))) where p=bas_dpoly model; symbolic procedure red!=recover model; % The dpoly part of model is empty, but the rep part contains % hidden terms. begin scalar u,v; for each x in bas_rep model do if mo_comp car x < 0 then u:=x.u else v:=x.v; return bas_make1(bas_nr model, dp_neworder reversip red!=hide u, reversip v); end; symbolic procedure red_TailRedDriver(bas,model,redfctn); % Takes a base element model and reduces the tail with the % top reduce "redfctn" recursively. if (null bas_dpoly model) or (null cdr bas_dpoly model) or (null bas) then model else begin while bas_dpoly model do model:=apply2(redfctn,bas,red!=hideLt(model)); return red!=recover(model); end; symbolic procedure red_TailRed(bas,model); % The tail reduction as we understand it at the moment. if !*noetherian then red_TailRedDriver(bas,model,function red_TopRed) else red_TailRedDriver(bas,model,function red_TopRedBE); symbolic procedure red_TotalRed(bas,model); % Make a terminating total reduction, i.e. for noetherian term orders % the classical one and for local term orders tail reduction with % bounded ecart. red_TailRed(bas,red_TopRed(bas,model)); % ---------- Reduction of the straightening parts -------- symbolic procedure red_Straight(bas); % Autoreduce straightening formulae of the base list bas, classical % in the noetherian case and with bounded ecart in the local case. begin scalar u; u:=for each x in bas collect red_TailRed(bas,x); if !*bcsimp then u:=bas_simp u; return sort(u,function red_better); end; symbolic procedure red_collect bas; % Returns ( bas1 . bas2 ), where bas2 may be reduced with bas1. begin scalar bas1,bas2; bas1:=listminimize(bas,function (lambda(x,y); mo_vdivides!?(dp_lmon bas_dpoly x,dp_lmon bas_dpoly y))); bas2:=setdiff(bas,bas1); return bas1 . bas2; end; symbolic procedure red_TopInterreduce m; % Reduce rows of the base list m with red_TopRed until it has pairwise % incomparable leading terms % Compute correct representation parts. Do no tail reduction. begin scalar c,w,bas1; m:=bas_sort bas_zerodelete m; if !*bcsimp then m:=bas_simp m; while cdr (c:=red_collect m) do << if cali_trace()>69 then <<write" interreduce ";terpri();bas_print m>>; m:=nil; w:=cdr c; bas1:=car c; while w do << c:=red_TopRed(bas1,car w); if bas_dpoly c then m:=c . m; w:=cdr w >>; if !*bcsimp then m:=bas_simp m; m:=merge(bas1,bas_sort m,function red_better); >>; return m; end; % ----- Interface to the former syntax -------------- symbolic procedure red_redpol(bas,model); % Returns (reduced model . multiplier) begin scalar m; m:=red_prepare model; return red_extract (if !*red_total then red_TotalRed(bas,m) else red_TopRed(bas,m)) end; symbolic procedure red_Interreduce m; % Applies to arbitrary term orders. begin % Top reduction, producing pairwise incomparable leading terms. m:=red_TopInterreduce m; if !*red_total then m:=red_Straight m; % Tail reduction : return m; end; endmodule; % red end;