(define arbitrary<? (lambda (a b) (let* ((type-of (lambda (i) (cond ((null? i) 0) ((pair? i) 1) ((boolean? i) 2) ((symbol? i) 3) ((char? i) 4) ((vector? i) 5) ((number? i) 6) ((string? i) 7) (else (error 'arbitrary<? "bad inputs" (list a b)))))) (type-a (type-of a)) (type-b (type-of b))) (or (< type-a type-b) (and (= type-a type-b) (> type-a 0) (case type-a ((1) (or (arbitrary<? (car a) (car b)) (and (not (arbitrary<? (car b) (car a))) (arbitrary<? (cdr a) (cdr b))))) ((2) (and b (not a))) ; #f<#t ((3) (string<? (symbol->string a) (symbol->string b))) ((4) (char<? a b)) ((5) (arbitrary<? (vector->list a) (vector->list b))) ((6) (< a b)) ((7) (string<? a b)))))))) (define list->set (lambda (ls) (remove-duplicates (sort arbitrary<? ls)))) (define set->list (lambda (ls) ls)) (define remove-duplicates (lambda (set) (letrec ((loop (lambda (ls acc) (if (or (null? ls) (null? (cdr ls))) (append (reverse acc) ls) (if (equal? (car ls) (cadr ls)) (loop (cdr ls) acc) (loop (cdr ls) (cons (car ls) acc))))))) (loop set ())))) (define set+ (lambda args (letrec ((loop (lambda (ls) (if (null? (cdr ls)) ls (loop (cons (merge arbitrary<? (car ls) (cadr ls)) (cddr ls))))))) (if (null? args) () (remove-duplicates (car (loop args))))))) (define set-union set+) (define set-or set+) (define set- (lambda (set1 set2 . rest) (letrec ((loop (lambda (ls1 ls2 acc) (cond ((or (null? ls1) (null? ls2)) (append (reverse acc) ls1)) ((arbitrary<? (car ls1) (car ls2)) (loop (cdr ls1) ls2 (cons (car ls1) acc))) ((equal? (car ls1) (car ls2)) (loop (cdr ls1) (cdr ls2) acc)) (else (loop ls1 (cdr ls2) acc)))))) (if (null? rest) (loop set1 set2 ()) (apply set- (loop set1 set2 ()) rest))))) (define set-intersection (lambda (set1 . rest) (if (null? rest) set1 (letrec ((loop (lambda (ls1 ls2 acc) (cond ((or (null? ls1) (null? ls2)) (reverse acc)) ((arbitrary<? (car ls1) (car ls2)) (loop (cdr ls1) ls2 acc)) ((equal? (car ls1) (car ls2)) (loop (cdr ls1) (cdr ls2) (cons (car ls1) acc))) (else (loop ls1 (cdr ls2) acc)))))) (apply set-intersection (loop set1 (car rest) ()) (cdr rest)))))) (define set-intersect set-intersection) (define set-isect set-intersection) (define set-and set-intersection) (define set? (lambda (expr) (or (null? expr) (and (pair? expr) (or (null? (cdr expr)) (and (pair? (cdr expr)) (arbitrary<? (car expr) (cadr expr)) (set? (cdr expr)))))))) (define set-member? (lambda (item set) (and (not (null? set)) (or (equal? item (car set)) (and (not (arbitrary<? item (car set))) (set-member? item (cdr set))))))) (define set-insert (lambda (item set) (set+ set (list item)))) (define set-remove (lambda (item set) (set- set (list item)))) (define null-set ()) (define set-car car) (define set-cdr cdr) (define make-flatten-1 (lambda (proc) (lambda args (apply append (apply proc args))))) (define amap (make-flatten-1 map)) (define map* (lambda (func arg1 . args) (if (null? args) (map func arg1) (amap (lambda (a1) (apply map* (lambda a* (apply func a1 a*)) args)) arg1)))) (define amap* (make-flatten-1 map*)) (define filter (lambda (func data) (amap (lambda (d) (if (func d) (list d) ())) data))) (define bool-filter (lambda (bools data) (amap (lambda (b d) (if b (list d) ())) bools data))) (define filter* (lambda (test combine data1 . data*) (apply amap* (lambda args (if (apply test args) (list (apply combine args)) ())) data1 data*))) (define merge (lambda (cmp< list1 list2) (letrec ((loop (lambda (list1 list2 acc) (cond ((null? list1) (append (reverse acc) list2)) ((null? list2) (append (reverse acc) list1)) ((cmp< (car list1) (car list2)) (loop (cdr list1) list2 (cons (car list1) acc))) (else (loop list1 (cdr list2) (cons (car list2) acc))))))) (loop list1 list2 ())))) (define mergesort (lambda (cmp< ls) (letrec ((group (lambda (ls cur acc) ; gather presorted terms (cond ((null? ls) (reverse (cons (reverse cur) acc))) ((or (null? cur) (cmp< (car cur) (car ls))) (group (cdr ls) (cons (car ls) cur) acc)) (else (group (cdr ls) (list (car ls)) (cons (reverse cur) acc)))))) (loop (lambda (ls acc) ; do a pass of mergesort (cond ((null? ls) (reverse acc)) ((null? (cdr ls)) (reverse (cons (car ls) acc))) (else (loop (cddr ls) (cons (merge cmp< (car ls) (cadr ls)) acc)))))) (do-loop (lambda (ls) ; loop until it is sorted (if (null? (cdr ls)) (car ls) (do-loop (loop ls ())))))) (if (null? ls) () (do-loop (group ls () ())))))) (define sort mergesort) (define longest (lambda (lss) (cadar (mergesort (lambda (i j) (> (car i) (car j))) (map (lambda (ls) (list (length ls) ls)) lss))))) (define permute (lambda (ls) (letrec ((loop (lambda (ls) (if (null? ls) '(()) (let ((a (loop (cdr ls)))) (amap (lambda (i) (list i (cons (car ls) i))) a)))))) (loop ls)))) (define power-set? (lambda (in) (let* ((set (list->set (map list->set in))) (s (longest set)) (ps (list->set (map list->set (permute s))))) (display (list 'set= set))(newline) (display (list 's= s))(newline) (display (list 'ps= ps))(newline) (if (equal? set ps) 'good 'bad))))