March 2014 update

Task/Set-consolidation/Common-Lisp/set-consolidation.lisp

@@ -0,0 +1,8 @@
+(defun consolidate (ss)
+  (labels ((comb (cs s)
+             (cond ((null s) cs)
+                   ((null cs) (list s))
+                   ((null (intersection s (first cs)))
+                    (cons (first cs) (comb (rest cs) s)))
+                   ((consolidate (cons (union s (first cs)) (rest cs)))))))
+    (reduce #'comb ss :initial-value nil)))

Task/Set-consolidation/TXR/set-consolidation-1.txr

@@ -0,0 +1,26 @@
+@(do
+   (defun mkset (p x) (set [p x] (or [p x] x)))
+
+   (defun fnd (p x) (if (eq [p x] x) x (fnd p [p x])))
+
+   (defun uni (p x y)
+     (let ((xr (fnd p x)) (yr (fnd p y)))
+       (set [p xr] yr)))
+
+   (defun consoli (sets)
+     (let ((p (hash)))
+       (each ((s sets))
+         (each ((e s))
+           (mkset p e)
+           (uni p e (car s))))
+       (hash-values
+         [group-by (op fnd p) (hash-keys
+                                [group-by identity (flatten sets)])])))
+
+   ;; tests
+
+   (each ((test '(((a b) (c d))
+                  ((a b) (b d))
+                  ((a b) (c d) (d b))
+                  ((h i k) (a b) (c d) (d b) (f g h)))))
+     (format t "~s -> ~s\n" test (consoli test))))

Task/Set-consolidation/TXR/set-consolidation-2.txr

@@ -0,0 +1,21 @@
+@(do
+   (defun mkset (items) [group-by identity items])
+
+   (defun empty-p (set) (zerop (hash-count set)))
+
+   (defun consoli (ss)
+     (defun comb (cs s)
+       (cond ((empty-p s) cs)
+             ((null cs) (list s))
+             ((empty-p (hash-isec s (first cs)))
+              (cons (first cs) (comb (rest cs) s)))
+             (t (consoli (cons (hash-uni s (first cs)) (rest cs))))))
+     [reduce-left comb ss nil])
+
+   ;; tests
+   (each ((test '(((a b) (c d))
+                  ((a b) (b d))
+                  ((a b) (c d) (d b))
+                  ((h i k) (a b) (c d) (d b) (f g h)))))
+     (format t "~s -> ~s\n" test
+             [mapcar hash-keys (consoli [mapcar mkset test])])))