haskeem-0.7.5: set.scm

; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>
; $Id: set.scm,v 1.9 2009-06-29 00:25:19 uwe Exp $
; BSD3

; This could all go into stdlib?

; set operations:
;	is a given element in a set?
;	add an element to a set
;	remove an element from a set
;	find the union of two sets
;	find the intersection of two sets
; a set is a list of elements, not necessarily sorted
; specialized versions "set" -> "intset" where we assert that the
; elements are integers, so that the list is simply sortable -> faster
; more specialized versions "set" -> "bitset", where each set is simply
; a single infinite-precision integer, and we just flip bits; that means
; that the individual elements again have to be integers

; Create a new empty set

(define (set-new) '())
(define (intset-new) '())
(define (bitset-new) 0)

; Test if el is in set

(define (set-member? set el)
  (cond ((null? set) #f)
	((eqv? el (car set)) #t)
	(else (set-member? (cdr set) el))))

(define (intset-member? set el)
  (cond ((null? set) #f)
	((< el (car set)) #f)
	((eqv? el (car set)) #t)
	(else (intset-member? (cdr set) el))))

(define (bitset-member? set el) (bits-set? set el))

; Test if a set is empty

(define (set-empty? set) (null? set))

(define intset-empty? set-empty?)

(define bitset-empty? zero?)

; Return a new set containing el

(define (set-add set el)
  (if (set-member? set el) set (cons el set)))

(define (intset-add set el)
  (unless (integer? el)
	  (raise "non-integer input to intset-add"))
  (if (intset-member? set el) set (list-sort < (cons el set))))

(define (bitset-add set el)
  (bits-set set el))

; Return a new set not containing el

(define (set-remove set el)
  (filter (lambda (x) (not (eqv? x el))) set))

(define intset-remove set-remove)

(define (bitset-remove set el)
  (bits-clear set el))

; Return a new set without duplications

(define (set-remove-dups set)
  (letrec ((srd (lambda (s a)
		  (if (null? s)
		      (reverse a)
		      (srd (filter (lambda (x) (not (eqv? x (car s))))
				   (cdr s))
			   (cons (car s) a))))))
    (srd set '())))

(define (intset-remove-dups set)
  (letrec ((srd (lambda (l a)
		  (if (null? l)
		      (reverse a)
		      (srd (list-drop-while (lambda (x) (eqv? x (car l)))
					    (cdr l))
			   (cons (car l) a))))))
    (srd (list-sort < set) '())))

; D'oh!

(define (bitset-remove-dups set) set)

; Return the OR of two sets

; Really the set-remove-dups aren't needed, just append would be good enough,
; but this keeps the set smaller. Doing individual set-remove-dups before
; appending would be better if the sets are not already dup-free.

(define (set-or s1 s2) (set-remove-dups (append s1 s2)))

; For the integer versions of the various logical operations, list
; merges with the appropriate selectors work very well

(define (intset-or s1 s2)
  (cond ((intset-empty? s2) s1)
	((intset-empty? s1) s2)
	((< (car s1) (car s2)) (cons (car s1) (intset-or (cdr s1) s2)))
	((> (car s1) (car s2)) (cons (car s2) (intset-or s1 (cdr s2))))
	(else (cons (car s1) (intset-or (cdr s1) (cdr s2))))))

(define (bitset-or s1 s2) (bits-or s1 s2))

; Return those elements of s1 that are not also in s2

(define (set-andnot s1 s2)
  (if (null? s2)
      s1
      (set-andnot (set-remove s1 (car s2)) (cdr s2))))

(define (intset-andnot s1 s2)
  (cond ((intset-empty? s2) s1)
	((intset-empty? s1) '())
	((< (car s1) (car s2)) (cons (car s1) (intset-andnot (cdr s1) s2)))
	((> (car s1) (car s2)) (intset-andnot s1 (cdr s2)))
	(else (intset-andnot (cdr s1) (cdr s2)))))

(define (bitset-andnot s1 s2)
  (- s1 (bits-and s1 s2)))

; Return those elements which are in one or the other but not both sets

(define (set-xor s1 s2)
  (set-or (set-andnot s1 s2)
	  (set-andnot s2 s1)))

(define (intset-xor s1 s2)
  (cond ((intset-empty? s2) s1)
	((intset-empty? s1) s2)
	((< (car s1) (car s2)) (cons (car s1) (intset-xor (cdr s1) s2)))
	((> (car s1) (car s2)) (cons (car s2) (intset-xor s1 (cdr s2))))
	(else (intset-xor (cdr s1) (cdr s2)))))

(define (bitset-xor s1 s2) (bits-xor s1 s2))

; Return the intersection of two sets: those elements that are in both sets

(define (set-and s1 s2)
  (set-andnot (set-or s1 s2) (set-xor s1 s2)))

(define (intset-and s1 s2)
  (cond ((or (intset-empty? s1) (intset-empty? s2)) '())
	((< (car s1) (car s2)) (intset-and (cdr s1) s2))
	((> (car s1) (car s2)) (intset-and s1 (cdr s2)))
	(else (cons (car s1) (intset-and (cdr s1) (cdr s2))))))

(define (bitset-and s1 s2) (bits-and s1 s2))

; Check if two sets are equal

(define (set-equal? s1 s2) (set-empty? (set-xor s1 s2)))

(define (intset-equal? s1 s2)
  (cond ((and (intset-empty? s1) (intset-empty? s2)) #t)
	((or (intset-empty? s1) (intset-empty? s2)) #f)
	((= (car s1) (car s2)) (intset-equal? (cdr s1) (cdr s2)))
	(else #f)))

(define (bitset-equal? s1 s2) (= s1 s2))

; Given a bit-set, return a list of its members in an unspecified order
; (which happens to be descending order)

(define (bitset->list set)
  (letrec ((loop (lambda (s c l)
		   (cond ((zero? s) l)
			 ((even? s) (loop (bits-shift s -1) (+ c 1) l))
			 (else (loop (bits-shift s -1) (+ c 1) (cons c l)))))))
    (loop set 0 '())))

; Apply a function to each member of a set

(define (set-for-each set fn)
  (map fn set))

(define (intset-for-each set fn)
  (map fn set))

(define (bitset-for-each set fn)
  (map fn (bitset->list set)))