123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102 |
- module disjoin;
- % Convert a variety to a disjoint union of sub-coframings
- % Author: David Hartley
- fluid '(!*edsverbose !*edsdebug !*arbvars !*varopt !*groebopt
- !*solveinconsistent depl!* cfrmcrd!* cfrmrsx!* xvars!*
- !*edssloppy !*edsdisjoint);
- Comment. The edsdisjoin routines decompose a solution returned by
- eds*solve into a disjoint union of solutions (rmaps). The operations
- intersection and difference are somewhat slow, so the whole process is
- only performed automatically if the switch edsdisjoint is on.
- endcomment;
- symbolic operator disjoin;
- symbolic procedure disjoin u;
- (makelist foreach rm in
- edsdisjoin(foreach s in getrlist u collect !*a2rmap s) collect
- !*rmap2a rm) where !*edsdisjoint = t;
- symbolic procedure edsdisjoin u;
- % u:list of rmap -> edsdisjoin:list of rmap
- if !*edsdisjoint then reverse edsdisjoin1(u,{}) else u;
- symbolic procedure edsdisjoin1(u,v);
- % u,v:list of rmap -> edsdisjoin1:list of rmap
- % rmaps in v are disjoint already.
- if null u then v
- else edsdisjoin1(cdr u,edsdisjoin2(car u,v));
- symbolic procedure edsdisjoin2(x,v);
- % x:rmap, v:list of rmap -> edsdisjoin2:list of rmap
- % rmaps in v are disjoint already.
- if null v then {x}
- else
- begin scalar y,z;
- y := car v;
- return
- if z := rmapintersection(x,y) then
- append(rmapdifference(y,x),
- append(z,edsdisjoin1(rmapdifference(x,y),cdr v)))
- else
- y . edsdisjoin2(x,cdr v);
- end;
- symbolic procedure rmapintersection(x,y);
- % x,y:rmap -> rmapintersection:list of rmap
- begin scalar lhx,xl,z,rsx,rsy,mx,my;
- % First a simple check which may save us going into solve
- rsy := pullbackrsx(cadr y,car x);
- if 0 member rsy then return nil;
- rsx := pullbackrsx(cadr x,car y);
- if 0 member rsx then return nil;
- % Now just pile everything together and resolve
- return rmapeval {append(car x,car y),append(rsx,rsy)};
- end;
- symbolic procedure rmapdifference(x,z);
- % x,z:rmap -> rmapdifference:list of rmap
- % NO LONGER assumes z is a sub-coframing of x
- begin scalar m;
- m := foreach s in car z join
- if s := numr subsq(subtrsq(simp!* car s,simp!* cdr s),car x)
- then rmapeval {car x,addrsx(s,cadr x)};
- m := append(m,
- foreach s in cadr z join
- rmapeval {(0 . s) . car x,cadr x});
- return edsdisjoin purge m;
- end;
- symbolic procedure rmapeval x;
- % x:rmap -> rmapeval:list of rmap
- % Resolve a badly formed rmap into a disjoint list of rmaps.
- % The map part of x may include equations expr=expr.
- begin scalar xl,vl;
- % First resolve map part, solving for lhs variables where possible
- vl := purge foreach s in car x collect car s;
- vl := {intersection(cfrmcrd!*,vl),setdiff(cfrmcrd!*,vl)};
- xl := foreach s in car x collect
- subtrsq(simp!* car s,simp!* cdr s);
- return foreach s in edssolvegraded(xl,vl,cadr x) collect
- if car s then cdr s
- else
- << lprim "Could not resolve decomposition entirely";
- {foreach q in cdr s collect 0 . mk!*sq q,cadr x} >>;
- end;
-
- endmodule;
- end;
|