reduce-historical/r38/packages/algint/places.red

MODULE PLACES;
 
% Author: James H. Davenport.
 
FLUID '(BASIC!-LISTOFALLSQRTS
        BASIC!-LISTOFNEWSQRTS
        INTVAR
        LISTOFALLSQRTS
        LISTOFNEWSQRTS
        SQRT!-INTVAR
        SQRT!-PLACES!-ALIST
        SQRTS!-IN!-INTEGRAND);
 
EXPORTS GETSQRTSFROMPLACES,SQRTSINPLACES,GET!-CORRECT!-SQRTS,BASICPLACE,
        EXTENPLACE,EQUALPLACE,PRINTPLACE;
 
 
 
% Function to manipulate places
% a place is stored as a list of substitutions
% substitutions (x.f(x)) define the algrbraic number
% of which this place is an extension,
% while places (f(x).g(x)) define the extension.
%    currently g(x( is list ('minus,f(x))
%       or similar,e.g. (sqrt(sqrt x)).(sqrt(-sqrt x)).

 
 
% Given a list of places, produces a list of all
% the SQRTs in it that depend on INTVAR.
SYMBOLIC PROCEDURE GETSQRTSFROMPLACES PLACES;
  % The following loop finds all the SQRTs for a basis,
  % taking account of BASICPLACEs.
BEGIN
  SCALAR BASIS,V,B,C,VV;
  FOR EACH U IN PLACES DO <<
    V:=ANTISUBS(BASICPLACE U,INTVAR);
    VV:=SQRTSINSQ (SUBSTITUTESQ(!*KK2Q INTVAR,V),INTVAR);
      % We must go via SUBSTITUTESQ to get parallel
      % substitutions performed correctly.
    IF VV
      THEN VV:=SIMP ARGOF CAR VV;
    FOR EACH W IN EXTENPLACE U DO <<
      B:=SUBSTITUTESQ(SIMP LSUBS W,V);
      B:=DELETE(SQRT!-INTVAR,SQRTSINSQ(B,INTVAR));
      FOR EACH U IN B DO
        FOR EACH V IN DELETE(U,B) DO
          IF DEPENDSP(V,U)
            THEN B:=DELETE(U,B);
	    % remove all the "inner" items, since they will
	    % be accounted for anyway.
      IF LENGTH B IEQUAL 1
        THEN B:=CAR B
 ELSE B:=MVAR NUMR SIMPSQRTSQ MAPPLY(FUNCTION !*MULTSQ,
                                FOR EACH U IN B COLLECT SIMP ARGOF U);
      IF VV AND NOT (B MEMBER SQRTS!-IN!-INTEGRAND)
        THEN <<
          C:=NUMR MULTSQ(SIMP ARGOF B,VV);
          C:=CAR SQRTSINSF(SIMPSQRT2 C,NIL,INTVAR);
   IF C MEMBER SQRTS!-IN!-INTEGRAND
            THEN B:=C >>;
      IF NOT (B MEMBER BASIS)
        THEN BASIS:=B.BASIS >> >>;
  % The following loop deals with the annoying case of, say,
  % (X DIFFERENCE X 1) (X EXPT X 2) which should give rise to
  % SQRT(X-1).
  FOR EACH U IN PLACES DO BEGIN
    V:=CDR U;
    IF NULL V OR (CAR RFIRSTSUBS V NEQ 'EXPT)
      THEN RETURN;
    U:=SIMP!* SUBST(LIST('MINUS,INTVAR),INTVAR,RFIRSTSUBS U);
    WHILE V AND (CAR RFIRSTSUBS V EQ 'EXPT) DO <<
      U:=SIMPSQRTSQ U;
      V:=CDR V;
      BASIS:=UNION(BASIS,DELETE(SQRT!-INTVAR,SQRTSINSQ(U,INTVAR))) >>
    END;
  RETURN REMOVE!-EXTRA!-SQRTS BASIS
  END;
 
 
 
SYMBOLIC PROCEDURE SQRTSINPLACES U;
% Note the difference between this procedure and
% the previous one: this one does not take account
% of the BASICPLACE component (& is pretty useless).
IF NULL U
  THEN NIL
  ELSE SQRTSINTREE(FOR EACH V IN CAR U COLLECT LSUBS V,
                   INTVAR,
                   SQRTSINPLACES CDR U);
 
 
 
%symbolic procedure placesindiv places;
% Given a list of places (i.e. a divisor),
% produces a list of all the SQRTs on which the places
% explicitly depend.
%begin scalar v;
%  for each u in places do
%    for each uu in u do
%      if not (lsubs uu member v)
%        then v:=(lsubs uu) . v;
%  return v
%  end;

 
 
SYMBOLIC PROCEDURE GET!-CORRECT!-SQRTS U;
% u is a basicplace.
BEGIN
  SCALAR V;
  V:=ASSOC(U,SQRT!-PLACES!-ALIST);
  IF V
    THEN <<
      V:=CDR V;
      LISTOFALLSQRTS:=CDR V;
      LISTOFNEWSQRTS:=CAR V
      >>
    ELSE <<
      LISTOFNEWSQRTS:=BASIC!-LISTOFNEWSQRTS;
      LISTOFALLSQRTS:=BASIC!-LISTOFALLSQRTS
      >>;
  RETURN NIL
  END;
 
 
 
%symbolic procedure change!-place(old,new);
%% old and new are basicplaces;
%begin
%  scalar v;
%  v:=assoc(new,sqrt!-places!-alist);
%  if v
%    then sqrtsave(cddr v,cadr v,old)
%    else <<
%      listofnewsqrts:=basic!-listofnewsqrts;
%      listofallsqrts:=basic!-listofallsqrts
%      >>;
%  return nil
%  end;

 
 
SYMBOLIC PROCEDURE BASICPLACE(U);
% Returns the basic part of a place.
IF NULL U
  THEN NIL
  ELSE IF ATOM CAAR U
    THEN (CAR U).BASICPLACE CDR U
    ELSE NIL;
 
 
 
SYMBOLIC PROCEDURE EXTENPLACE(U);
% Returns the extension part of a place.
IF U AND ATOM CAAR U
  THEN EXTENPLACE CDR U
  ELSE U;
 
 
 
SYMBOLIC PROCEDURE EQUALPLACE(A,B);
% Sees if two extension places represent the same place or not.
IF NULL A
  THEN IF NULL B
    THEN T
    ELSE NIL
  ELSE IF NULL B
    THEN NIL
    ELSE IF MEMBER(CAR A,B)
      THEN EQUALPLACE(CDR A,DELETE(CAR A,B))
      ELSE NIL;
 
 
 
SYMBOLIC PROCEDURE REMOVE!-EXTRA!-SQRTS BASIS;
BEGIN
  SCALAR BASIS2,SAVE;
  SAVE:=BASIS2:=FOR EACH U IN BASIS COLLECT !*Q2F SIMP ARGOF U;
  FOR EACH U IN BASIS2 DO
    FOR EACH V IN DELETE(U,BASIS2) DO
      IF QUOTF(V,U)
        THEN BASIS2:=DELETE(V,BASIS2);
  IF BASIS2 EQ SAVE
    THEN RETURN BASIS
    ELSE RETURN FOR EACH U IN BASIS2 COLLECT LIST('SQRT,PREPF U)
  END;
 
 
 
SYMBOLIC PROCEDURE PRINTPLACE U;
BEGIN
  SCALAR A,N,V;
  A:=RFIRSTSUBS U;
  PRINC (V:=LFIRSTSUBS U);
  PRINC "=";
  IF ATOM A
    THEN PRINC "0"
    ELSE IF (CAR A EQ 'QUOTIENT) AND (CADR A=1)
      THEN PRINC "infinity"
      ELSE <<
 N:=NEGSQ ADDSQ(!*KK2Q V,NEGSQ SIMP!* A);
% NEGSQ added JHD 22.3.87 - the previous value was wrong.
% If the substitution is (X-v) then this takes -v to 0,
% so the place was at -v.
        IF (NUMBERP NUMR N) AND (NUMBERP DENR N)
          THEN <<
            PRINC NUMR N;
            IF NOT ONEP DENR N
              THEN <<
                PRINC " / ";
                PRINC DENR N >> >>
          ELSE <<
            IF DEGREEIN(NUMR N,INTVAR) > 1
             THEN PRINTC "Any root of:";
            PRINTSQ N;
            IF CDR U
	      THEN PRINC "at the place " >> >>;
  U:=CDR U;
  IF NULL U
    THEN GOTO NL!-RETURN;
  N:=1;
  WHILE U AND (CAR RFIRSTSUBS U EQ 'EXPT) DO <<
    N:=N * CADDR RFIRSTSUBS U;
    U:=CDR U >>;
  IF N NEQ 1 THEN <<
    TERPRI!* NIL;
    prin2 " ";
    PRINC V;
    PRINC "=>";
    PRINC V;
    PRINC "**";
    PRINC N >>;
  WHILE U DO <<
    IF CAR RFIRSTSUBS U EQ 'MINUS
      THEN PRINC "-"
      ELSE PRINC "+";
    U:=CDR U >>;
NL!-RETURN:
  TERPRI();
  RETURN
  END;
 
 
 
SYMBOLIC PROCEDURE DEGREEIN(SF,VAR);
IF ATOM SF
  THEN 0
  ELSE IF MVAR SF EQ VAR
    THEN LDEG SF
    ELSE MAX(DEGREEIN(LC SF,VAR),DEGREEIN(RED SF,VAR));
 
ENDMODULE;
 
END;