;;; --------------------SET PACKAGE-----------------------
;;;  		V.R.Pratt.  Nov. 24, 1978
;;; BBOOLE code mostly due to H.G.Baker.

;;; The following operations are provided for manipulating finite
;;; sets of arbitrary objects represented as bit vectors.  The function
;;; BBOOLE permits bignums to be manipulated.  (This improves on the set
;;; facilities in extant implementations of PASCAL.)  The package keeps track
;;; of a universe U of objects, which are added to as needed by GATHER.
;;; GATHER considers objects distinct just when EQUAL, rather than EQ,
;;; pronounces them so.  M denotes objects, A,B,... sets.

;;; (UNION A1 ... An)		union of A1 ... An
;;; (INTERSECT A1 ... An)	intersection of A1 ... An
;;; (GATHER M1 ... Mn)		{M1,...,Mn}
;;; (SETDIFF A1 ... An)		n=0: U.  n=1: U-A.  n>1: A1-A2-...-An.
;;; (SYMDIFF A1 ... An)		elements occurring an odd number of times
;;; (ELEMENTS A)		list of elements of A, in order first met
;;; (ELEMENTOF A)		some element of A
;;; (CARDINAL A)		number of elements of A
;;; (ELEMENTP M A)		tests whether M is an element of A
;;; (SUBSETP A B)		tests whether A is a subset of B

;;; The following are not essential, but the user may find them handy on
;;; occasion.

;;; (CLEARSETS)			forgets all elements, so U = {}.  Crude GC.
;;; (BLSH A N)			LISP's LSH, works on bignums too
;;; (BBOOLE N A B)		ditto for BOOLE
;;; CARDUNIV			cardinality of the known universe.  Readonly!
;;; SETSOBARRAY			See below

;;; Only the symbols mentioned explicitly above are added to the normal
;;; obarray; the other atoms of the package are hidden in the obarray
;;; SETSOBARRAY referred to above.

;;; Examples of use
;;; (GATHER 'XY 55 '(A B))			forms the set {XY,55,(A B)}
;;; (UNION (GATHER 'XY 55) (GATHER 55 '(A B)))  ditto
;;; (ELEMENTS (GATHER 'XY 55 '(A B)))		forms the list (XY 55 (A B))
;;; (SUBSETP X (UNION X Y))			is always T (assuming X bound)
;;; (ELEMENTP A (GATHER A))			is always T (assuming A bound)
;;; (CARDINAL (GATHER 'XY '(A B)))		will be 2

;;; As PRINT will not distinguish between sets and integers, and MAPCAR will
;;; not know how to enumerate set elements, the function ELEMENTS is provided
;;; to convert a set to a list of its elements.

;;; The constant EMPTY may be expressed as 0, or as (GATHER) if you need to
;;; hint that it is of type SET, (SETDIFF) returns the present
;;; universe (everthing that has been GATHERed), SETDIFF will serve as
;;; COMPLEMENT, ZEROP will serve as the predicate EMPTYP, ODDP will serve as
;;; the predicate CONTAINS-ZERO.

;;; CGOL users have access to these routines automatically.  The syntax is
;;; {a1,...,an}		(GATHER A1 ... An)
;;; a1a2..an	(UNION A1 ... An)
;;; a1a2..an	(INTERSECT A1 ... An)
;;; a1~a2~...~an	(SETDIFF A1 A2 ... An)
;;; na		(ELEMENTP N A)
;;; ab		(SUBSETP A B)
;;; In addition f{a} (which is (APPLY 'F A)) will have the appropriate effect
;;; for f being any of gather,union,intersect.  Needless to say, f[a1,...,an]
;;; (which is (MAPCAR 'F A1 ... An) ) works correctly with all of the above.

;;; For efficiency, these routines, with the exception of GATHER and ELEMENTS,
;;; far outclass anything possible with methods based on representing sets
;;; as lists, by a factor of hundreds if not thousands.  In the case of
;;; GATHER, there is an overhead associated with the first time a pointer
;;; is encountered, dominated by the cost of doing an SXHASH on the object
;;; pointed to by that pointer.  While pathological cases could give rise to
;;; n**2 behavior, one can expect in general that the overhead from GATHER
;;; will not dominate.  ELEMENTS is not unduly slow, but it has to be done
;;; to get back your elements, unlike a method based on lists, where there
;;; is zero overhead here.

;;; Once a universe has been GATHERed up, the order of gathering will be that
;;; in which elements of sets are listed by ELEMENTS.  Thus to sort a list L
;;; all of whose elements are already in the universe, do
;;; (ELEMENTS (APPLY 'GATHER L)).  Repetitions will be eliminated.  If L
;;; contains elements not yet in the universe, they will retain the order
;;; they had in L, and appear after all other elements of L.




;;; **********************SETS PACKAGE**********************

(PROGN '(UNION INTERSECT GATHER SETDIFF SYMDIFF COMPLEMENT ELEMENTS ELEMENTOF
 CARDINAL ELEMENTP SUBSETP CLEARSETS BLSH BBOOLE CARDUNIV SETSOBARRAY) NIL)

(SETQ &OBARRAY OBARRAY
      OBARRAY (COND ((BOUNDP 'SETSOBARRAY) SETSOBARRAY)
		    ((*ARRAY NIL 'OBARRAY T))))

(DECLARE '(MUZZLED T)
	 (FIXNUM C I N X Y Z ARGNO CARDUNIV SETSASZ)
	 (SPECIAL CARDUNIV SETSOBARRAY))

(COND ((BOUNDP 'CARDUNIV) (CLEARSETS)))

(DEFUN UNION ARGNO
       (DO ((I 1 (ADD1 I)) (AC 0))
           ((GREATERP I ARGNO) AC)
           (SETQ AC (BBOOLE 7 AC (ARG I)))))

(DEFUN INTERSECT ARGNO
       (DO ((I 1 (ADD1 I)) (AC -1))
           ((GREATERP I ARGNO) AC)
           (SETQ AC (BBOOLE 1 AC (ARG I)))))

(DEFUN GATHER ARGNO
       (DO ((I 1 (ADD1 I)) (AC 0))
           ((GREATERP I ARGNO) AC)
           (SETQ AC (PBOOLEAN 7 AC (EXPT 2 (OBNUM (ARG I)))))))

(DEFUN SETDIFF ARGNO
       (COND ((ZEROP ARGNO) (SUB1 (EXPT 2 CARDUNIV)))
 	     ((EQUAL ARGNO 1) (DIFFERENCE (EXPT 2 CARDUNIV) 1 (ARG 1)))
	     ((DO ((I 2 (ADD1 I)) (AC (ARG 1)))
                  ((GREATERP I ARGNO) AC)
                  (SETQ AC (BBOOLE 4 AC (ARG I)))))))

(DEFUN SYMDIFF ARGNO
       (DO ((I 1 (ADD1 I)) (AC 0))
           ((GREATERP I ARGNO) AC)
           (SETQ AC (BBOOLE 6 AC (ARG I)))))

(DEFUN ELEMENTS (A)
       (COND ((MINUSP A) (ERROR '|INFINITELY MANY ELEMENTS|))
	     ((BIGP A) (LELEMENTS (CDR A) 0))
	     ((FELEMENTS A 0))))

(DEFUN LELEMENTS (L N)
       (AND L (APPEND (FELEMENTS (CAR L) N) (LELEMENTS (CDR L) (PLUS N 35.)))))

(DEFUN FELEMENTS (X N)
       (COND ((ZEROP X) NIL)
	     ((ODDP X) (CONS (SETSARRAY N) (FELEMENTS (LSH X -1) (ADD1 N))))
	     ((FELEMENTS (LSH X -1) (ADD1 N)))))

(DEFUN ELEMENTOF (A) (COND ((PLUSP A) (SETSARRAY (SUB1 (HAULONG A))))))

(DEFUN CARDINAL (A)
       (COND ((MINUSP A) 'INFINITY)
	     ((BIGP A) (APPLY 'PLUS (MAPCAR 'FCARDINAL (CDR A))))
	     ((FCARDINAL A))))

(DEFUN FCARDINAL (X)
       (COND ((ZEROP X) 0)
	     ((ODDP X) (ADD1 (FCARDINAL (LSH X -1))))
	     ((FCARDINAL (LSH X -1)))))

(DEFUN BELEMENTP (N L)
       ;;; TEST IF THE N'TH BIT IS ON IN THE LIST OF FIXNUMS L.
       (COND ((NULL L) NIL)
	     ;;; IF BIT IS IN CURRENT WORD, CHECK IT.
	     ((< N 35.) (ODDP (LSH (CAR L) (MINUS N))))
	     ;;; OTHERWISE, TRY NEXT WORD.
	     ((BELEMENTP (- N 35.) (CDR L)))))

(DEFUN ELEMENTP (A L)
       ((LAMBDA (N)
        (COND ((NULL N) NIL)
	      ;;; IF L NEG, SEE IF N MISSING IN L COMPLEMENT.
	      ((MINUSP L) (NOT (ELEMENTP N (DIFFERENCE -1 L))))
	      ;;; IF L A BIGNUM, RUN DOWN LIST OF FIXNUMS.
	      ((BIGP L) (BELEMENTP N (CDR L)))
	      ;;; CHECK IF BIT ON IN SHIFTED FIXNUM.
	      ((ODDP (LSH L (MINUS N))))))
	(OLDOBNUM A)))

(DEFUN SUBSETP (A B) (ZEROP (BBOOLE 4 A B)))

(DEFUN BLSH (M N) 
       ;;; BLSH(M N) = (FLOOR (TIMES M (EXPT 2. N)))
       (COND ((MINUSP N)
             (COND ((MINUSP M) (DIFFERENCE -1 (BLSH (DIFFERENCE -1 M) N)))
                   ((QUOTIENT M (EXPT 2. N)))))
	     ((TIMES M (EXPT 2. N))))) 

(DEFUN SWR MACRO (A) 
       ;;; "SWR" = SWITCH ROWS IN "BOOLE"-TYPE 2X2 MATRIX
       ;;; SWR(ABCD) = BADC.
       (SUBST (CADR A)
	      'ABCD
	      '(BOOLE 7 (LSH (BOOLE 1 5. ABCD) 1.) (LSH (BOOLE 1 10. ABCD) -1.)))) 

(DEFUN SWC MACRO (A) 
       ;;; "SWC" = SWITCH COLUMNS IN "BOOLE"-TYPE 2X2 MATRIX
       ;;; SWC(ABCD) = CDAB.
       (SUBST (CADR A)
	      'ABCD
	      '(BOOLE 7 (LSH (BOOLE 1 3. ABCD) 2.) (LSH (BOOLE 1 12. ABCD) -2.)))) 

(DEFUN BBOOLEAN (C A B) 
       ;;; COMPUTES GENERAL BOOLEAN FUNCTION OF TWO LISTS OF
       ;;; POSITIVE FIXNUMS, NOT NECESSARILY OF THE SAME LENGTH.
       ;;; RETURNS EITHER A LIST OF POSITIVE FIXNUMS, OR A SINGLE FIXNUM.
       (OR (AND (OR (AND A (OR B (SETQ B '(0.))))
		    (AND B (OR A (SETQ A '(0.)))))
		((LAMBDA (X W)
		     (COND ((ATOM W)
			    (COND ((ZEROP W) X) ((LIST X W))))
			   ((CONS X W))))
		 (BOOLE C (CAR A) (CAR B))
		 (BBOOLEAN C (CDR A) (CDR B))))
	   0.)) 

(DEFUN PBOOLEAN (C A B) 
       ;;; COMPUTES A BOOLEAN FUNCTION OF TWO NON-NEGATIVE
       ;;; INTEGER ARGUMENTS.  THE FUNCTION APPLIED TO (0, 0) MUST 
       ;;; RETURN 0.
       (COND ((BIGP A)
	      (COND ((BIGP B)
		     (CONSBIGNUMBER (BBOOLEAN C (CDR A) (CDR B))))
		    ((CONSBIGNUMBER (BBOOLEAN C (CDR A) (LIST B))))))
	     ((COND ((BIGP B)
		     (CONSBIGNUMBER (BBOOLEAN C (LIST A) (CDR B))))
		    ((BOOLE C A B)))))) 

(DEFUN BBOOLE (C A B) 
       ;;; computes the general boolean function of two integer arguments.
       (COND ((MINUSP A)
	      (COND ((MINUSP B)
		     (COND ((ZEROP (BOOLE 1 1. C))
			    (PBOOLEAN C (DIFFERENCE -1 A) (DIFFERENCE -1 B)))
			   ((DIFFERENCE -1 (PBOOLEAN (BOOLE 4 15. C)
					    (DIFFERENCE -1 A)
					    (DIFFERENCE -1 B))))))
		    ((COND ((ZEROP (BOOLE 1 4. C))
			    (PBOOLEAN (SWR C) (DIFFERENCE -1 A) B))
			   ((DIFFERENCE -1 (PBOOLEAN (BOOLE 4 15. (SWR C))
					    (DIFFERENCE -1 A)
					    B)))))))
	     ((COND ((MINUSP B)
		     (COND ((ZEROP (BOOLE 1 2. C))
			    (PBOOLEAN (SWC C) A (DIFFERENCE -1 B)))
			   ((DIFFERENCE -1 (PBOOLEAN (BOOLE 4 15. (SWC C))
					    A
					    (DIFFERENCE -1 B))))))
		    ((COND ((ZEROP (BOOLE 1 8. C)) (PBOOLEAN C A B))
			   ((DIFFERENCE -1 (PBOOLEAN (BOOLE 4 15. C) A B))))))))) 

(DEFUN CONSBIGNUMBER (A) 
       (COND ((ATOM A) A) ((NULL (CDR A)) (CAR A)) ((CONSBIGNUM A)))) 

(VALRET '//:VP/ ) ;;; GET SYMBOLS FROM DDT.

(LAP CONSBIGNUM SUBR)
	(JRST 0 BNCONS)
NIL 

(DECLARE (SPECIAL AW ASX)) ;;; COMMUNICATES BETWEEN OBNUM, OLDOBNUM

(DEFUN OBNUM (W)
   ;;; CONVERTS OBJECT TO A SMALL NUMERIC IDENTIFIER FOR THAT OBJECT
       (OR (OLDOBNUM W)		;;; IF ALREADY IN UNIVERSE, USE IT
	   ((LAMBDA (N)		;;; OTHERWISE ADD TO UNIVERSE
		  (STORE (SETSARRAY N) W)
		  (PUTPROP AW N 'OBNUM)
		  (COND (ASX (PUTPROP ASX
				      (CONS (CONS W N) (GET ASX 'SXES))
				      'SXES)))
		  N)
	    (NEWNUM))))

(DEFUN OLDOBNUM (W)
   ;;; LIKE OBNUM, BUT RETURNS NIL IF W IS NOT IN UNIVERSE
       (SETQ AW (MAKSYM W) ASX NIL)
       (COND ((AND (ATOM W) (NOT (BIGP W))) (GET AW 'OBNUM))
	     ((OR (GET AW 'OBNUM)
		  (CDR (ASSOC W (GET (SETQ ASX (MAKSYM (SXHASH W))) 'SXES)))))))

(DEFUN MAKSYM (A)
       (COND ((OR (NOT (ATOM A)) (BIGP A)) (IMPLODE (EXPLODE (MAKNUM A))))
	     ((NUMBERP A) (IMPLODE (EXPLODE A)))
	     (A)))

(DEFUN NEWNUM ()
       (SETQ CARDUNIV (ADD1 CARDUNIV))
       (COND ((LESSP SETSASZ CARDUNIV)
	      (*REARRAY 'SETSARRAY T (SETQ SETSASZ (PLUS SETSASZ 200.)))))
       (SUB1 CARDUNIV))

(DEFUN CLEARSETS ()
       (DO ((I 0 (ADD1 I)))
	   ((EQUAL I CARDUNIV) (SETQ CARDUNIV 0))
	   (OLDOBNUM (SETSARRAY I))
	   (PUTPROP AW NIL 'OBNUM)
	   (COND (ASX (PUTPROP ASX NIL 'SXES)))
	   (STORE (SETSARRAY I) 'NONEXISTENT-SET-ELEMENT)))

(COND ((NOT (BOUNDP 'CARDUNIV))
       (ARRAY SETSARRAY T 200.)
       (SETQ SETSASZ 200.)
       (FILLARRAY 'SETSARRAY '(NONEXISTENT-SET-ELEMENT))))

(SETQ CARDUNIV 0 SETSOBARRAY OBARRAY OBARRAY &OBARRAY)