PDP-10.its/src/libdoc/set.ira1

(COMMENT SET OPERATIONS -- Ira Goldstein)

;;;This file contains functions for operating on sets.
;;;A given function like UNION comes in several flavors.
;;;	UNION takes multiple arguments and uses equal
;;;	UNION2 takes 2 arguments and uses equal.
;;;	UNIONQ takes multiple arguments and uses eq.
;;;	UNIONQ2 takes 2 arguments and uses eq.

;;;The file currently contains the following functions:
;;;Union:	 (union, unionq, union2, unionq2)
;;;Intersection: (intersect, intersectq, intersect2, intersectq2)
;;;Subtraction:  (setminus, setminusq, setminus2, setminusq2)

;;;Other useful set functions that are included are:
;;;(unite e v)  sets the value of v (l) to be union of (e) and l
;;;(uniteq e v) similar to unite.  Uses eq.

;;;(Unify e l)	returns union of (list e) and L.
;;;(unifyq e l)	returns unionq of (list e) and L.

;;;(Setify L)	returns L with all duplicates (compared using equal) deleted.
;;;(setifyq L)	returns L with all duplicates (compared using eq) deleted.

;;;(subset x y)	returns t iff x is a subset of y.  x atomic treated as unary set.
;;;(subsetq x y) similar to subset but uses eq.

(COMMENT MACRODEF)

;;;macrodef defines macros during compilation.  But is equivalent
;;;to DEFUN during interpretation.  Simplifies debugging interpretive code.

(DECLARE (MACROS NIL) (FIXNUM N))

(SSTATUS FEATURE SET)


(defun EXPAND macro (qqq)
	;;from GLS;MACROS >
       (list 'quote
	     ((lambda (www)
		      (rplaca x (car www))
		      (rplacd x (cdr www)))
	      (sublis (mapcar (function
				  (lambda (hhh)
					(cons (car hhh)
					      (eval (cadr hhh)))))
			      (cadr qqq))
		      (caddr qqq)))))

(defun MACRODEF macro (qqq)
	;;from GLS;MACROS >
       (list 'defun
	     (cadr qqq)
	     'macro
	     '(x)
	     (list 'expand
		   (do ((rrr (caddr qqq) (cdr rrr))
			(ccc '(cdr x) (list 'cdr ccc))
			(lll nil
			     (cons (list (car rrr)
					 (list 'car ccc))
				   lll)))
		       ((atom rrr)
			(and rrr
			     (setq lll
				   (cons (list rrr ccc) lll)))
			(nreverse lll)))
		   (COND ((CDDDDR QQQ) (CONS 'PROGN (CDDDR QQQ)))
			 ((cadddr qqq))))))



(COMMENT SET RELATED FUNCTIONS)

(DEFUN UNITEQ FEXPR (X)
  ;;VARIABLE IS THE NAME OF A LIST.  E.G. (UNITEQ A X)
  ;;ELEMENT ADDED TO VALUE OF VARIABLE IF NOT ALREADY PRESENT.
 (PROG (ELEMENT VARIABLE) 
  (SETQ ELEMENT (CAR X) VARIABLE (CADR X))
  (RETURN
   (COND ((NOT (BOUNDP VARIABLE)) (SET VARIABLE (LIST ELEMENT)))
         ((SET VARIABLE (UNIFYQ ELEMENT (EVAL VARIABLE))))))))

(DEFUN UNITE FEXPR (X)
  ;;VARIABLE IS THE NAME OF A LIST.
  ;;ELEMENT ADDED TO VALUE OF VARIABLE IF NOT ALREADY PRESENT.
 (PROG (ELEMENT VARIABLE) 
  (SETQ ELEMENT (CAR X) VARIABLE (CADR X))
  (RETURN
   (COND ((NOT (BOUNDP VARIABLE)) (SET VARIABLE (LIST ELEMENT)))
         ((SET VARIABLE (UNIFY ELEMENT (EVAL VARIABLE))))))))

(DEFUN UNIFYQ (ELEMENT L)
  ;;L IS A LIST, ELEMENT IS AN ATOM.  ELEMENT ADDED TO LIST IF NOT ALREADY PRESENT.
  (COND ((NULL L) (LIST ELEMENT))
        ((MEMQ ELEMENT L))
        ((CONS ELEMENT L))))

(DEFUN UNIFY (ELEMENT L)
  ;;L IS A LIST, ELEMENT IS AN ATOM.  ELEMENT ADDED TO LIST IF NOT ALREADY PRESENT.
  (COND ((NULL L) (LIST ELEMENT))
        ((MEMBER ELEMENT L))
        ((CONS ELEMENT L))))

(defun SETIFY (l)
        ;; returns L with all duplicates (compared using
        ;;  EQUAL) removed.  The order is unchanged.
        (cond((null l) nil)
             (t
              (do ((set (list (car l)))
                   (remainder (cdr l) (cdr remainder)))
                  ((null remainder) (nreverse set))
                  (cond((not (member (car remainder) set))
                        (setq set (cons (car remainder) set))))))))

 (defun SETIFYQ (l)
        ;; returns L with all duplicates (compared using
        ;;  EQ) removed.  The order is unchanged.
        (cond((null l) nil)
             (t
              (do ((set (list (car l)))
                   (remainder (cdr l) (cdr remainder)))
                  ((null remainder) (nreverse set))
                  (cond((not (memq (car remainder) set))
                        (setq set (cons (car remainder) set))))))))

(DEFUN SUBSETQ (X Y)
  ;X = ATOM <=> X = (ELEMENT). I.E. ATOM X TREATED AS UNARY SET.
  ;USES EQ.
  (COND ((ATOM X) (MEMQ X Y))
        ((NULL (SETMINUSQ2 X Y)))))


(DEFUN SUBSET (X Y)
  ;X = ATOM <=> X = (ELEMENT). I.E. ATOM X TREATED AS UNARY SET.
  ;USES EQ.
  (COND ((ATOM X) (MEMBER X Y))
        ((NULL (SETMINUS2 X Y)))))

(COMMENT SET SUBTRACTION)

;;THESE MACROS DO NOT DO NREVERSING.

(MACRODEF SETMINUSQ2-M (A B) 
  ;;Result is not nreversed to be in order similar to args for efficiency.
  ;;since setminus2 is used by setminus and union repeatedly.
       (do ((x a (cdr x)) (result))
           ((null x) result)
           (or (memq (car x) b)
               (setq result (cons (car x) result)))))

(MACRODEF SETMINUS2-M (A B) 
  ;;Result is not nreversed to be in order similar to args for efficiency.
  ;;since setminus2 is used by setminus and union repeatedly.
       (do ((x a (cdr x)) (result))
           ((null x) result)
           (or (member (car x) b)
               (setq result (cons (car x) result)))))

;;(SETMINUS a b) returns all elements of a not in b.

(defun SETMINUSQ2 (A B)  (NREVERSE (SETMINUSQ2-M A B)))

(defun SETMINUS2 (A B)  (NREVERSE (SETMINUS2-M A B)))

(DEFUN SETMINUS N
  (COND ((= N 2) (NREVERSE (SETMINUS2-M (ARG 1) (ARG 2))))
        ((DO ((I 2 (1+ I)) (L (ARG 1)))
           ((> I N) (COND ((ODDP N) L) ((NREVERSE L))))
	   (SETQ L (SETMINUS2-M L (ARG I)))))))

(DEFUN SETMINUSQ N
  (COND ((= N 2) (NREVERSE (SETMINUSQ2-M (ARG 1) (ARG 2))))
        ((DO ((I 2 (1+ I)) (L (ARG 1)))
           ((> I N) (COND ((ODDP N) L) ((NREVERSE L))))
	   (SETQ L (SETMINUSQ2-M L (ARG I)))))))


(COMMENT UNION)

;;UNION2 AND UNIONQ2 takes the union of exactly two sets.
;;Most efficient if the first is the smallest.

(DEFUN UNIONQ2 (A B)
       (APPEND A (NREVERSE (SETMINUSQ2-M B A))))

(DEFUN UNION2 (A B)
       (APPEND A (NREVERSE (SETMINUS2-M B A))))

;;UNION takes the union of any number of sets.

(DEFUN UNION N
  ;;COPY DONE TO ALLOW NCONC, WITHOUT EFFECT ON ARGS.
  (COND ((= N 2) (UNION2 (ARG 1) (ARG 2)))
        ((DO ((I 2 (1+ I)) (RESULT (SUBST NIL NIL (ARG 1))))
	  ((> I N) RESULT)
	  (SETQ RESULT (NCONC RESULT (NREVERSE (SETMINUS2-M (ARG I) RESULT))))))))

(DEFUN UNIONQ N
  (COND ((= N 2) (UNIONQ2 (ARG 1) (ARG 2)))
        ((DO ((I 2 (1+ I)) (RESULT (ARG 1)))
	  ((> I N) RESULT)
	  (SETQ RESULT (NCONC RESULT (NREVERSE (SETMINUSQ2-M (ARG I) RESULT))))))))

(COMMENT INTERSECTION)

;;;These macros are for internal efficiency to avoid repeated nreversing.
;;;They do not appear in the fasl file.

(macrodef intersectQ2-m (a b)
       (do ((x a (cdr x)) (result))
           ((null x) result)
           (and (memq (car x) b)
                (setq result (cons (car x) result)))))

(macrodef intersect2-m (a b)
       (do ((x a (cdr x)) (result))
           ((null x) result)
           (and (member (car x) b)
                (setq result (cons (car x) result)))))

;;;intersectQ2 and intersect2 takes the intersection of exactly two sets. 
;;;The first should be the smaller, for efficiency.

(defun intersectQ2 (a b) (nreverse (intersectq2-m a b)))

(defun intersect2 (a b) (nreverse (intersect2-m a b)))

;; INTERSECT takes the intersection of n sets of atoms.

(DEFUN INTERSECT N 
  ;;IF N ODD, REVERSING CANCEL AND NO FINAL NREVERSE IS NECESSARY.
  (COND ((= N 2) (NREVERSE (INTERSECT2-M (ARG 1) (ARG 2))))
        ((DO ((I 2 (1+ I)) (RESULT (ARG 1)))
	  ((> I N) (COND ((ODDP N) RESULT) ((NREVERSE RESULT))))
	  (SETQ RESULT (INTERSECT2-M RESULT (ARG I)))))))

(DEFUN INTERSECTQ N 
  (COND ((= N 2) (NREVERSE (INTERSECTQ2-M (ARG 1) (ARG 2))))
        ((DO ((I 2 (1+ I)) (RESULT (ARG 1)))
	  ((> I N) (COND ((ODDP N) RESULT) ((NREVERSE RESULT))))
	  (SETQ RESULT (INTERSECTQ2-M RESULT (ARG I)))))))