archive/share/trash/set.lisp

   1 ;FILENAME: SETM >
   2
   3 ;This file contains 2 packages for Set Theory -
   4 ;the first is for LISP and the second is for MACSYMA.
   5
   6
   7 ;The LISP Set Package:
   8
   9 ;contents of the LISP Set Package:
  10 ;INTERSECT+ INTERSECT2
  11 ;UNION+ UNION2
  12 ;COMPLEMENT
  13 ;SETDIFFERENCE
  14 ;SYMMDIFFERENCE
  15 ;POWERSET
  16 ;SETIFY
  17 ;SUBSET SUBLIST
  18 ;SETP
  19 ;SETEQUALP
  20 ;SUBSETP
  21 ;DISJOINTP
  22
  23
  24 ;auxiliary functions: XEROX
  25
  26
  27 (DECLARE #-NIL(MAPEX T)
  28          (SPECIAL CANONLT $CANONLT SUPERCANONLT)
  29          #-NIL(*FEXPR ERRM1 ERRM2)
  30          )
  31
  32
  33 (DEFmacro XEROX (X)
  34    (LIST 'APPEND (CADR X) NIL))
  35
  36 ;XEROX COPIES A LIST.
  37
  38
  39 (DEFUN INTERSECT+ N
  40    (DO ((X (LISTIFY N) (DO ((Y X (CDDR Y))
  41                   (A NIL (CONS (INTERSECT2 (CAR Y) (CADR Y)) A)))
  42                  ((NULL Y) A))))
  43        ((NULL (CDR X)) (CAR X))))
  44
  45
  46 (DEFUN INTERSECT2 (A B)
  47    (SETQ A (SETIFY A) B (SETIFY B))
  48    (PROG (U)
  49    1 (COND ((OR (NULL A) (NULL B))
  50             (RETURN (NREVERSE U)))
  51            ((FUNCALL CANONLT (CAR A) (CAR B))
  52             (SETQ A (CDR A)))
  53            ((FUNCALL CANONLT (CAR B) (CAR A))
  54             (SETQ B (CDR B)))
  55            (T (SETQ U (CONS (CAR A) U)
  56                     A (CDR A)
  57                     B (CDR B))))
  58      (GO 1)))
  59
  60
  61
  62 (DEFUN UNION+ N
  63    (DO ((X (LISTIFY N) (DO ((Y X (CDDR Y))
  64                   (A NIL (CONS (UNION2 (CAR Y) (CADR Y)) A)))
  65                  ((NULL Y) A))))
  66        ((NULL (CDR X)) (CAR X))))
  67
  68
  69 (DEFUN UNION2 (A B)
  70    (SETQ A (SETIFY A) B (SETIFY B))
  71    (PROG (U)
  72    1  (COND ((NULL A) (RETURN (APPEND (NREVERSE U) B)))
  73             ((NULL B) (RETURN (APPEND (NREVERSE U) A)))
  74             ((FUNCALL CANONLT (CAR A) (CAR B))
  75              (SETQ U (CONS (CAR A) U)
  76                    A (CDR A)))
  77             ((FUNCALL CANONLT (CAR B) (CAR A))
  78              (SETQ U (CONS (CAR B) U)
  79                    B (CDR B)))
  80             (T (SETQ U (CONS (CAR A) U)
  81                      A (CDR A)
  82                      B (CDR B))))
  83       (GO 1)))
  84
  85
  86 (DEFUN COMPLEMENT (A B)
  87    (SETQ A (SETIFY A) B (SETIFY B))
  88    (PROG (U)
  89    1  (COND ((NULL A) (RETURN (APPEND (NREVERSE U) B)))
  90             ((NULL B) (RETURN (NREVERSE U)))
  91             ((FUNCALL CANONLT (CAR A) (CAR B))
  92              (SETQ A (CDR A)))
  93             ((FUNCALL CANONLT (CAR B) (CAR A))
  94              (SETQ U (CONS (CAR B) U)
  95                    B (CDR B)))
  96             (T (SETQ A (CDR A) B (CDR B))))
  97       (GO 1)))
  98
  99
 100 (DEFUN SETDIFFERENCE (A B)  (COMPLEMENT B A))
 101
 102
 103 (DEFUN SYMMDIFFERENCE (A B)
 104    (UNION2 (COMPLEMENT A B) (COMPLEMENT B A)))
 105
 106
 107
 108 (DEFUN POWERSET (X)
 109    (SETQ X (SETIFY X))
 110    (DO ((X X (CDR X))
 111         (A (LIST NIL)))
 112        ((NULL X) (MAPCAR (FUNCTION REVERSE) (NREVERSE A)))
 113        (SETQ A
 114           (APPEND
 115              (DO ((A A (CDR A))
 116                   (Y (CAR X))
 117                   (B))
 118                  ((NULL A) (NREVERSE B))
 119                  (SETQ B (CONS (CONS Y (CAR A)) B)))
 120              A))))
 121
 122
 123
 124
 125 (DEFUN SETIFY (X)
 126    (COND ((SETP X) X)
 127          (T (SETQ X (SORT (XEROX X) SUPERCANONLT))
 128             (DO ((X (CDR X) (CDR X))
 129                  (Y (NCONS (CAR X)))
 130                  (A (CAR X)))
 131                 ((NULL X) (NREVERSE Y))
 132                 (COND ((FUNCALL CANONLT A (CAR X))
 133                        (SETQ A (CAR X) Y (CONS A Y))))))))
 134
 135
 136
 137 (DEFUN SUBSET (A F) (SUBLIST (SETIFY A) F))
 138
 139 (DEFUN SUBLIST (A F)
 140    (DO ((A A (CDR A))
 141         (X))
 142        ((NULL A) (NREVERSE X))
 143        (COND ((FUNCALL F (CAR A))
 144               (SETQ X (CONS (CAR A) X))))))
 145
 146
 147
 148 (DEFUN SETP (L)
 149    (DO ((L (CDR L) (CDR L))
 150         (A (CAR L) (CAR L)))
 151        ((NULL L) T)
 152        (OR (FUNCALL CANONLT A (CAR L))
 153            (RETURN NIL))))
 154
 155
 156
 157 (DEFUN SETEQUALP (A B)
 158    (AND (= (LENGTH A) (LENGTH B))
 159         (DO ((A A (CDR A))
 160              (B B (CDR B)))
 161             ((NULL A) T)
 162             (COND ((OR (FUNCALL CANONLT (CAR A) (CAR B))
 163                        (FUNCALL CANONLT (CAR B) (CAR A)))
 164                    (RETURN NIL))))))
 165
 166
 167 ;SETEQUALP ASSUMES A AND B ARE SETS
 168
 169 (DEFUN SUBSETP (A B)
 170    (SETQ A (SETIFY A) B (SETIFY B))
 171    (SETEQUALP A (INTERSECT2 A B)))
 172
 173
 174 (DEFUN DISJOINTP (A B)
 175    (NULL (INTERSECT2 A B)))
 176
 177
 178 ;The MACSYMA Set Package:
 179
 180 ;contents of MACSYMA Set Package:
 181 ;$INTERSECT $UNION
 182 ;$COMPLEMENT $SETDIFFERENCE $SYMMDIFFERENCE
 183 ;$POWERSET
 184 ;$SETIFY $SUBSET
 185 ;$SETP $SUBSETP $DISJOINTP
 186
 187
 188 ;auxiliary functions:
 189 ;INLIST OUTLIST SUBLISTM CANONLT-SET
 190
 191
 192
 193
 194 (DEFMACRO INLIST (X)
 195    (CONS 'CDR (CDR X)))
 196
 197
 198 (DEFMACRO OUTLIST (X)
 199    (LIST 'CONS
 200          (LIST 'QUOTE
 201                (LIST 'MLIST 'SIMP))
 202          (CADR X)))
 203
 204
 205
 206 (DEFUN $INTERSECT N
 207    ((LAMBDA (X CANONLT SUPERCANONLT)
 208       (COND ((LLISTP X)
 209              (CANONLT-SET)
 210              (OUTLIST
 211                  (APPLY (FUNCTION INTERSECT+)
 212                         (MAPCAR (FUNCTION INLIST) X))))
 213             (T (ERRM2  NIL '|INTERSECT| '|lists|))))
 214     (LISTIFY N)
 215     $CANONLT
 216     $CANONLT))
 217
 218
 219 (DEFUN $UNION N
 220    ((LAMBDA (X CANONLT SUPERCANONLT)
 221        (COND ((LLISTP X)
 222               (CANONLT-SET)
 223               (OUTLIST
 224                  (APPLY (FUNCTION UNION+)
 225                         (MAPCAR (FUNCTION INLIST) X))))
 226              (T (ERRM2 NIL '|UNION| '|lists|))))
 227     (LISTIFY N)
 228     $CANONLT
 229     $CANONLT))
 230
 231
 232 (DEFUN $COMPLEMENT (A B)
 233    (COND ((AND ($LISTP A) ($LISTP B))
 234           (OUTLIST
 235              ((LAMBDA (CANONLT SUPERCANONLT)
 236                  (CANONLT-SET)
 237                  (COMPLEMENT (INLIST A) (INLIST B)))
 238               $CANONLT
 239               $CANONLT)))
 240          (T (ERRM2 NIL '|COMPLEMENT| '|lists|))))
 241
 242
 243
 244 (DEFUN $SETDIFFERENCE (A B)
 245    (COND ((AND ($LISTP A) ($LISTP B))
 246           (OUTLIST
 247              ((LAMBDA (CANONLT SUPERCANONLT)
 248                  (CANONLT-SET)
 249                  (COMPLEMENT (INLIST B) (INLIST A)))
 250               $CANONLT
 251               $CANONLT)))
 252          (T (ERRM2 NIL '|SETDIFFERENCE| '|lists|))))
 253
 254
 255
 256 (DEFUN $SYMMDIFFERENCE (A B)
 257    (COND ((AND ($LISTP A) ($LISTP B))
 258           (OUTLIST
 259              ((LAMBDA (CANONLT SUPERCANONLT)
 260                  (CANONLT-SET)
 261                  (SYMMDIFFERENCE (INLIST A) (INLIST B)))
 262               $CANONLT
 263               $CANONLT)))
 264          (T (ERRM2 NIL '|SYMMDIFFERENCE| '|lists|))))
 265
 266
 267
 268
 269 (DEFUN $POWERSET (X)
 270    (COND (($LISTP X)
 271           ((LAMBDA (CANONLT SUPERCANONLT)
 272               (CANONLT-SET)
 273               (OUTLIST
 274                  (MAPCAR (FUNCTION OUTLIST)
 275                          (POWERSET (INLIST X)))))
 276            $CANONLT
 277            $CANONLT))
 278          (T (ERRM1 NIL '|POWERSET| '|a list|))))
 279
 280
 281
 282
 283 (DEFUN $SETIFY (X)
 284    (COND (($LISTP X)
 285           ((LAMBDA (CANONLT SUPERCANONLT)
 286               (CANONLT-SET)
 287               (OUTLIST (SETIFY (INLIST X))))
 288            $CANONLT
 289            $CANONLT))
 290          (T (ERRM1 NIL '|SETIFY| '|a list|))))
 291
 292
 293
 294 (DEFUN $SUBSET (A F)
 295    (COND (($LISTP A)
 296           (OUTLIST
 297              ((LAMBDA (CANONLT SUPERCANONLT)
 298                  (CANONLT-SET)
 299                  (SUBLISTM (INLIST A) F))
 300               $CANONLT
 301               $CANONLT)))
 302          (T (ERRM1 '|first| '|SUBSET| '|a list|))))
 303
 304
 305
 306
 307
 308 (DEFUN $SETP (X)
 309    (COND (($LISTP X)
 310           ((LAMBDA (CANONLT SUPERCANONLT)
 311               (CANONLT-SET)
 312               (SETP (INLIST X)))
 313            $CANONLT
 314            $CANONLT))
 315          (T (ERRM1 NIL '|SETP| '|a list|))))
 316
 317
 318
 319 (DEFUN $SUBSETP (A B)
 320    (COND ((AND ($LISTP A) ($LISTP B))
 321           ((LAMBDA (CANONLT SUPERCANONLT)
 322               (CANONLT-SET)
 323               (SUBSETP (INLIST A) (INLIST B)))
 324            $CANONLT
 325            $CANONLT))
 326          (T (ERRM2 NIL '|SUBSETP| '|lists|))))
 327
 328
 329
 330 (DEFUN $DISJOINTP (A B)
 331    (COND ((AND ($LISTP A) ($LISTP B))
 332           ((LAMBDA (CANONLT SUPERCANONLT)
 333               (CANONLT-SET)
 334               (DISJOINTP (INLIST A) (INLIST B)))
 335            $CANONLT
 336            $CANONLT))
 337          (T (ERRM2 NIL '|DISJOINTP| '|lists|))))
 338
 339
 340 (DEFUN LLISTP (L)
 341    (DO ((L L (CDR L)))
 342        ((NULL L) T)
 343        (OR ($LISTP (CAR L)) (RETURN NIL))))
 344
 345
 346
 347
 348 (DEFUN SUBLISTM (A F)
 349    (DO ((A A (CDR A))
 350         (X))
 351        ((NULL A) (NREVERSE X))
 352        (COND ((MEVALP (LIST (NCONS F) (CAR A)))
 353               (SETQ X (CONS (CAR A) X))))))
 354
 355
 356
 357
 358 (DEFUN CANONLT-SET NIL
 359    (OR (EQ $CANONLT '$ORDERLESSP)
 360        (SETQ CANONLT '(LAMBDA (X Y) (MCALL $CANONLT X Y))
 361              SUPERCANONLT '(LAMBDA (X Y)
 362                               (COND ((MCALL $CANONLT X Y) T)
 363                                     ((MCALL $CANONLT Y X) NIL)
 364                                     (T ($ORDERLESSP X Y)))))))
 365
 366
 367
 368 #-NIL(DECLARE (READ) (READ))
 369
 370 (DEFUN INLIST (X) (CDR X))
 371
 372 (DEFUN OUTLIST (X) (CONS '(MLIST SIMP) X))
 373
 374
 375 (SETQ $CANONLT '$ORDERLESSP
 376       CANONLT '$ORDERLESSP
 377       SUPERCANONLT '$ORDERLESSP)
 378
 379 (DEFUN ERRM0 (&rest X)
 380    (PRINC '|Incorrect argument syntax to function |)
 381    (PRINC (CAR X))
 382    (PRINC '|.|)
 383    (ERR))
 384
 385
 386 (DEFUN ERRM1 (&rest X)
 387    (PRINC '|The |)
 388    (COND ((CAR X)
 389           (PRINC (CAR X))
 390           (PRINC '| |)))
 391    (PRINC '|argument to |)
 392    (PRINC (CADR X))
 393    (PRINC '| must be |)
 394    (PRINC (CADDR X))
 395    (PRINC '|.|)
 396    (ERR))
 397
 398 (DEFUN ERRM2 (&rest X)
 399    (PRINC '|The |)
 400    (COND  ((CAR X)
 401            (PRINC (CAR X))
 402            (PRINC '| |)))
 403    (PRINC '|arguments to |)
 404    (PRINC (CADR X))
 405    (PRINC '| must be |)
 406    (PRINC (CADDR X))
 407    (PRINC '|.|)
 408    (ERR))