Artifact f74680a47c674dd7f4a60e9ef177edd597f6af6f9c3dd454a83f1cf8eb6a4080:

• File r30/part.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 1918) [annotate] [blame] [check-ins using] [more...]

SYMBOLIC PROCEDURE SIMPPART U;
   BEGIN SCALAR EXPN;
      EXPN := PREPSQ!* SIMP!* CAR U;
      U := CDR U;
      WHILE U DO
	 BEGIN SCALAR X,Y;
	   IF ATOM EXPN
	     THEN MSGPRI("Expression",EXPN,
			 "does not have part",CAR U,T)
            ELSE IF NOT NUMBERP(X := REVAL CAR U)
	     THEN MSGPRI("Invalid argument",CAR U,"to part",NIL,T)
	    ELSE IF X=0
	     THEN RETURN <<EXPN := CAR EXPN; U := NIL>>
	    ELSE IF X<0 THEN <<X := -X; Y := REVERSE CDR EXPN>>
 	    ELSE Y := CDR EXPN;
	   IF LENGTH Y<X
	     THEN MSGPRI("Expression",EXPN,
			 "does not have part",CAR U,T)
	    ELSE EXPN := NTH(Y,X);
       U := CDR U
     END;
      RETURN SIMP EXPN
   END;

PUT('PART,'SIMPFN,'SIMPPART);

SYMBOLIC PROCEDURE SIMPSETPART U;
   %Simplifies a SETPART expression;
   (LAMBDA X; SIMP SIMPSETP1(PREPSQ!* SIMP!* CAR U,REVERSE CDR X,CAR X))
    REVERSE CDR U;

SYMBOLIC PROCEDURE SIMPSETP1(EXPN,PTLIST,REP);
   IF NULL PTLIST THEN REP
    ELSE IF ATOM EXPN
	     THEN MSGPRI("Expression",EXPN,
			 "does not have part",CAR PTLIST,T)
    ELSE BEGIN SCALAR X;
      IF NOT NUMBERP(X := REVAL CAR PTLIST)
	     THEN MSGPRI("Invalid argument",CAR PTLIST,"to part",NIL,T)
       ELSE RETURN 
	IF X=0 THEN REP . CDR EXPN
	 ELSE IF X<0
	  THEN CAR EXPN . 
		REVERSE SSL(REVERSE CDR EXPN,
			    -X,CDR PTLIST,REP,EXPN . CAR PTLIST)
	 ELSE CAR EXPN . SSL(CDR EXPN,X,CDR PTLIST,
			     REP,EXPN . CAR PTLIST)
   END;

SYMBOLIC PROCEDURE SSL(EXPN,INDX,PTLIST,REP,REST);
   IF NULL EXPN
     THEN MSGPRI("Expression",CAR REST,"does not have part",CDR REST)
    ELSE IF INDX=1 THEN SIMPSETP1(CAR EXPN,PTLIST,REP) . CDR EXPN
    ELSE CAR EXPN . SSL(CDR EXPN,INDX-1,PTLIST,REP,REST);

PUT('PART,'SETQFN,'SETPART!*);

PUT('SETPART!*,'SIMPFN,'SIMPSETPART);

SYMBOLIC PROCEDURE ARGLENGTH U;
   BEGIN SCALAR X;
      X := PREPSQ!* SIMP!* U;
      RETURN IF ATOM X THEN -1 ELSE LENGTH CDR X
   END;

FLAG('(ARGLENGTH),'OPFN);


END;