; http://caml.inria.fr/pub/docs/manual-ocaml/libref/Set.html ; http://cap-lore.com/code/Scheme/Set/ (lambda (Icompare) ; type t = Empty | Node of t * elt * t * int ; () | ((t . elt) . (t . int)) (let* ( (height (lambda (t) (if (null? t) 0 (cddr t)))) (create (lambda (l v r) (let ((hl (height l))(hr (height r))) (cons (cons l v) (cons r (+ (if (>= hl hr) hl hr) 1)))))) (bal (lambda (l v r) (let ((hl (height l))(hr (height r))) (if (> hl (+ hr 2)) (if (null? l) (invalid_arg "Set.bal") (let ((ll (caar l))(lv (cdar l))(lr (cadr l))) (if (>= (height ll) (height lr)) (create ll lv (create lr v r)) (if (null? lr) (invalid_arg "Set.bal") (let ((lrl (caar lr))(lrv (cdar lr))(lrr (cadr lr))) (create (create ll lv lrl) lrv (create lrr v r))))))) (if (> hr (+ hl 2)) (if (null? r) (invalid_arg "Set.bal") (let ((rl (caar r))(rv (cdar r))(rr (cadr r))) (if (>= (height rr)(height rl)) (create (create l v rl) rv rr) (if (null? rl) (invalid_arg "Set.bal") (let ((rll (caar rl))(rlv (cdar rl))(rlr (cadr rl))) (create (create l v rll) rlv (create rlr rv rr))))))) (cons (cons l v) (cons r (+ (if (>= hl hr) hl hr) 1)))))))) (add (lambda (e x) (let add ((x x)) (if (null? x) (cons (cons '() e) (cons '() 1)) (let* ((l (caar x))(v (cdar x))(r (cadr x))(c (Icompare e v))) (if (= c 0) x (if (< c 0) (bal (add l) v r) (bal l v (add r))))))))) (these (lambda (l) (let L ((l l)) (if (null? l) '() (add (car l) (L (cdr l))))))) (singleton (lambda (e) (cons (cons '() e) (cons '() 1)))) (add_min_element (lambda (v r) (let ain ((r r)) (if (null? r) (singleton v) (bal (ain (caar r)) (cdar r) (cadr r)))))) (add_max_element (lambda (v r) (let aax ((r r)) (if (null? r) (singleton v) (bal (caar r) (cdar r) (aax (cadr r))))))) (join (lambda (l v r) (let join ((l l)(r r)) (if (null? l) (add_min_element v r) (if (null? r) (add_max_element v l) (let ((ll (caar l))(lv (cdar l))(lr (cadr l))(lh (cddr l)) (rl (caar r))(rv (cdar r))(rr (cadr r))(rh (cddr r))) (if (> lh (+ rh 2)) (bal ll lv (join lr r)) (if (> rh (+ lh 2)) (bal (join l rl) rv rr) (create l v r))))))))) (min_elt (lambda (x) (let min_elt ((x x)) (if (null? x) (Not_found) (if (null? (caar x)) (cdar x) (min_elt (caar x))))))) (max_elt (lambda (x) (let max_elt ((x x)) (if (null? x) (Not_found) (if (null? (cadr x)) (cdar x) (max_elt (cadr x))))))) (remove_min_elt (lambda (x) (let remove_min_elt ((x x)) (if (null? x) (invalid_arg "Set.remove_min_elt") (if (null? (caar x)) (cadr x) (bal (remove_min_elt (caar x)) (cdar x) (cadr x))))))) (merge (lambda (t1 t2) (if (null? t1) t2 (if (null? t2) t1 ; bal t1 (min_elt t2) (remove_min_elt t2) (bal t1 (min_elt t2) (remove_min_elt t2)))))) (concat (lambda (t1 t2) (if (null? t1) t2 (if (null? t2) t1 (join t1 (min_elt t2) (remove_min_elt t2)))))) ; let rec split x = function ; Empty -> ; (Empty, false, Empty) ; | Node(l, v, r, _) -> ; let c = Ord.compare x v in ; if c = 0 then (l, true, r) ; else if c < 0 then ; let (ll, pres, rl) = split x l in (ll, pres, join rl v r) ; else ; let (lr, pres, rr) = split x r in (join l v lr, pres, rr) (split (lambda (x s) (let split ((s s)) (if (null? s) (list '() #f '()) (let* ((l (caar s))(v (cdar s))(r (cadr s))(c (Icompare x v))) (if (= c 0) (list l #t r) (if (< c 0) (let ((y (split l))) (list (car y) (cadr y) (join (caddr y) v r))) (let ((y (split r))) (list (join l v (car y)) (cadr y) (caddr y)))))))))) (empty '()) ; let rec mem x = function ; Empty -> false ; | Node(l, v, r, _) -> ; let c = Ord.compare x v in ; c = 0 || mem x (if c < 0 then l else r) (mem (lambda (x s) (let mem ((s s)) (and (not (null? s)) (let ((c (Icompare x (cdar s)))) (or (= c 0) (mem (if (< c 0) (caar s) (cadr s))))))))) (remove (lambda (x s) (let rem ((s s)) (if (null? s) '() (let* ((l (caar s))(v (cdar s))(r (cadr s))(c (Icompare x v))) (if (= c 0) (merge l r) (if (> c 0) (bal l v (remove x r)) (bal (remove x l) v r)))))))) (union (lambda (s1 s2) (let union ((s1 s1)(s2 s2)) (if (null? s1) s2 (if (null? s2) s1 (let ((l1 (caar s1))(v1 (cdar s1))(r1 (cadr s1))(h1 (cddr s1)) (l2 (caar s2))(v2 (cdar s2))(r2 (cadr s2))(h2 (cddr s2))) (if (>= h1 h2) (if (= h2 1) (add v2 s1) (let ((sp (split v1 s2))) (join (union l1 (car sp)) v1 (union r1 (caddr sp))))) (if (= h1 1) (add v1 s2) (let ((sp (split v2 s1))) (join (union (car sp) l2) v2 (union (caddr sp) r2))))))))))) (inter (lambda (s1 s2) (let inter ((s1 s1)(s2 s2)) (if (or (null? s1)(null? s2)) '() (let* ((l1 (caar s1))(v1 (cdar s1))(r1 (cadr s1))(sp (split v1 s2))) (if (cadr sp) (join (inter l1 (car sp)) v1 (inter r1 (caddr sp))) (concat (inter l1 (car sp)) (inter r1 (caddr sp))))))))) (diff (lambda (s1 s2) (let diff ((s1 s1)(s2 s2)) (if (null? s1) '() (if (null? s2) s1 (let* ((l1 (caar s1))(v1 (cdar s1))(r1 (cadr s1))(sp (split v1 s2))) (if (cadr sp) (concat (diff l1 (car sp)) (diff r1 (caddr sp))) (join (diff l1 (car sp)) v1 (diff r1 (caddr sp)))))))))) ; type enumeration = End | More of elt * t * enumeration ; list of dotted pairs: (elt . t) (cons_enum (lambda (s e) (let cons_enum ((s s)(e e)) (if (null? s) e (cons_enum (caar s) (cons (cons (cdar s) (cadr s)) e)))))) (compare_aux (lambda (e1 e2) (let compare_aux ((e1 e1)(e2 e2)) (if (and (null? e1)(null? e2)) 0 (if (null? e1) -1 (if (null? e2) 1 (let ((c (Icompare (caar e1) (caar e2)))) (if (= c 0) (compare_aux (cons_enum (cdar e1) (cdr e1)) (cons_enum (cdar e2) (cdr e2))) c)))))))) (compare (lambda (s1 s2) (compare_aux (cons_enum s1 '()) (cons_enum s2 '())))) (equal (lambda (s1 s2) (= 0 (compare s1 s2)))) (subset (lambda (s1 s2) (let subset ((s1 s1)(s2 s2)) (or (null? s1) (and (not (null? s2)) (let ((l1 (caar s1))(v1 (cdar s1))(r1 (cadr s1)) (l2 (caar s2))(v2 (cdar s2))(r2 (cadr s2))) (let ((c (Icompare v1 v2))) (if (= c 0) (and (subset l1 l2) (subset r1 r2)) (if (< c 0) (and (subset (cons (cons l1 v1) (cons '() 0)) l2) (subset r1 s2)) (and (subset (cons (cons '() v1) (cons r1 0)) r2) (subset l1 s2)) ))))))))) (iter (lambda (f s) (let iter ((s s)) (if (not (null? s)) (begin (iter (caar s)) (f (cdar s)) (iter (cadr s))) '())))) (fold (lambda (f s accu) (let fold ((s s)(a accu)) (if (null? s) a (fold (cadr s) (f (cdar s) (fold (caar s) a))))))) (for_all (lambda (p s) (let for_all ((s s)) (or (null? s) (and (for_all (caar s)) (p (cdar s)) (for_all (cadr s))))))) (exists (lambda (p s) (let exists ((s s)) (and (not (null? s)) (or (exists (caar s)) (p (cdar s)) (exists (cadr s))))))) (filter (lambda (p s) (let filt ((s s)) (if (null? s) '() (let ((lp (filt (caar s)))(rp (filt (cadr s)))) (if (p (cdar s)) (join lp (cdar s) rp) (concat lp rp))))))) (partition (lambda (p s) (let part ((s s)) (if (null? s) (cons '() '()) (let ((lp (part (caar s)))(rp (part (cadr s)))) (if (p (cdar s)) (cons (join (car lp) (cdar s) (car rp)) (concat (cdr lp) (cdr rp))) (cons (concat (car lp) (car rp)) (join (cdr lp) (cdar s) (cdr rp))))))))) (cardinal (lambda (s) (let num ((s s)) (if (null? s) 0 (+ 1 (num (caar s)) (num (cadr s))))))) (elements_aux (lambda (accu s) (let ea ((a accu)(s s)) (if (null? s) a (ea (cons (cdar s) (ea a (cadr s))) (caar s)))))) (elements (lambda (s) (elements_aux '() s))) (choose min_elt) (find (lambda (x s) (let fnd ((s s)) (if (null? '()) "none-such" (let ((c (Icompare x (cdar s)))) (if (= 0 c) (cdar s) (fnd ((if (< c 0) caar card) s))))))))) (let* ((pc ((fileVal "Seal"))) (se (car pc)) (us (cdr pc)) (B5 (lambda (f) (lambda (a b) (se (f a (us b)))))) (B7 (lambda (f) (lambda (a b) (se (f (us a) (us b)))))) (B10 (lambda (f) (lambda (a b c) (se (f a (us b) c))))) (b3 (lambda (f) (lambda (x) (f (us x))))) (b5 (lambda (f) (lambda (a b) (f a (us b))))) (b7 (lambda (f) (lambda (a b) (f (us a) (us b))))) (b10 (lambda (f) (lambda (a b c) (f a (us b) c)))) (Map (list (cons 'empty (se empty)) (cons 'empty? (lambda (x) (null? (us x)))) (cons 'mem (b5 mem)) (cons 'add (B5 add)) (cons 'singleton (lambda (x) (se (singleton x)))) (cons 'remove (B5 remove)) (cons 'union (B7 union)) (cons 'inter (B7 inter)) (cons 'diff (B7 diff)) (cons 'compare (b7 compare)) (cons 'equal? (b7 equal)) (cons 'subset (b7 subset)) (cons 'iter (b5 iter)) (cons 'fold (b10 fold)) (cons 'for_all (b10 for_all)) (cons 'exists (b10 exists)) (cons 'filter (lambda (a b c) (se (filter a (us b) c)))) (cons 'partition (lambda (p s) (let ((x (partition p (us s)))) (cons (se (car x)) (se (cdr x)))))) (cons 'cardinal (b3 cardinal)) (cons 'elements (b3 elements)) (cons 'min_elt (b3 min_elt)) (cons 'max_elt (b3 max_elt)) (cons 'choose (b3 choose)) (cons 'Set? (lambda (x) (and (procedure? x) (not (not (us x)))))) (cons 'split split) (cons 'find (b3 find)) (cons 'these (lambda (l) (se (these l))))))) (lambda (sy) (cdr (assq sy Map)))))) ; Tests: See ./TestSet