(FILECREATED "28-Mar-86 15:33:01" {ERIS}<LISPUSERS>KOTO>LSET.;3 19210
previous date: "19-May-85 11:17:09" {ERIS}<LISPUSERS>KOTO>LSET.;1)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LSETCOMS)
(RPAQQ LSETCOMS ((PROPS (LSUBTRACTQ ARGNAMES)
(LSUBTRACT ARGNAMES)
(LUNIONQ ARGNAMES)
(LUNION ARGNAMES)
(LINTERSECTQ ARGNAMES)
(LINTERSECT ARGNAMES)
(BSUBTRACTQ ARGNAMES)
(BSUBTRACT ARGNAMES)
(BUNIONQ ARGNAMES)
(BUNION ARGNAMES)
(BINTERSECTQ ARGNAMES)
(BINTERSECT ARGNAMES))
(FNS LUNIFYQ LUNIFY LSETIFYQ LSETIFY LSETQP LSETP LSUBSETQ LSUBSET LEQUAL LEQUALQ LSUBTRACTQ2
LSUBTRACT2 LSUBTRACTQ LSUBTRACT LUNIONQ2 LUNION2 LUNIONQ LUNION LINTERSECTQ2 LINTERSECT2
LINTERSECTQ LINTERSECT BUNIFYQ BUNIFY BALISTQ BALIST BUNALIST BSUBBAGQ BSUBBAG BEQUAL
BEQUALQ BSUBTRACTQ2 BSUBTRACT2 BSUBTRACTQ BSUBTRACT BUNIONQ2 BUNION2 BUNIONQ BUNION
BINTERSECTQ2 BINTERSECT2 BINTERSECTQ BINTERSECT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA BINTERSECT BINTERSECTQ BUNION BUNIONQ BSUBTRACT BSUBTRACTQ
LINTERSECT LINTERSECTQ LUNION LUNIONQ LSUBTRACT LSUBTRACTQ)))))
(PUTPROPS LSUBTRACTQ ARGNAMES SETS)
(PUTPROPS LSUBTRACT ARGNAMES SETS)
(PUTPROPS LUNIONQ ARGNAMES SETS)
(PUTPROPS LUNION ARGNAMES SETS)
(PUTPROPS LINTERSECTQ ARGNAMES SETS)
(PUTPROPS LINTERSECT ARGNAMES SETS)
(PUTPROPS BSUBTRACTQ ARGNAMES BAGS)
(PUTPROPS BSUBTRACT ARGNAMES BAGS)
(PUTPROPS BUNIONQ ARGNAMES BAGS)
(PUTPROPS BUNION ARGNAMES BAGS)
(PUTPROPS BINTERSECTQ ARGNAMES BAGS)
(PUTPROPS BINTERSECT ARGNAMES BAGS)
(DEFINEQ
(LUNIFYQ
(LAMBDA (ELEMENT LIST) (* kbr: "21-Jul-84 21:56")
(* ELEMENT ADDED TO LIST IF NOT ALREADY PRESENT)
(COND
((MEMB ELEMENT LIST)
LIST)
((CONS ELEMENT LIST)))))
(LUNIFY
(LAMBDA (ELEMENT LIST) (* kbr: "21-Jul-84 21:56")
(* ELEMENT ADDED TO LIST IF NOT ALREADY PRESENT)
(COND
((MEMBER ELEMENT LIST)
LIST)
((CONS ELEMENT LIST)))))
(LSETIFYQ
(LAMBDA (LIST) (* kbr: "21-Jul-84 21:56")
(* RETURNS LIST WITH ALL DUPLICATES REMOVED)
(PROG (ANSWER)
(FOR ELEMENT IN LIST WHEN (NOT (MEMB ELEMENT ANSWER)) DO (PUSH ANSWER ELEMENT))
(RETURN ANSWER))))
(LSETIFY
(LAMBDA (LIST) (* kbr: "21-Jul-84 21:56")
(* RETURNS LIST WITH ALL DUPLICATES REMOVED)
(PROG (ANSWER)
(FOR ELEMENT IN LIST WHEN (NOT (MEMBER ELEMENT ANSWER)) DO (PUSH ANSWER ELEMENT))
(RETURN ANSWER))))
(LSETQP
(LAMBDA (LIST) (* kbr: "19-May-85 11:14")
(for TAIL on LIST always (NOT (MEMB (CAR TAIL)
(CDR TAIL))))))
(LSETP
(LAMBDA (LIST) (* kbr: "19-May-85 11:14")
(for TAIL on LIST always (NOT (MEMBER (CAR TAIL)
(CDR TAIL))))))
(LSUBSETQ
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* RETURNS T IF X IS A SUBSET OF Y)
(COND
((EQ X Y) (* Optimized case *)
T)
(T (NULL (LSUBTRACTQ2 X Y))))))
(LSUBSET
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* RETURNS T IF X IS A SUBSET OF Y)
(COND
((EQ X Y) (* Optimized case *)
T)
(T (NULL (LSUBTRACT2 X Y))))))
(LEQUAL
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(COND
((EQ X Y) (* Optimized case *)
T)
(T (AND (LSUBSET X Y)
(LSUBSET Y X))))))
(LEQUALQ
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(COND
((EQ X Y) (* Optimized case *)
T)
(T (AND (LSUBSETQ X Y)
(LSUBSETQ Y X))))))
(LSUBTRACTQ2
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* RETURNS ELEMENTS IN X NOT IN Y)
(COND
((EQ X Y) (* Optimized case *)
NIL)
(T (FOR ELEMENT IN X WHEN (NOT (MEMB ELEMENT Y)) COLLECT ELEMENT)))))
(LSUBTRACT2
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* RETURNS ELEMENTS IN X NOT IN Y)
(COND
((EQ X Y) (* Optimized case *)
NIL)
(T (FOR ELEMENT IN X WHEN (NOT (MEMBER ELEMENT Y)) COLLECT ELEMENT)))))
(LSUBTRACTQ
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (SETS) (* RETURNS ELEMENTS IN FIRST SET NOT IN THE REMAINING
SETS)
(PROG (ANSWER)
(SETQ ANSWER (CAR SETS))
(FOR SET IN (CDR SETS) DO (SETQ ANSWER (LSUBTRACTQ2 ANSWER SET)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(LSUBTRACT
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (SETS) (* RETURNS ELEMENT IN FIRST SET NOT IN THE REMAINING
SETS)
(PROG (ANSWER)
(SETQ ANSWER (CAR SETS))
(FOR SET IN (CDR SETS) DO (SETQ ANSWER (LSUBTRACT2 ANSWER SET)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(LUNIONQ2
(LAMBDA (A B) (* kbr: "21-Jul-84 21:56")
(* LUNION OF SETS A AND B)
(PROG (C)
(SETQ C (LSUBTRACTQ2 A B))
(COND
((NULL C)
(RETURN B))
(T (RETURN (APPEND C B)))))))
(LUNION2
(LAMBDA (A B) (* kbr: "21-Jul-84 21:56")
(* LUNION OF SETS A AND B)
(PROG (C)
(SETQ C (LSUBTRACT2 A B))
(COND
((NULL C)
(RETURN B))
(T (RETURN (APPEND C B)))))))
(LUNIONQ
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (SETS) (* LUNION OF N SETS)
(PROG (ANSWER)
(FOR SET IN SETS DO (SETQ ANSWER (LUNIONQ2 ANSWER SET)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(LUNION
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (SETS) (* LUNION OF N SETS)
(PROG (ANSWER)
(FOR SET IN SETS DO (SETQ ANSWER (LUNION2 ANSWER SET)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(LINTERSECTQ2
(LAMBDA (A B) (* kbr: "21-Jul-84 21:56")
(* INTERSECTION OF SETS A AND B)
(COND
((EQ A B) (* Optimized case *)
A)
(T (FOR ELEMENT IN A WHEN (MEMB ELEMENT B) COLLECT ELEMENT)))))
(LINTERSECT2
(LAMBDA (A B) (* kbr: "21-Jul-84 21:56")
(* INTERSECTION OF SETS A AND B)
(COND
((EQ A B) (* Optimized case *)
A)
(T (FOR ELEMENT IN A WHEN (MEMBER ELEMENT B) COLLECT ELEMENT)))))
(LINTERSECTQ
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (SETS) (* INTERSECTION OF N SETS)
(PROG (ANSWER)
(SETQ ANSWER (CAR SETS))
(FOR SET IN (CDR SETS) DO (SETQ ANSWER (LINTERSECTQ2 ANSWER SET)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(LINTERSECT
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (SETS) (* INTERSECTION OF N SETS)
(PROG (ANSWER)
(SETQ ANSWER (CAR SETS))
(FOR SET IN (CDR SETS) DO (SETQ ANSWER (LINTERSECT2 ANSWER SET)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(BUNIFYQ
(LAMBDA (ELEMENT LIST) (* kbr: "21-Jul-84 21:56")
(* ELEMENT ADDED TO LIST *)
(CONS ELEMENT LIST)))
(BUNIFY
(LAMBDA (ELEMENT LIST) (* kbr: "21-Jul-84 21:56")
(* ELEMENT ADDED TO LIST *)
(CONS ELEMENT LIST)))
(BALISTQ
(LAMBDA (BAG) (* kbr: "21-Jul-84 21:56")
(* Return incidence ALIST for BAG *)
(PROG (ALIST BUCKET)
(FOR ELEMENT IN BAG
DO (SETQ BUCKET (ASSOC ELEMENT ALIST))
(COND
(BUCKET (RPLACD BUCKET (ADD1 (CDR BUCKET))))
(T (PUSH ALIST (CONS ELEMENT 1)))))
(RETURN ALIST))))
(BALIST
(LAMBDA (BAG) (* kbr: "21-Jul-84 21:56")
(* Return incidence ALIST for BAG *)
(PROG (ALIST BUCKET)
(FOR ELEMENT IN BAG
DO (SETQ BUCKET (SASSOC ELEMENT ALIST))
(COND
(BUCKET (RPLACD BUCKET (ADD1 (CDR BUCKET))))
(T (PUSH ALIST (CONS ELEMENT 1)))))
(RETURN ALIST))))
(BUNALIST
(LAMBDA (ALIST) (* kbr: "21-Jul-84 21:56")
(* Return BAG corresponding to incidence ALIST *)
(PROG (BAG)
(SETQ BAG (FOR BUCKET IN ALIST JOIN (FOR I FROM 1 TO (CDR BUCKET) COLLECT (CAR BUCKET))))
(RETURN BAG))))
(BSUBBAGQ
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* RETURNS T IF X IS A SUBBAG OF Y)
(PROG (XALIST YALIST YBUCKET ANSWER)
(SETQ XALIST (BALISTQ X))
(SETQ YALIST (BALISTQ Y))
(SETQ ANSWER (FOR XBUCKET IN XALIST
DO (SETQ YBUCKET (ASSOC (CAR XBUCKET)
YALIST))
(COND
((OR (NULL YBUCKET)
(IGREATERP (CDR XBUCKET)
(CDR YBUCKET)))
(RETURN NIL)))
FINALLY (RETURN T)))
(RETURN ANSWER))))
(BSUBBAG
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* RETURNS T IF X IS A SUBBAG OF Y)
(PROG (XALIST YALIST YBUCKET ANSWER)
(SETQ XALIST (BALIST X))
(SETQ YALIST (BALIST Y))
(SETQ ANSWER (FOR XBUCKET IN XALIST
DO (SETQ YBUCKET (SASSOC (CAR XBUCKET)
YALIST))
(COND
((OR (NULL YBUCKET)
(IGREATERP (CDR XBUCKET)
(CDR YBUCKET)))
(RETURN NIL)))
FINALLY (RETURN T)))
(RETURN ANSWER))))
(BEQUAL
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(AND (BSUBBAG X Y)
(BSUBBAG Y X))))
(BEQUALQ
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(AND (BSUBBAGQ X Y)
(BSUBBAGQ Y X))))
(BSUBTRACTQ2
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* Bag X minus bag Y *)
(PROG (XALIST YALIST XBUCKET ANSWER)
(COND
((EQ X Y) (* Optimized case *)
(RETURN NIL)))
(SETQ XALIST (BALISTQ X))
(SETQ YALIST (BALISTQ Y))
(FOR YBUCKET IN YALIST
DO (SETQ XBUCKET (ASSOC (CAR YBUCKET)
XALIST))
(COND
((OR (NULL XBUCKET)
(IGREATERP (CDR YBUCKET)
(CDR XBUCKET)))
(ERROR `(,Y not a subbag of ,X)
"")))
(RPLACD XBUCKET (IDIFFERENCE (CDR XBUCKET)
(CDR YBUCKET))))
(SETQ ANSWER (BUNALIST XALIST))
(RETURN ANSWER))))
(BSUBTRACT2
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* Bag X minus bag Y *)
(PROG (XALIST YALIST XBUCKET ANSWER)
(COND
((EQ X Y) (* Optimized case *)
(RETURN NIL)))
(SETQ XALIST (BALIST X))
(SETQ YALIST (BALIST Y))
(FOR YBUCKET IN YALIST
DO (SETQ XBUCKET (SASSOC (CAR YBUCKET)
XALIST))
(COND
((OR (NULL XBUCKET)
(IGREATERP (CDR YBUCKET)
(CDR XBUCKET)))
(ERROR `(,Y not a subbag of ,X)
"")))
(RPLACD XBUCKET (IDIFFERENCE (CDR XBUCKET)
(CDR YBUCKET))))
(SETQ ANSWER (BUNALIST XALIST))
(RETURN ANSWER))))
(BSUBTRACTQ
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (BAGS) (* Subtract BAG2 ... BAGN from BAG1 *)
(PROG (ANSWER)
(SETQ ANSWER (CAR BAGS))
(FOR BAG IN (CDR BAGS) DO (SETQ ANSWER (BSUBTRACTQ2 ANSWER BAG)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(BSUBTRACT
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (BAGS) (* Subtract BAG2 ... BAGN from BAG1 *)
(PROG (ANSWER)
(SETQ ANSWER (CAR BAGS))
(FOR BAG IN (CDR BAGS) DO (SETQ ANSWER (BSUBTRACT2 ANSWER BAG)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(BUNIONQ2
(LAMBDA (A B) (* kbr: "21-Jul-84 21:56")
(* BUNION OF BAGS A AND B)
(APPEND A B)))
(BUNION2
(LAMBDA (A B) (* kbr: "21-Jul-84 21:56")
(* BUNION OF BAGS A AND B)
(APPEND A B)))
(BUNIONQ
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (BAGS) (* BUNION OF N BAGS)
(APPLY 'APPEND BAGS))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(BUNION
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (BAGS) (* BUNION OF N BAGS)
(APPLY 'APPEND BAGS))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(BINTERSECTQ2
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* Bag X intersect bag Y *)
(PROG (XALIST YALIST XBUCKET ALIST ANSWER)
(COND
((EQ X Y) (* Optimized case *)
(RETURN X)))
(SETQ XALIST (BALISTQ X))
(SETQ YALIST (BALISTQ Y))
(FOR YBUCKET IN YALIST
DO (SETQ XBUCKET (ASSOC (CAR YBUCKET)
XALIST))
(COND
(XBUCKET (PUSH ALIST (CONS (CAR XBUCKET)
(IMIN (CDR XBUCKET)
(CDR YBUCKET)))))))
(SETQ ANSWER (BUNALIST ALIST))
(RETURN ANSWER))))
(BINTERSECT2
(LAMBDA (X Y) (* kbr: "21-Jul-84 21:56")
(* Bag X intersect bag Y *)
(PROG (XALIST YALIST XBUCKET ALIST ANSWER)
(COND
((EQ X Y) (* Optimized case *)
(RETURN X)))
(SETQ XALIST (BALIST X))
(SETQ YALIST (BALIST Y))
(FOR YBUCKET IN YALIST
DO (SETQ XBUCKET (SASSOC (CAR YBUCKET)
XALIST))
(COND
(XBUCKET (PUSH ALIST (CONS (CAR XBUCKET)
(IMIN (CDR XBUCKET)
(CDR YBUCKET)))))))
(SETQ ANSWER (BUNALIST ALIST))
(RETURN ANSWER))))
(BINTERSECTQ
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (BAGS) (* INTERSECTION OF N BAGS)
(PROG (ANSWER)
(SETQ ANSWER (CAR BAGS))
(FOR BAG IN (CDR BAGS) DO (SETQ ANSWER (BINTERSECTQ2 ANSWER BAG)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
(BINTERSECT
(LAMBDA $EXPR$ (* kbr: "21-Jul-84 21:56")
((LAMBDA (BAGS) (* INTERSECTION OF N BAGS)
(PROG (ANSWER)
(SETQ ANSWER (CAR BAGS))
(FOR BAG IN (CDR BAGS) DO (SETQ ANSWER (BINTERSECT2 ANSWER BAG)))
(RETURN ANSWER)))
(FOR I FROM 1 TO $EXPR$ COLLECT (ARG $EXPR$ I)))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA BINTERSECT BINTERSECTQ BUNION BUNIONQ BSUBTRACT BSUBTRACTQ LINTERSECT LINTERSECTQ
LUNION LUNIONQ LSUBTRACT LSUBTRACTQ)
)
(PUTPROPS LSET COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1735 18873 (LUNIFYQ 1745 . 2038) (LUNIFY 2040 . 2334) (LSETIFYQ 2336 . 2709) (LSETIFY
2711 . 3085) (LSETQP 3087 . 3294) (LSETP 3296 . 3506) (LSUBSETQ 3508 . 3856) (LSUBSET 3858 . 4204) (
LEQUAL 4206 . 4471) (LEQUALQ 4473 . 4741) (LSUBTRACTQ2 4743 . 5145) (LSUBTRACT2 5147 . 5550) (
LSUBTRACTQ 5552 . 6036) (LSUBTRACT 6038 . 6519) (LUNIONQ2 6521 . 6858) (LUNION2 6860 . 7195) (LUNIONQ
7197 . 7581) (LUNION 7583 . 7965) (LINTERSECTQ2 7967 . 8360) (LINTERSECT2 8362 . 8756) (LINTERSECTQ
8758 . 9194) (LINTERSECT 9196 . 9630) (BUNIFYQ 9632 . 9855) (BUNIFY 9857 . 10079) (BALISTQ 10081 .
10528) (BALIST 10530 . 10977) (BUNALIST 10979 . 11369) (BSUBBAGQ 11371 . 12000) (BSUBBAG 12002 . 12630
) (BEQUAL 12632 . 12785) (BEQUALQ 12787 . 12943) (BSUBTRACTQ2 12945 . 13776) (BSUBTRACT2 13778 . 14608
) (BSUBTRACTQ 14610 . 15056) (BSUBTRACT 15058 . 15502) (BUNIONQ2 15504 . 15720) (BUNION2 15722 . 15937
) (BUNIONQ 15939 . 16225) (BUNION 16227 . 16512) (BINTERSECTQ2 16514 . 17255) (BINTERSECT2 17257 .
17997) (BINTERSECTQ 17999 . 18435) (BINTERSECT 18437 . 18871)))))
STOP