;;; list-set.scm -- Jens Axel Søgaard (module list-set mzscheme ;(print-struct #t) (require (lib "67.ss" "srfi") ; compare (all-except (lib "list.ss") empty empty? remove remove*) (lib "26.ss" "srfi") (lib "42.ss" "srfi")) ;; an LSET consists of a compare functions ;; and a sorted (w.r.t to the compare function) ;; list of elements (define-struct lset (compare elements) (make-inspector)) ; set? : object -> boolean (define (set? o) (lset? o)) ; empty : [compare] -> set (define empty (case-lambda [() (empty (current-compare))] [(cmp) (make-lset cmp '())])) ; empty? : set -> boolean (define (empty? s) (null? (lset-elements s))) ; find-min : set -> element (define (find-min s) (when (empty? s) (error 'find-min "an empty set does not have a minimum element")) (car (lset-elements s))) (define (delete-min s) (delete (find-min s) s)) ; singleton : [compare] element -> set (define singleton (case-lambda [(x) (singleton (current-compare) x)] [(cmp x) (make-lset cmp (list x))])) ; elements : set -> list (define (elements s) (lset-elements s)) ; select : set -> element (define (select s) (if (empty? s) (error 'select "can't select an element from an empty set") (car (lset-elements s)))) ; size : set -> integer (define (size s) (length (elements s))) ; list-sorted? : compare list -> boolean (define (list-sorted? cmp xs) (or (null? xs) (null? (cdr xs)) (and (if<=? cmp (car xs) (cadr xs)) (list-sorted? cmp (cdr xs))))) ; list-merge : compare list list -> list ; merge two cmp-sorted lists (define (list-merge cmp xs ys) (cond [(null? xs) ys] [(null? ys) xs] [else (let ([x (car xs)] [y (car ys)]) (if<=? (cmp x y) (cons x (list-merge cmp (cdr xs) ys)) (cons y (list-merge cmp xs (cdr ys)))))])) ; list-split : list -> list list ; splits a list xs into two lists ys and zs, ; s.t. ys and zs are half as long as xs ; and (append ys zs) is a permutation of xs (define (list-split xs) (cond [(null? xs) (values '() '())] [(null? (cdr xs)) (values xs '())] [else (let-values ([(ys zs) (list-split (cddr xs))]) (values (cons (car xs) ys) (cons (cadr xs) zs)))])) ; list-sort : compare list -> list (define (list-sort cmp xs) (cond [(null? xs) '()] [(null? (cdr xs)) xs] [else (let-values ([(ys zs) (list-split xs)]) (list-merge cmp (list-sort cmp ys) (list-sort cmp zs)))])) (define (union s1 s2) (let ([cmp (lset-compare s1)]) (make-lset cmp (list-union cmp (elements s1) (elements s2))))) (define (union/combiner s1 s2 combine) (let ([cmp (lset-compare s1)]) (make-lset cmp (list-union/combiner cmp (elements s1) (elements s2) combine)))) (define (intersection s1 s2) (let ([cmp (lset-compare s1)]) (make-lset cmp (list-intersection cmp (elements s1) (elements s2))))) (define (intersection/combiner s1 s2 combine) (let ([cmp (lset-compare s1)]) (make-lset cmp (list-intersection/combiner cmp (elements s1) (elements s2) combine)))) (define (difference s1 s2) (let ([cmp (lset-compare s1)]) (make-lset cmp (list-difference cmp (elements s1) (elements s2))))) (define (subset? s1 s2) (let ([cmp (lset-compare s1)]) (list-subset? cmp (elements s1) (elements s2)))) (define (equal=? s1 s2) (let ([cmp (lset-compare s1)]) (list-equal=? cmp (elements s1) (elements s2)))) ; list-union : compare list list -> list (define (list-union cmp xs ys) (list-union/combiner cmp xs ys (lambda (x y) x))) ; list-union/combiner : compare list list (element element -> element) -> list (define (list-union/combiner cmp xs ys combine) ; xs and ys are cmp-sorted (cond [(null? xs) ys] [(null? ys) xs] [else (let ([x (car xs)] [y (car ys)]) (if3 (cmp x y) (cons x (list-union/combiner cmp (cdr xs) ys combine)) (cons (combine x y) (list-union/combiner cmp (cdr xs) (cdr ys) combine)) (cons y (list-union/combiner cmp xs (cdr ys) combine))))])) ; list-intersection : compare list list -> list (define (list-intersection cmp xs ys) (list-intersection/combiner cmp xs ys (lambda (x y) x))) ; list-intersection/combiner : compare list list (element element -> element) -> list (define (list-intersection/combiner cmp xs ys combine) ; xs and ys are cmp-sorted (cond [(null? xs) '()] [(null? ys) '()] [else (let ([x (car xs)] [y (car ys)]) (if3 (cmp x y) (list-intersection/combiner cmp (cdr xs) ys combine) (cons (combine x y) (list-intersection/combiner cmp (cdr xs) (cdr ys) combine)) (list-intersection/combiner cmp xs (cdr ys) combine)))])) ; list-difference : compare list list -> list (define (list-difference cmp xs ys) ; xs and ys are cmp-sorted (cond [(null? ys) xs] [(null? xs) '()] [else (let ([x (car xs)] [y (car ys)]) (if3 (cmp x y) (cons x (list-difference cmp (cdr xs) ys)) (list-difference cmp (cdr xs) (cdr ys)) (list-difference cmp xs (cdr ys))))])) ; list-insert : compare element list -> list ; given x and the cmp-sorted list xs, ; returns (sort cmp (cons x xs)) (define (list-insert cmp x xs) ; insert x into xs, which is sorted w.r.t. cmp (cond [(null? xs) (list x)] [else (let ([y (car xs)]) (if3 (cmp x y) (cons x xs) (cons x (cdr xs)) ; keep the last representative (cons y (list-insert cmp x (cdr xs)))))])) ; list-insert/combiner : compare element list (element element -> element) -> list ; given x and the cmp-sorted list xs, ; returns (sort cmp (cons x xs)) (define (list-insert/combiner cmp x xs combine) ; insert x into xs, which is sorted w.r.t. cmp (cond [(null? xs) (list x)] [else (let ([y (car xs)]) (if3 (cmp x y) (cons x xs) (cons (combine x y) (cdr xs)) (cons y (list-insert/combiner cmp x (cdr xs) combine))))])) (define (list-subset? cmp xs ys) (cond [(null? xs) #t] [(null? ys) #f] [else (let ([x (car xs)] [y (car ys)]) (if3 (cmp x y) #f (list-subset? cmp (cdr xs) (cdr ys)) (list-subset? cmp xs (cdr ys))))])) (define (list-equal=? cmp xs ys) (cond [(and (null? xs) (null? ys)) #t] [(null? xs) #f] [(null? ys) #f] [(cmp (car xs) (car ys)) (list-equal=? cmp (cdr xs) (cdr ys))] [else #f])) (define member? (case-lambda [(x s) (list-member? (lset-compare s) x (lset-elements s))] [(cmp x s) (if (eq? cmp (lset-compare s)) (member? x s) (member? x (list-sort cmp s)))])) (define get (case-lambda [(x s) (list-get (lset-compare s) x (lset-elements s))] [(cmp x s) (if (eq? cmp (lset-compare s)) (get x s) (get x (list-sort cmp s)))])) (define (insert x s) (let ([cmp (lset-compare s)]) (make-lset cmp (list-insert cmp x (lset-elements s))))) (define (insert/combiner x s combine) (let ([cmp (lset-compare s)]) (make-lset cmp (list-insert/combiner cmp x (lset-elements s) combine)))) (define (insert* xs s) (foldl insert s xs)) (define (insert*/combiner xs s combine) (foldl (lambda (x s) (insert/combiner x s combine)) s xs)) (define (list-member? cmp x xs) (and (not (null? xs)) (or (=? cmp x (car xs)) (and (not (<? cmp x (car xs))) (list-member? cmp x (cdr xs)))))) (define (list-get cmp x xs) (cond [(null? xs) #f] [else (if3 (cmp x (car xs)) #f (car xs) (list-get cmp x (cdr xs)))])) (define (delete x s) (difference s (singleton (lset-compare s) x))) (define (delete-all x s) (delete x s)) (define (delete* xs s) (difference s (list->set (lset-compare s) xs))) (define (fold f init s) (foldl f init (lset-elements s))) (define (list-remove-duplicates cmp xs) ; removes removes duplicates from an sorted list (cond [(null? xs) xs] [(null? (cdr xs)) xs] [(=? cmp (car xs) (cadr xs)) (list-remove-duplicates cmp (cdr xs))] [else (cons (car xs) (list-remove-duplicates cmp (cdr xs)))])) (define list->set (case-lambda [(xs) (list->set (current-compare) xs)] [(cmp xs) (foldl insert (empty cmp) xs)])) (define list->set/combiner (case-lambda [(xs combine) (list->set (current-compare) xs combine)] [(cmp xs combine) (foldl (lambda (x s) (insert/combiner x s combine)) (empty cmp) xs)])) (define (set . xs) (list->set xs)) ;; support for srfi-42 (define-syntax set-ec (syntax-rules () [(_ cmp etc1 etc ...) (fold-ec (empty cmp) etc1 etc ... insert)])) (define-syntax :set (syntax-rules (index) ((:set cc var (index i) arg) (:parallel cc (:stack var arg) (:integers i)) ) ((:set cc var arg) (:do cc (let ()) ((t (lset-elements arg))) (not (null? t)) (let ((var (car t)))) #t ((cdr t)) )))) (define (:set-dispatch args) (cond [(null? args) 'set] [(and (= (length args) 1) (set? (car args))) (:generator-proc (:set (car args)))] [else #f])) (:-dispatch-set! (dispatch-union (:-dispatch-ref) :set-dispatch)) ;;; PROVIDE SET FUNCTIONS (require "signatures/set-signature.scm") (provide-set) )