union

This is a binary operation producing the union of two sets. union returns false if both objects are not sets.

(define metaset '(union sset (set sol)))

(define union
(function metaset ((obj1 metaset)
(obj2 metaset))
(letrec

; Procedure to compute the union of two explicit sets, (represnted as
; lists) and return the result (also represented as a list). Because
; this code is called for both ordered and unordered sets, it should
; maintain ordering (as much as possible).

; Actually above documentation is not true. Procedure calculates
; b-minus-a, which can be used to describe union in combination with
; original set B

((union-explicit-simplify
(lambda (a b b-minus-a)

; A and B are lists containing
; the members of the input
; sets, and UNION-A-B is a
; list containing the elements
; of the union of the
; two sets. A should be no
; larger than B for optimal
; efficiency.

(if (equal? a '()) ; Is A empty?
; We're done - return union.
; Reverse is called to maintain
; order.

(reverse b-minus-a)

; A not empty. Check to see if
; (car A) in B...

(if (member (car a) b)

; ...it is. That means we
; don't need to add it to
; B-MINUS-A.

(union-explicit-simplify (cdr a) b b-minus-a)

; It's not in B. Add it to
; B-MINUS-A.

(union-explicit-simplify
(cdr a) b (cons (car a) b-minus-a))))))

; This function calculates the union of a core and an explicit
; set. Every member of the explicit set is checked for membership in
; the core set.

(union-core-explicit
(lambda (a b b-minus-a)

; A is the symbolic name of
; the core set. B is
; the derived set represented
; as a list. This function
; returns a list of those
; elments of B not in A.

(if (equal? b '()) ; Is B empty? We're done.

(reverse b-minus-a)

; B not empty. Check to see
; if the first element of B is
; in A.

(if (in? (car b) a)
; It is. Don't add it to the list.

(union-core-explicit a (cdr b) b-minus-a)

; It's not. Add it to B-MINUS-A.

(union-core-explicit
a (cdr b) (cons (car b) b-minus-a)))))))

; ********************************
; Beginning of main UNION routine.
; ********************************

(cond

; Check to see if either
; object is the SOL set. If
; so, return SOL.

((or (eq? obj1 sol) (eq? obj2 sol))
'sol)

; See if obj1 and obj2 are the
; same thing. If so, return
; obj1.

((eq? obj1 obj2)
obj1)

; Now check the first object
; against the core sets.

((core? obj1)
; OBJ1 is a member of CORE.
(cond
((core? obj2)

;; We know that both OBJ1 and OBJ2 are core. This section is devoted
;; to case-by-case matching for simplification.

(case obj1
; If OBJ1 is SSET
((sset)
(case obj2

; The union of SSET and any
; other set-containing set is
; SSET.

((sordered unordered
fundamental core explicit derived) 'sset)
(else (list 'union obj1 obj2))))

; If OBJ1 is SORDERED
((sordered)
(case obj2

; The union of SSET or
; UNORDERED and ORDERED
; produces SSET.

((sset unordered) 'sset)
(else (list 'union obj1 obj2))))

; If OBJ1 is UNORDERED
((unordered)
(case obj2

; The union of SSET or ORDERED
; and UNORDERED results in
; SSET.

((sset sordered) 'sset)

; The union of UNORDERED and
; unordered core sets which do
; not contian orderd sets
; results in UNORDERED.

((pair slist
procedure boolean)
'unordered)
(else (list 'union obj1 obj2))))

; If OBJ1 is FUNDAMENTAL

((fundamental)
(case obj2

; The union of FUNDAMENTAL and
; DERIVED is SSET.

((sset derived) 'sset)
((core explicit) 'fundamental)
(else (list 'union obj1 obj2))))

; OBJ1 is CORE

((core)
(case obj2
((sset) 'sset)
((fundamental) 'fundamental)
; The union of CORE and
; EXPLICIT is DERIVED.
((explicit) 'fundamental)
(else (list 'union obj1 obj2))))

((explicit)
(case obj2
((sset) 'sset)
((fundamental) 'fundamental)
; The union of CORE and
; EXPLICIT is DERIVED.
((core) 'fundamental)
(else (list 'union obj1 obj2))))

; If OBJ1 is DERIVED
((derived)
(case obj2
; The union of FUNDAMENTAL and
; DERIVED is SSET.

((sset fundamental) 'sset)
(else (list 'union obj1 obj2))))

; OBJ1 is NUMBER

((number)
(case obj2
((complex real rational integer) 'number)
(else (list 'union obj1 obj2))))

; If OBJ1 is COMPLEX
((complex)
(case obj2
((number) 'number)
((real rational integer) 'complex)
(else (list 'union obj1 obj2))))

; If OBJ1 is REAL
((real)
(case obj2
((number) 'number)
((complex) 'complex)
((rational integer) 'real)
(else (list 'union obj1 obj2))))

; If OBJ1 is RATIONAL
((rational)
(case obj2
((number) 'number)
((complex) 'complex)
((real) 'real)
((integer) 'rational)
(else (list 'union obj1 obj2))))

; If OBJ1 is INTEGER
((integer)
(case obj2
((number) 'number)
((complex) 'complex)
((real) 'real)
((rational) 'rational)
(else (list 'union obj1 obj2))))

; If OBJ1 is SSTRING,
; SYMBOL, or CHAR

((sstring symbol char)
(list 'union obj1 obj2))

; If OBJ1 is PAIR

((pair)
(case obj2
((slist) 'pair)
(else (list 'union obj1 obj2))))

; If OBJ1 is SLIST

((slist)
(case obj2
((pair) 'pair)
(else (list 'union obj1 obj2))))

; If OBJ1 is PROCEDURE or BOOLEAN

((procedure boolean)
(list 'union obj1 obj2))))

;; In this section we deal with the case of OBJ1 being a core set and
;; OBJ2 being an explicit set. Basically, we call union-core-explicit
;; and be done with it.

((explicit? obj2)

; OBJ1 is CORE, and OBJ2 is
; EXPLICIT.

(let ((val2 (set->list obj2)))

; Call union-core-explicit.

(let ((result (union-core-explicit obj1 val2 '())))

(if (null? result)
obj1

; If both are ordered...

(if (and (ordered? obj1) (ordered? obj2))

; Return the symbolic union of
; obj2 (core) and the
; ordered results of calling
; union-core-explicit
; with obj2 and the contents
; of obj1.

(list 'union obj1
(list->ordered result))

; One or both are not ordered.
; Return the symbolic union of
; obj2 and the unordered
; results of calling
; union-core-explicit.

(list 'union obj1
(list->unordered result)))))))


;; In this section we deal with the case of OBJ1 being a core set and
;; OBJ2 being a derived set. This is kind of tricky, because the
;; simplification of some states are not clear. I will probably have
;; to rewrite it at some point.

((derived? obj2)

(letrec ((operation (car obj2))
(operand1 (cadr obj2))
(operand2 (caddr obj2)))

(cond
; If the operation is union...
((eq? operation 'union)
(let ((result1 (union obj1 operand1))
(result2 (union obj1 operand2)))
(cond
((core? result1)
(list 'union result1 operand2))
((core? result2)
(list 'union operand1 result2))
(else
(list 'union obj1 obj2)))))

; Intersection...

((eq? operation 'intersection)
(cond
((subset? obj2 obj1)
obj1)
((subset? obj1 obj2)
obj2)
(else
(list 'union obj1 obj2))))

; Difference.

((eq? operation 'difference)
(cond
((subset? obj2 obj1)
obj1)
((subset? obj1 obj2)
obj2)
(else
(list 'union obj1 obj2))))

(else (error "union: Bad derived set:" obj2)))))
((classType? obj2)
(list union obj1 obj2))
(else (error "union: argument not a set: " obj2))))


;; We have now exhausted the possibilities for OBJ1 being a core set.
;; Moving on to the case where OBJ1 is an explicit set...

; Is object1 an explicit set?
((explicit? obj1)
; Is OBJ2 a core set?
(cond
((core? obj2)

; We've already coded the
; union of a core and explicit
; set, so swap the order of
; the arguments and
; recursively call UNION.
(union obj2 obj1))


;; Deal with the case of both OBJ1 and OBJ2 being explicit sets.

; Construct the union of two
; explicit sets.
((explicit? obj2)

; Convert both sets to lists.

(let ((val1 (set->list obj1))
(val2 (set->list obj2)))

; Are we simplifying?

(if (> global-auto-simplify 0)
; If both sets are ordered

(if (and (ordered? obj1) (ordered? obj2))

; Return the ordered union
(list->ordered
(append (union-explicit-simplify val1 val2 '()) val2))

; One or both of the sets is
; not an ordered set. The
; result will not be ordered.

(list->unordered
(append (union-explicit-simplify val1 val2 '()) val2)))

; Same thing but no simplification.

(if (and (ordered? obj1) (ordered? obj2))

; Return the ordered union
(list->ordered
(append val1 val2))

; One or both of the sets is
; not an ordered set. The
; result will not be ordered.

(list->unordered
(append val1 val2))))))


;; The first object is explicit and the second object is neither core
;; nor explicit. See if it's derived...

((derived? obj2)

(letrec ((operation (car obj2))
(operand1 (cadr obj2))
(operand2 (caddr obj2)))

(cond
; If the operation is union...
((eq? operation 'union)

; Subtract both operands from
; obj1 and see what we're left
; with.

(let ((result (difference operand2
(difference operand1 obj1))))

; If it's null, return OBJ2.

(if (null? (set->list result))
obj2
; Otherwise...
(list 'union result obj2))))

; Intersection...

((eq? operation 'intersection)
(cond
((subset? obj2 obj1)
obj1)
((subset? obj1 obj2)
obj2)
(else
(list 'union obj1 obj2))))

; Difference.

((eq? operation 'difference)
(cond
((subset? obj2 obj1)
obj1)
((subset? obj1 obj2)
obj2)
(else
(list 'union obj1 obj2))))

(else (error "union: Bad derived set: " obj2)))))
((classType? obj2)
(list union obj1 obj2))
(else (error "union: Second argument not a set: " obj2))))


;; We know that obj1 is neither core nor explicit. The only other
;; (legal) possibilities are that it is a derived or class type set.
;; Fortunately, we have coded for most of these combinations
;; already...

((fundamental? obj1)
(cond
((core? obj2)
(union obj2 obj1))
((explicit? obj2)
(union obj2 obj1))

; The only combination we have
; left to wory about is the
; union of a derived and a
; derived set.

((derived? obj2)

; There are nine special cases
; to worry about. At this
; point I'm just going to set
; up the framework, then punt.

(letrec ((op1 (car obj1))
(A (cadr obj1))
(B (caddr obj1))
(op2 (car obj2))
(C (cadr obj2))
(D (caddr obj2)))

; Just return the unsimplified
; expression.

(list 'union obj1 obj2)))
((classType? obj2)
(list union obj1 obj2))
(else (error "union: second argument not a set: " obj2))))
(else (error "union: first argument not a set: " obj1))))))